{-# LANGUAGE RecordWildCards #-}

module System.Hardware.Acquisition.Protocol.QM1537 (protocol) where

import Prelude
import Control.Applicative
import Control.Monad.Error
import Data.Maybe
import Data.Word
import Data.Bits
import Text.Printf

-- Measurement constructors clashes with local definition of Mode
import System.Hardware.Acquisition hiding (Measurement (..))
import qualified System.Hardware.Acquisition as Acquisition

-- | Each packet is terminated by a 0x0d 0x0a (i.e. CR LF) pair, for a total
-- of 14 bytes, inclusive. We don't store the terminator here though.
newtype RawPacket = RP [Word8] deriving ()

-- | These should go into some common interface module
data Multiplier{- {{{ -}
	= Femto
	| Pico
	| Nano
	| Micro
	| Milli
	| Unit
	| Kilo
	| Mega
	| Giga
	deriving (Show, Enum)
valM :: Multiplier -> Value
valM m = 1000 ^^ (fromEnum m - fromEnum Unit){- }}} -}

data Digit = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9{- {{{ -}
	deriving (Show, Enum)
valD :: Digit -> Value
valD = fromIntegral . fromEnum{- }}} -}

data Dot = E0 | E1 | E2 | E3{- {{{ -}
	deriving (Show, Enum)
valE :: Dot -> Value
valE e = 10 ^^ (fromEnum e - fromEnum E0){- }}} -}

data MinMax = Min | Max deriving (Show)

data Mode
	= DutyCycle
	| Voltage
	| Current
	| Resistance
	| DCGain
	| Frequency
	| Capacitance
	| Celsius
	| Farenheit
	deriving (Show)

data Packet = Packet{- {{{ -}
	{ negative     :: Bool
	-- significands, MSD to LSD, each ranging from 0 to 9
	, s3           :: Maybe Digit
	, s2           :: Maybe Digit
	, s1           :: Maybe Digit
	, s0           :: Maybe Digit
	, dot          :: Dot
	, autorange    :: Bool
	, alternating  :: Bool
	, relative     :: Bool
	, hold         :: Bool
	, minmax       :: Maybe MinMax
	, multiplier   :: Multiplier
	, mode         :: Mode
	, bars         :: Int
	} deriving (Show){- }}} -}

-- display shows s3 . s2 s1 s0 * 10^dot
-- value is display * multiplier

getPacket :: (Error e, MonadError e m, MonadIO m) => Connection -> m RawPacket{- {{{ -}
getPacket conn = gp [] where
	gp :: (Error e, MonadError e m, MonadIO m) => [Word8] -> m RawPacket
	gp (0x0a : 0x0d : packet) = do
		let p = take 12 packet
		case length p == 12 of
			True -> return (RP (reverse p))
			False -> gp []
	gp acc = do
		b <- getWord8 conn
{- 		liftIO (print b) -}
		gp (b : acc){- }}} -}

throwMsg :: (Error e, MonadError e m) => String -> m alpha
throwMsg = throwError . strMsg

parsePacket :: (Error e, MonadError e m) => RawPacket -> m Packet{- {{{ -}
parsePacket (RP [b0, b1, b2, b3, b4, b5, b6, f3@b7, f2@b8, f1@b9, f0@ba, bb]) = do
	let (?) :: Word8 -> Int -> Bool
	    (?) = testBit

	negative <- case b0 of
		0x2b{-'+'-} -> return False
		0x2d{-'-'-} -> return True
		_   -> throwMsg "this is not a sign"

	let parseDigit :: Monad m => Word8 -> m (Maybe Digit)
	    parseDigit b = case 0x30{-'0'-} <= b && b <= 0x39{-'9'-} of
		True -> (return . Just . toEnum . fromIntegral) (b - 0x30)
		False -> return Nothing
	s3 <- parseDigit b1
	s2 <- parseDigit b2
	s1 <- parseDigit b3
	s0 <- parseDigit b4

	unless (b5 == 0x20{-' '-}) $ do
		throwMsg "expected a space character"

	dot <- case b6 of
		0x31{-'1'-} -> return E0
		0x32{-'2'-} -> return E1
		0x34{-'4'-} -> return E2
		0x30{-'0'-} -> return E3
		_   -> throwMsg "not a valid exponent"

	{- 	let f3 = b7; f2 = b8; f1 = b9; f0 = ba -}

	let autorange = f3 ? 5
	alternating <- case (f3 ? 3, f3 ? 4) of
		(True, True) -> throwMsg "AC/DC?"
		(alt, _) -> return alt

	let relative = f3 ? 2

	let hold = f3 ? 1
	minmax <- case (f2 ? 5, f2 ? 4) of
		(False, False) -> return Nothing
		(False, True) -> return (Just Min)
		(True, False) -> return (Just Max)
		(True, True) -> throwMsg "cannot be both min and max"

	multiplier <- case (f2 ? 1, f1 ? 7, f1 ? 6, f1 ? 5, f1 ? 4) of
		(True,  False, False, False, False) -> return Nano
		(False, True,  False, False, False) -> return Micro
		(False, False, True,  False, False) -> return Milli
		(False, False, False, False, False) -> return Unit
		(False, False, False, True,  False) -> return Kilo
		(False, False, False, False, True ) -> return Mega
		_ -> throwMsg "cannot be in more than one range"

	mode <- case (f1 ? 1, f0 ? 7, f0 ? 6, f0 ? 5, f0 ? 4, f0 ? 3, f0 ? 2, f0 ? 1, f0 ? 0) of
		(True,  False, False, False, False, False, False, False, False) -> return DutyCycle
		(False, True,  False, False, False, False, False, False, False) -> return Voltage
		(False, False, True,  False, False, False, False, False, False) -> return Current
		(False, False, False, True,  False, False, False, False, False) -> return Resistance
		(False, False, False, False, True,  False, False, False, False) -> return DCGain
		(False, False, False, False, False, True,  False, False, False) -> return Frequency
		(False, False, False, False, False, False, True,  False, False) -> return Capacitance
		(False, False, False, False, False, False, False, True,  False) -> return Celsius
		(False, False, False, False, False, False, False, False, True ) -> return Farenheit
		_ -> throwMsg "cannot be in more than one mode"

	bars <- do
		let sign = if bb ? 7 then -1 else 1
		let magnitude = fromIntegral (bb .&. 0x7f)
		return (sign * magnitude)

	return Packet {..}
parsePacket _ = throwMsg "how on earth did we get here?!"{- }}} -}

normalise :: Packet -> Sample{- {{{ -}
normalise Packet {..} = Sample {..} where
	nan, infinity :: Value
	nan = 0 / 0; infinity = 1 / 0
	(measurement, adjust, oops) = case mode of
		DutyCycle -> (Acquisition.DutyCycle, (/ 100), nan)
		Voltage -> (if alternating then Acquisition.VoltageAC else Acquisition.VoltageDC, id, nan)
		Current -> (if alternating then Acquisition.CurrentAC else Acquisition.CurrentDC, id, nan)
		Resistance -> (Acquisition.Resistance, id, infinity)
		DCGain -> (Acquisition.DCGain, id, nan)
		Frequency -> (Acquisition.Frequency, id, nan)
		Capacitance -> (Acquisition.Capacitance, id, nan)
		Celsius -> (Acquisition.Temperature, (+ 273.15), nan)
		Farenheit -> (Acquisition.Temperature, (\ f -> (f + 459.67) * 5 / 9), nan)
	value :: Value
	value = adjust (sign * sum vs * valE dot * valM multiplier) where
		digits = map (maybe oops valD) [s3, s2, s1, s0]
		sign = if negative then -1 else 1
		vs = zipWith (\ n d -> 10 ^^ negate n * d) [0..] digits
{- }}} -}

protocol :: Connection -> Protocol{- {{{ -}
protocol conn = Protocol {..} where

	initialise :: MonadIO m => m [Channel]
	initialise = do
		let getSample :: (Error e, MonadError e m, MonadIO m) => m Sample
		    getSample = do
			raw <- getPacket conn
			return normalise `ap` parsePacket raw
		let close :: MonadIO m => m ()
		    close = return ()
		return [Channel {..}]

	destroy :: MonadIO m => m ()
	destroy = return ()

{- }}} -}