large portion
[hsv4l2:phischus-v4l2.git] / Graphics / V4L2 / VideoInput.hs
1 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2 {- |
3 Module      : Graphics.V4L2.VideoInput
4 Maintainer  : claudiusmaximus@goto10.org
5 Stability   : no
6 Portability : no
7 -}
8 module Graphics.V4L2.VideoInput
9   ( VideoInputID()
10   , VideoInputInfo(..)
11   , VideoInputType(..)
12   , VideoInputStatus(..)
13   , VideoInputCapability(..)
14   , videoInputs
15   , getVideoInput
16   , setVideoInput
17   ) where
18
19 import Prelude hiding (catch)
20
21 import Control.Exception (catch, throwIO)
22 import Data.Bits (testBit)
23 import Data.Data (Data)
24 import Data.Map (Map)
25 import qualified Data.Map as M
26 import Data.Set (Set)
27 import qualified Data.Set as S
28 import Data.Typeable (Typeable)
29 import Data.Word (Word32)
30 import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type)
31
32 import Bindings.Linux.VideoDev2
33
34 import Foreign.Extra.CEnum (fromCEnum)
35 import Foreign.Extra.BitSet (fromBitSet)
36 import Foreign.Extra.String (fromString)
37 import Graphics.V4L2.Device (Device)
38 import Graphics.V4L2.IOCtl (ioctl, ioctl_, ioctl', zero)
39 import Graphics.V4L2.VideoStandard (VideoStandard)
40 import Graphics.V4L2.VideoStandard.Internal (fromVideoStandard)
41
42
43 c'V4L2_IN_CAP_PRESETS :: Word32
44 c'V4L2_IN_CAP_PRESETS = 1
45 c'V4L2_IN_CAP_CUSTOM_TIMINGS :: Word32
46 c'V4L2_IN_CAP_CUSTOM_TIMINGS = 2
47 c'V4L2_IN_CAP_STD :: Word32
48 c'V4L2_IN_CAP_STD = 4
49 newtype AudioInputID = AudioInputID Int
50   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
51 newtype TunerID = TunerID Int
52   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
53
54 {- |  Video input index. -}
55 newtype VideoInputID = VideoInputID Int
56   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
57
58 {- |  Video input info. -}
59 data VideoInputInfo = VideoInputInfo
60   { videoInputName       :: String
61   , videoInputType       :: VideoInputType
62   , videoInputAudio      :: Set AudioInputID
63   , videoInputTuner      :: Set TunerID
64   , videoInputStandard   :: VideoStandard
65   , videoInputStatus     :: Set VideoInputStatus
66   , videoInputCapability :: Set VideoInputCapability
67   }
68   deriving (Eq, Ord, Read, Show, Typeable)
69
70 {- |  Video input type. -}
71 data VideoInputType
72   = TunerInput
73   | CameraInput
74   | UnknownInput Word32
75   deriving (Eq, Ord, Read, Show, Data, Typeable)
76
77 fromVideoInputType :: Word32 -> VideoInputType
78 fromVideoInputType = fromCEnum
79   [ ( TunerInput  , c'V4L2_INPUT_TYPE_TUNER  )
80   , ( CameraInput , c'V4L2_INPUT_TYPE_CAMERA )
81   ]   UnknownInput
82
83 {- |  Video input status. -}
84 data VideoInputStatus
85   = NoPower
86   | NoSignal
87   | NoColor
88   | HFlip
89   | VFlip
90   | NoHLock
91   | ColorKill
92   | NoSync
93   | NoEqu
94   | NoCarrier
95   | Macrovision
96   | NoAccess
97   | Vtr
98   | UnknownStatus Word32
99   deriving (Eq, Ord, Read, Show, Data, Typeable)
100
101 fromVideoInputStatus :: Word32 -> Set VideoInputStatus
102 fromVideoInputStatus = fromBitSet
103   [ ( NoPower     , c'V4L2_IN_ST_NO_POWER    )
104   , ( NoSignal    , c'V4L2_IN_ST_NO_SIGNAL   )
105   , ( NoColor     , c'V4L2_IN_ST_NO_COLOR    )
106   , ( HFlip       , c'V4L2_IN_ST_HFLIP       )
107   , ( VFlip       , c'V4L2_IN_ST_VFLIP       )
108   , ( NoHLock     , c'V4L2_IN_ST_NO_H_LOCK   )
109   , ( ColorKill   , c'V4L2_IN_ST_COLOR_KILL  )
110   , ( NoSync      , c'V4L2_IN_ST_NO_SYNC     )
111   , ( NoEqu       , c'V4L2_IN_ST_NO_EQU      )
112   , ( NoCarrier   , c'V4L2_IN_ST_NO_CARRIER  )
113   , ( Macrovision , c'V4L2_IN_ST_MACROVISION )
114   , ( NoAccess    , c'V4L2_IN_ST_NO_ACCESS   )
115   , ( Vtr         , c'V4L2_IN_ST_VTR         )
116   ]   UnknownStatus
117
118 {- |  Video input capabilitites. -}
119 data VideoInputCapability
120   = Presets
121   | CustomTimings
122   | InputStd
123   | UnknownCapability Word32
124   deriving (Eq, Ord, Read, Show, Data, Typeable)
125
126 fromVideoInputCapability :: Word32 -> Set VideoInputCapability
127 fromVideoInputCapability = fromBitSet
128   [ ( Presets       , c'V4L2_IN_CAP_PRESETS        )
129   , ( CustomTimings , c'V4L2_IN_CAP_CUSTOM_TIMINGS )
130   , ( InputStd      , c'V4L2_IN_CAP_STD            )
131   ]   UnknownCapability
132
133 {- | Enumerate video inputs. -}
134 videoInputs :: Device -> IO (Map VideoInputID VideoInputInfo)
135 videoInputs = enuminputs' 0
136
137 enuminputs' :: VideoInputID -> Device -> IO (Map VideoInputID VideoInputInfo)
138 enuminputs' n h = do
139   mi <- (Just `fmap` enuminput h n) `catch` (\e -> case ioe_type e of
140     InvalidArgument -> return Nothing
141     _ -> throwIO e)
142   case mi of
143     Just i -> M.insert n i `fmap` enuminputs' (n + 1) h
144     Nothing -> return M.empty
145
146 enuminput :: Device -> VideoInputID -> IO VideoInputInfo
147 enuminput h n = do
148   i' <- ioctl h C'VIDIOC_ENUMINPUT =<< return . (\s->s{ c'v4l2_input'index = fromIntegral n }) =<< zero
149   return (decodeInput i')
150
151 decodeInput :: C'v4l2_input -> VideoInputInfo
152 decodeInput i = VideoInputInfo
153   { videoInputName = fromString $ c'v4l2_input'name i
154   , videoInputType = fromVideoInputType $ c'v4l2_input'type i
155   , videoInputAudio = S.fromList [ fromIntegral ai | ai <- [0..31], c'v4l2_input'audioset i `testBit` ai ]
156   , videoInputTuner = S.fromList [ fromIntegral ti | ti <- [0..31], c'v4l2_input'tuner i `testBit` ti ]
157   , videoInputStandard = fromVideoStandard $ c'v4l2_input'std i
158   , videoInputStatus = fromVideoInputStatus $ c'v4l2_input'status i
159   , videoInputCapability = fromVideoInputCapability $ c'v4l2_input'reserved i !! 0
160   }
161
162 {- | Query the current video input.
163
164     Exceptions:
165
166       * InvalidArgument - this device has no video inputs
167 -}
168 getVideoInput :: Device -> IO VideoInputID
169 getVideoInput h = fromIntegral `fmap` ioctl' h C'VIDIOC_G_INPUT
170
171 {- | Select the current video input.
172
173      Exceptions:
174
175        * InvalidArgument - no video input with this index
176
177        * ResourceBusy - the video input cannot be switched now
178 -}
179 setVideoInput :: Device -> VideoInputID -> IO ()
180 setVideoInput h i = ioctl_ h C'VIDIOC_S_INPUT (fromIntegral i)