blink1 0.3 → 0.3.1

raw patch · 6 files changed

+95/−33 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• System/Hardware/Blink1.hs +8/−8
• System/Hardware/Blink1/Class.hs +1/−0
• System/Hardware/Blink1/Linux.hs +0/−1
• System/Hardware/Blink1/Types.hs +84/−19
• System/Hardware/Blink1/USB.hs +1/−4
• blink1.cabal +1/−1

@@ -1,5 +1,5 @@ module System.Hardware.Blink1-  ( RGB(..)+  ( RGB(..), RGB8   , Delay(..)   , PatternStep @@ -20,7 +20,7 @@ import Data.Bits (shiftR, shiftL, (.|.)) import Data.Char (chr, ord) import Data.List (foldl')-import Data.Word (Word16, Word32)+import Data.Word import System.Hardware.Blink1.Class import System.Hardware.Blink1.Types @@ -28,7 +28,7 @@ reportId = 1  msgLen :: Int-msgLen = 8+msgLen = 7  fi :: (Integral a, Num b) => a -> b fi = fromIntegral@@ -53,7 +53,7 @@   _:_:maj:min:_ <- request b 'v' []   return (chr (fi maj), chr (fi min)) -rgb :: RGB -> [Word8]+rgb :: RGB8 -> [Word8] rgb (RGB r g b) = [r,g,b]  delay :: Delay -> [Word8]@@ -65,10 +65,10 @@ pos p = [fi (fromEnum p)]  -- | set the given color now-setColor :: Blink1 b => b -> RGB -> IO ()+setColor :: Blink1 b => b -> RGB8 -> IO () setColor b c = command b 'n' $ rgb c -fadeToColor :: Blink1 b => b -> Delay -> RGB -> IO ()+fadeToColor :: Blink1 b => b -> Delay -> RGB8 -> IO () fadeToColor b d c = command b 'c' $ rgb c ++ delay d  -- | enable/disable serverdown mode@@ -81,10 +81,10 @@ playPattern b (Just p) = command b 'p' $ 1 : pos p  -- | set the sequence pattern for the given position-setPattern :: Blink1 b => b -> PatternStep -> Delay -> RGB -> IO ()+setPattern :: Blink1 b => b -> PatternStep -> Delay -> RGB8 -> IO () setPattern b p d c = command b 'P' $ rgb c ++ delay d ++ pos p -getPattern :: Blink1 b => b -> PatternStep -> IO (Delay, RGB)+getPattern :: Blink1 b => b -> PatternStep -> IO (Delay, RGB8) getPattern b p = do   _:r:g:b:d1:d2:_ <- request b 'R' $ rgb black ++ delay 0 ++ pos p   return (fi (i d1 `shiftL` 8 .|. i d2) / 100, RGB r g b)

@@ -1,5 +1,6 @@ module System.Hardware.Blink1.Class   ( Blink1(..)+  , Word8   , blink1Vendor, blink1Product   ) where 

@@ -18,7 +18,6 @@ import Foreign.Marshal.Array  import System.Linux.HIDRaw-import System.Hardware.Blink1.Types import System.Hardware.Blink1.Class  newtype Blink1Raw = Blink1Raw Fd

@@ -1,32 +1,62 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances, TypeSynonymInstances #-} module System.Hardware.Blink1.Types-  ( Word8-  , RGB(..)+  ( RGB(..), RGB8   , black   , Delay(..)+  , second   , PatternStep(..)   , EEPROMAddr(..)   , serialNumLen   ) where -import Data.Word (Word8)-import Data.Fixed (Centi)+import Control.Applicative+import Control.Arrow ((***))+import Data.Fixed (HasResolution(..), Centi)+import Data.Monoid (Monoid(..))+import Data.Word (Word8, Word16) import Numeric (showHex, readHex) -data RGB = RGB { red, green, blue :: !Word8 }+data RGB a = RGB { red, green, blue :: !a }+type RGB8 = RGB Word8 -black :: RGB+black :: RGB8 black = RGB 0 0 0 +instance Functor RGB where+  fmap f (RGB r g b) = RGB (f r) (f g) (f b)+instance Applicative RGB where+  pure x = RGB x x x+  RGB fr fg fb <*> RGB r g b = RGB (fr r) (fg g) (fb b)++instance Num a => Num (RGB a) where+  (+) = liftA2 (+)+  (-) = liftA2 (-)+  (*) = liftA2 (*)+  negate = fmap negate+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++clipAdd :: (Num a, Ord a, Bounded a) => a -> a -> a+clipAdd x y +  | z < x = maxBound+  | otherwise = z+  where z = x + y++-- |like 'Sum' but clips overflowing values at 'maxBound'+instance (Num a, Ord a, Bounded a) => Monoid (RGB a) where+  mempty = 0+  mappend = liftA2 clipAdd+ showHex2 :: Word8 -> ShowS showHex2 x   | x < 16 = showChar '0' . showHex x   | otherwise = showHex x -instance Show RGB where+-- |uses #RRGGBB format+instance Show RGB8 where   showsPrec _ (RGB r g b) = showChar '#' . showHex2 r . showHex2 g . showHex2 b--instance Read RGB where+instance Read RGB8 where   readsPrec _ ('#':c) = rc2 c ++ rc1 c where     rc1 (r:g:b:s) = rc (0x11*) [r] [g] [b] s     rc1 _ = []@@ -39,21 +69,56 @@       return (RGB (f r) (f g) (f b), s)   readsPrec _ _ = [] --- | time is counted in centiseconds-newtype Delay = Delay { delayCentiseconds :: Centi } deriving (Eq, Ord, Num, Real, Fractional, RealFrac)+-- | time is measured in centiseconds+newtype Delay = Delay { delayCentiseconds :: Word16 } deriving (Bounded, Eq, Ord, Enum) -instance Bounded Delay where-  minBound = Delay 0-  maxBound = Delay 655.36+sec :: Num a => a+sec = 100 +second :: Delay+second = Delay sec++-- This boiler-plate fixed-point is all possibly over-kill, but is hopefully at least unambiguous, and better than using Centi+instance HasResolution Delay where+  resolution _ = sec++-- | operations are based on seconds+instance Num Delay where+  Delay x + Delay y = Delay (x + y)+  Delay x - Delay y = Delay (x - y)+  Delay x * Delay y = Delay (x * y `div` sec) -- XXX: overflow+  negate (Delay x) = Delay (negate x)+  abs (Delay x) = Delay (abs x)+  signum (Delay x) = Delay (signum x * sec)+  fromInteger i = Delay (fromInteger i * sec)+instance Real Delay where+  toRational (Delay x) = toRational x / sec+instance Fractional Delay where+  Delay x / Delay y = Delay (x * sec `div` y) -- XXX: overflow+  recip (Delay x) = Delay (sec * sec `div` x)+  fromRational r = Delay (floor (r * sec))+instance RealFrac Delay where+  properFraction (Delay x) = fromIntegral *** Delay $ x `divMod` sec+  truncate (Delay x) = fromIntegral (x `div` sec)+  round (Delay x) = truncate (Delay (x + (pred sec `div` 2)))+  ceiling (Delay x) = truncate (Delay (x + pred sec))+  floor x = truncate x -- unsigned!+ instance Show Delay where-  showsPrec p (Delay s) = showsPrec p s . showChar 's'-#if MIN_VERSION_base(4,4,0)+  showsPrec p d = showsPrec p (realToFrac d :: Centi) . showChar 's' instance Read Delay where   readsPrec p = map f . readsPrec p where-    f (x,'s':s) = (Delay x, s)-    f (x,s) = (Delay x, s)+    f (x,'s':s) = (realToFrac x, s)+    f (x,'c':'s':s) = (Delay (floor x), s)+    f (x,'m':'s':s) = (Delay (floor x `div` 10), s)+    f (x,s) = (realToFrac (x ::+#if MIN_VERSION_base(4,4,0)+        Centi+#else+        Float #endif+      ), s)+  -- | positions are counted 0-11 newtype PatternStep = PatternStep Word8 deriving (Eq, Ord, Enum, Num, Show, Read)

@@ -7,13 +7,11 @@   ) where  import Control.Monad-import System.IO.Error (ioError, mkIOError, doesNotExistErrorType)+import System.IO.Error (mkIOError, doesNotExistErrorType) import System.USB-import Bindings.Libusb.Descriptors (c'LIBUSB_CLASS_PER_INTERFACE, c'LIBUSB_CLASS_HID) import qualified Data.Vector as V import qualified Data.ByteString as BS (pack, unpack) import qualified Data.Text as Text (unpack)-import System.Hardware.Blink1.Types import System.Hardware.Blink1.Class  newtype Blink1USB = Blink1USB DeviceHandle@@ -22,7 +20,6 @@ findUSBDev ctx = V.filterM (return . f <=< getDeviceDesc) =<< getDevices ctx where   f d = deviceVendorId d == blink1Vendor      && deviceProductId d == blink1Product -    && deviceClass d == c'LIBUSB_CLASS_PER_INTERFACE      && deviceNumConfigs d == 1     -- ideally we should check the interfaces, but blink(1) only has one 

@@ -1,5 +1,5 @@ Name:		blink1-Version:	0.3+Version:	0.3.1 Author:		Dylan Simon Maintainer:     dylan@dylex.net License:        BSD3