module Graphics.V4L2.Control
( ControlID()
, MenuID()
, ControlFlag(..)
, ControlInfo(..)
, queryControls
, Activate(..)
, ControlData()
, getControl
, setControl
) where
import Control.Exception as E (catch, throwIO)
import Control.Monad (liftM)
import Data.Data (Data)
import Data.Int (Int32)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Foreign.Marshal.Utils (fromBool, toBool)
import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type)
import Bindings.Linux.VideoDev2
import Foreign.Extra.BitSet (fromBitSet)
import Foreign.Extra.String (fromString)
import Graphics.V4L2.Device (Device)
import Graphics.V4L2.IOCtl (ioctl, ioctl_, zero)
newtype ControlID = ControlID Int
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
newtype MenuID = MenuID Int
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
data ControlFlag
= ControlDisabled
| ControlGrabbed
| ControlReadOnly
| ControlUpdate
| ControlInactive
| ControlSlider
| ControlWriteOnly
| ControlUnknown Word32
deriving (Eq, Ord, Read, Show, Data, Typeable)
fromControlFlag :: Word32 -> Set ControlFlag
fromControlFlag = fromBitSet
[ ( ControlDisabled , c'V4L2_CTRL_FLAG_DISABLED )
, ( ControlGrabbed , c'V4L2_CTRL_FLAG_GRABBED )
, ( ControlReadOnly , c'V4L2_CTRL_FLAG_READ_ONLY )
, ( ControlUpdate , c'V4L2_CTRL_FLAG_UPDATE )
, ( ControlInactive , c'V4L2_CTRL_FLAG_INACTIVE )
, ( ControlSlider , c'V4L2_CTRL_FLAG_SLIDER )
, ( ControlWriteOnly , c'V4L2_CTRL_FLAG_WRITE_ONLY )
] ControlUnknown
data ControlInfo
= ControlInteger { controlName :: String, controlFlags :: Set ControlFlag, controlDefaultInt, controlMinimum, controlMaximum, controlStep :: Int }
| ControlBoolean { controlName :: String, controlFlags :: Set ControlFlag, controlDefaultBool :: Bool }
| ControlButton { controlName :: String, controlFlags :: Set ControlFlag }
| ControlInteger64{ controlName :: String, controlFlags :: Set ControlFlag }
| ControlString { controlName :: String, controlFlags :: Set ControlFlag, controlLengthWithout0 :: Int }
| ControlMenu { controlName :: String, controlFlags :: Set ControlFlag, controlDefaultMenu :: MenuID, controlMenu :: Map MenuID String }
deriving (Eq, Ord, Read, Show, Data, Typeable)
queryControls :: Device -> IO (Map ControlID ControlInfo)
queryControls d = do
cs1 <- (M.fromList . catMaybes) `fmap` mapM (queryctrl d) [c'V4L2_CID_BASE .. c'V4L2_CID_LASTP1 1]
cs2 <- M.fromList `fmap` unfoldM q (c'V4L2_CID_PRIVATE_BASE)
return $ cs1 `M.union` cs2
where
q c = fmap (flip (,) (c + 1)) `fmap` queryctrl d c
queryctrl :: Device -> ControlID -> IO (Maybe (ControlID, ControlInfo))
queryctrl d n = do
mq <- (return . Just =<< ioctl d C'VIDIOC_QUERYCTRL . (\s->s{ c'v4l2_queryctrl'id = fromIntegral n }) =<< zero
) `E.catch` (\e -> case ioe_type e of
InvalidArgument -> return Nothing
_ -> throwIO e)
case mq of
Nothing -> return Nothing
Just q -> return . Just . (,) n =<< case c'v4l2_queryctrl'type q of
x | x == c'V4L2_CTRL_TYPE_INTEGER -> return ControlInteger
{ controlName = fromString $ c'v4l2_queryctrl'name q
, controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q
, controlDefaultInt = fromIntegral $ c'v4l2_queryctrl'default_value q
, controlMinimum = fromIntegral $ c'v4l2_queryctrl'minimum q
, controlMaximum = fromIntegral $ c'v4l2_queryctrl'maximum q
, controlStep = fromIntegral $ c'v4l2_queryctrl'step q }
| x == c'V4L2_CTRL_TYPE_BOOLEAN -> return ControlBoolean
{ controlName = fromString $ c'v4l2_queryctrl'name q
, controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q
, controlDefaultBool = toBool $ c'v4l2_queryctrl'default_value q }
| x == c'V4L2_CTRL_TYPE_BUTTON -> return ControlButton
{ controlName = fromString $ c'v4l2_queryctrl'name q
, controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q }
| x == c'V4L2_CTRL_TYPE_INTEGER64 -> return ControlInteger64
{ controlName = fromString $ c'v4l2_queryctrl'name q
, controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q }
| x == c'V4L2_CTRL_TYPE_STRING -> return ControlString
{ controlName = fromString $ c'v4l2_queryctrl'name q
, controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q
, controlLengthWithout0 = fromIntegral $ c'v4l2_queryctrl'maximum q }
| x == c'V4L2_CTRL_TYPE_MENU -> (\m -> ControlMenu
{ controlName = fromString $ c'v4l2_queryctrl'name q
, controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q
, controlDefaultMenu = fromIntegral $ c'v4l2_queryctrl'default_value q
, controlMenu = m }) `fmap` querymenus d n (fromIntegral $ c'v4l2_queryctrl'minimum q) (fromIntegral $ c'v4l2_queryctrl'maximum q)
| otherwise -> error "queryctrl"
querymenus :: Device -> ControlID -> MenuID -> MenuID -> IO (Map MenuID String)
querymenus d c mi ma = (M.fromList . catMaybes) `fmap` mapM (querymenu d c) [mi .. ma]
querymenu :: Device -> ControlID -> MenuID -> IO (Maybe (MenuID, String))
querymenu d c m = do
i <- (return . Just =<< ioctl d C'VIDIOC_QUERYMENU . (\s->s{ c'v4l2_querymenu'id = fromIntegral c, c'v4l2_querymenu'index = fromIntegral m }) =<< zero
) `E.catch` (\e -> case ioe_type e of
InvalidArgument -> return Nothing
_ -> throwIO e)
return $ case i of
Nothing -> Nothing
Just fs -> Just (m, fromString $ c'v4l2_querymenu'name fs)
class ControlData d where
toControlData :: d -> Int32
fromControlData :: Int32 -> d
instance ControlData Bool where
toControlData = fromBool
fromControlData = toBool
instance ControlData MenuID where
toControlData = fromIntegral
fromControlData = fromIntegral
instance ControlData Int32 where
toControlData = id
fromControlData = id
data Activate = Activate
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable)
instance ControlData Activate where
toControlData Activate = 0
fromControlData _ = Activate
getControl :: ControlData d => Device -> ControlID -> IO d
getControl d c = return . fromControlData . c'v4l2_control'value =<< ioctl d C'VIDIOC_G_CTRL . (\s->s{ c'v4l2_control'id = fromIntegral c }) =<< zero
setControl :: ControlData d => Device -> ControlID -> d -> IO ()
setControl d c x = ioctl_ d C'VIDIOC_S_CTRL . (\s->s{ c'v4l2_control'id = fromIntegral c, c'v4l2_control'value = toControlData x }) =<< zero
unfoldM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]
unfoldM f b = do
fb <- f b
case fb of
Just (a, b') -> (a :) `liftM` unfoldM f b'
Nothing -> return []