AFRPUtils.hs

{-# LANGUAGE 
  GADTs, 
  EmptyDataDecls,
  TypeFamilies, 
  TypeOperators
  #-}

-- | This module provides some utilities for writing drivers of
-- signal functions. 
module Nettle.FRPControl.AFRPUtils
    (
     -- * Type-level lists
     Nil, 
     (:::), 

     -- * Value-level representation of type-level lists
     Rep (..), 

     -- * Event-source vector
     SFInput(..), 

     -- * List of sensor channels
     SensorChans,

     -- * Output vector
     SFOutput(..), 

     -- * List of actuator actions
     Actuators,

     -- * Driver
     sfDriver

    ) where

import Control.Concurrent
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Control.Monad
import Nettle.FRPControl.AFRP 
import Data.Monoid hiding (All)

-- Heterogeneous lists of types

-- | Empty list.
data Nil 

-- | Cons list
data (:::) x xs = (:::) (x, xs)

-- | Infix operator; synonymous with TCons.
infixr 5 :::

-- | Value level representation of type level lists.
data Rep a where
    RNil  :: Rep Nil
    RCons :: Rep b -> Rep (a ::: b)

-- |Input types for each heterogeneous type list.
type family SFInput t
type instance SFInput Nil          = () 
type instance SFInput ((:::) x xs) = (Maybe x, SFInput xs) 

-- | Injects the missing value into an SFInput type.
missing :: Rep a -> SFInput a 
missing RNil       = ()
missing (RCons rb) = (Nothing, missing rb)

-- | Vector of Sensor channels of the right types
type family SensorChans t
type instance SensorChans Nil = ()
type instance SensorChans (a ::: bs) = (Chan a, SensorChans bs)

-- | Make a sensor for SFInput s values, given a collection of SensorChans.
mkSensor :: Rep s -> SensorChans s -> IO (Chan (SFInput s))
mkSensor RNil ()                = newChan
mkSensor (RCons rb) (aCh, bChs) = 
    do bCh <- mkSensor rb bChs 
       multiplexChanPair rb aCh bCh

-- Helper function, used in mkSensor above.
multiplexChanPair :: Rep b -> 
                     Chan a -> 
                     Chan (SFInput b) -> 
                     IO (Chan (SFInput (a ::: b))) 
multiplexChanPair RNil aCh _ = do                       
  abCh <- newChan
  forkIO $ forever (readChan aCh >>= writeChan abCh . (\a -> (Just a, ())))
  return abCh
multiplexChanPair rb aCh bCh = do 
  abCh <- newChan
  forkIO $ readWriter aCh (\a -> (Just a, missing rb)) abCh
  forkIO $ readWriter bCh (\b -> (Nothing, b)) abCh
  return abCh
      where readWriter srcCh f destCh = 
                forever (readChan srcCh >>= writeChan destCh . f)


-- |Output type for each heterogeneous list 
type family SFOutput t 
type instance SFOutput Nil        = ()
type instance SFOutput (a ::: bs) = (a, SFOutput bs)

-- Vector of Actuator actions of the right types
type family Actuators t
type instance Actuators Nil       = ()
type instance Actuators (a ::: bs) = (a -> IO (), Actuators bs)

-- Make an actuator given a representation of type s, and 
-- an actuator list of shape s.
actuateVector :: Rep s -> Actuators s -> SFOutput s -> IO ()
actuateVector RNil () ()
    = return ()
actuateVector (RCons rb) (actA, actsB) (a, b)
    = actA a >> actuateVector rb actsB b


-- | Drives signal functions with the given collection of sensor channels
-- and actuator actions. It multiplexes the sensors into a single channel of events.
sfDriver :: Rep s                            -- ^ Representation of the shape of the @SensorChans@ argument
            -> SensorChans s                 -- ^ Sensor channels
            -> Rep t                         -- ^ Representation of the shape of the actuator argument
            -> Actuators t                   -- ^ Actuators
            -> SF (SFInput s) (SFOutput t)   -- ^ Signal function to drive
            -> IO ()                         
sfDriver repS chS repT chT sf = 
  do 
    sensorCh      <- mkSensor repS chS
    let actuator  = actuateVector repT chT
    let sense     = readChan sensorCh
    let a0        = missing repS
    let aMissing  = Just (missing repS)
    sfDriverAux a0 sense aMissing actuator sf


------------- INTERNAL ----------------

sfDriverAux :: a -> IO a -> Maybe a -> (b -> IO ()) -> SF a b -> IO ()
sfDriverAux a0 sensor clockInput actuator sf = do 

  lastSenseTimeVar <- newEmptyMVar
  inCh             <- newChan :: IO (Chan (Maybe a))
  let initiator = initReact lastSenseTimeVar
  let sensor''  = sensor' inCh lastSenseTimeVar
  forkIO $ genClockSignal inCh
  forkIO $ genNormalSignal inCh
  reactimate initiator sensor'' actuator' sf

    where 

      initReact lastSenseTimeVar = 
          do
            t <- getCurrentTime
            putMVar lastSenseTimeVar t
            return a0
  
      sensor' ch lastSenseTimeVar _ = 
          do 
            ma <- readChan ch
            t' <- getCurrentTime
            t  <- swapMVar lastSenseTimeVar t'
            let delta = fromRational (toRational (diffUTCTime t' t))
            return (delta, ma)

      actuator' changed b = actuator b >> return False

      genClockSignal ch  = 
          forever (threadDelay clockCycle >> writeChan ch clockInput)
          where clockCycle = 1000

      genNormalSignal ch = forever (sensor >>= writeChan ch . Just)