{-# LANGUAGE RecordWildCards #-}

module System.Hardware.Acquisition.Adaptor.Continuous
	( adaptor
	) where

import Prelude
import Control.Monad.Error
import Control.Concurrent
import Control.Concurrent.STM
import Data.Foldable
import Data.Traversable

import System.Hardware.Acquisition as Acquisition

-- would like to have Error e => Either e Sample, but no cigar
type Concrete = Either String Sample

{-|
	Makes a blocking protocol non-blocking, by launching a background reader
	thread. Repeated reads through this adaptor returns the previously read
	value of the underlying protocol.
-}
adaptor :: MonadIO m => Adaptor m
adaptor c = liftIO $ do
	sv <- atomically (newTVar Nothing)

	tid <- forkOS . forever $ do
		s <- runErrorT (getSample c) :: IO Concrete
		atomically (writeTVar sv (Just s))

	let getSample :: (Error e, MonadError e m, MonadIO m) => m Sample
	    getSample = do
		c <- liftIO . atomically $ do
			ms <- readTVar sv
			case ms of
				Just s -> return s
				Nothing -> retry
		case c of
			Left e -> throwError (strMsg e)
			Right s -> return s

	let close :: MonadIO m => m ()
	    close = liftIO (killThread tid)

	return Channel {..}