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
import System.Hardware.Acquisition hiding (Measurement (..))
import qualified System.Hardware.Acquisition as Acquisition
newtype RawPacket = RP [Word8] deriving ()
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
, 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)
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
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 <= b && b <= 0x39 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 -> return E0
0x32 -> return E1
0x34 -> return E2
0x30 -> return E3
_ -> throwMsg "not a valid exponent"
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 ()