{-# LANGUAGE RecordWildCards, RankNTypes #-}

module System.Hardware.Acquisition
	( Value
	, Measurement (..)
	, Sample (..)
	, Channel (..)
	, ioChannel
	, constChannel
	, Protocol (..)
	, Connection (..)
	, Adaptor
	, (=>>=)
	) where

import Prelude
import Control.Monad.Error
import Data.Word
import qualified System.IO as IO

{-| Base type for all measurements; 'Double' seems a reasonable choice. -}
type Value = Double

{-|
	All measurements normalised to SI units; base units are preferred over
	derived units.
-}
data Measurement{- {{{ -}
	= Whatever {-^ no frackin' clue whatsoever -}
	| VoltageAC {-^ Volts RMS -}
	| VoltageDC {-^ Volts -}
	| CurrentAC {-^ Amperes RMS -}
	| CurrentDC {-^ Amperes -}
	| Resistance {-^ Ohms -}
	| Capacitance {-^ Farads -}
	| Inductance {-^ Henries -}
	| Temperature {-^ Kelvins -}
	| DCGain {-^ Ratio, hFE for bipolar transistors -}
	| DutyCycle {-^ Ratio, not percentage! -}
	| Frequency {-^ Hertz -}
	| Length {-^ Metres -}
	| Illuminance {-^ Lux -}
	| Mass {-^ Kilograms -}
	| Force {-^ Newtons -}
	| Time {-^ Seconds -}
	deriving (Eq, Show){- }}} -}

data Sample = Sample{- {{{ -}
	{ measurement  :: Measurement
	, value        :: Value
	{-^
		Overload shows up as @NaN@; infinite values /ought/ to show up as
		±@Infinity@.
	-}
	} deriving (Eq, Show)

sample :: Value -> Sample
sample v = Sample { measurement = Whatever, value = v }

sampleUnOp :: (Value -> Value) -> Sample -> Sample
sampleUnOp f x = x { value = f (value x) }

sampleBinOp :: (Value -> Value -> Value) -> Sample -> Sample -> Sample
sampleBinOp (?) x y = sample (value x ? value y)

instance Num Sample where{- {{{ -}
	(+) = sampleBinOp (+)
	(*) = sampleBinOp (*)
	(-) = sampleBinOp (-)
	negate = sampleUnOp negate
	abs = sampleUnOp abs
	signum = sampleUnOp signum
	fromInteger = sample . (fromInteger :: Integer -> Value){- }}} -}

instance Fractional Sample where{- {{{ -}
	(/) = sampleBinOp (/)
	recip = sampleUnOp recip
	fromRational = sample . (fromRational :: Rational -> Value){- }}} -}

instance Floating Sample where{- {{{ -}
	pi = sample pi
	exp = sampleUnOp exp
	sqrt = sampleUnOp sqrt
	log = sampleUnOp log
	(**) = sampleBinOp (**)
	logBase = sampleBinOp logBase
	sin = sampleUnOp sin
	tan = sampleUnOp tan
	cos = sampleUnOp cos
	asin = sampleUnOp asin
	atan = sampleUnOp atan
	acos = sampleUnOp acos
	sinh = sampleUnOp sinh
	tanh = sampleUnOp tanh
	cosh = sampleUnOp cosh
	asinh = sampleUnOp asinh
	atanh = sampleUnOp atanh
	acosh = sampleUnOp acosh{- }}} -}

{- }}} -}

data Connection = Connection{- {{{ -}
	{ getWord8 :: (Error e, MonadError e m, MonadIO m) => m Word8
	, disconnect :: MonadIO m => m ()
	} deriving (){- }}} -}

data Protocol = Protocol{- {{{ -}
	{ initialise :: MonadIO m => m [Channel]
	, destroy :: MonadIO m => m ()
	} deriving (){- }}} -}

data Channel = Channel{- {{{ -}
	{ getSample :: (Error e, MonadError e m, MonadIO m) => m Sample
	, close :: MonadIO m => m ()
	} deriving ()

ioChannel :: IO Sample -> Channel
ioChannel get = Channel
	{ getSample = liftIO get
	, close = return () }

constChannel :: Sample -> Channel
constChannel = ioChannel . return

instance Eq Channel where
	_ == _ = False

instance Show Channel where
	show _ = "<<Channel>>"

channelUnOp :: (Sample -> Sample) -> Channel -> Channel
channelUnOp f c = c { getSample = return f `ap` getSample c }

channelBinOp :: (Sample -> Sample -> Sample) -> Channel -> Channel -> Channel
channelBinOp (?) a b = Channel
	{ getSample = return (?) `ap` getSample a `ap` getSample b
	, close = return () }

instance Num Channel where{- {{{ -}
	(+) = channelBinOp (+)
	(*) = channelBinOp (*)
	(-) = channelBinOp (-)
	negate = channelUnOp negate
	abs = channelUnOp abs
	signum = channelUnOp signum
	fromInteger = constChannel . fromInteger{- }}} -}

instance Fractional Channel where{- {{{ -}
	(/) = channelBinOp (/)
	recip = channelUnOp recip
	fromRational = constChannel . fromRational{- }}} -}

instance Floating Channel where{- {{{ -}
	pi = constChannel pi
	exp = channelUnOp exp
	sqrt = channelUnOp sqrt
	log = channelUnOp log
	(**) = channelBinOp (**)
	logBase = channelBinOp logBase
	sin = channelUnOp sin
	tan = channelUnOp tan
	cos = channelUnOp cos
	asin = channelUnOp asin
	atan = channelUnOp atan
	acos = channelUnOp acos
	sinh = channelUnOp sinh
	tanh = channelUnOp tanh
	cosh = channelUnOp cosh
	asinh = channelUnOp asinh
	atanh = channelUnOp atanh
	acosh = channelUnOp acosh{- }}} -}

{- }}} -}

type Adaptor m = Channel -> m Channel
(=>>=) :: Monad m => Adaptor m -> Adaptor m -> Adaptor m
(a =>>= b) c = a c >>= b