{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{- |
Module      : Graphics.V4L2.VideoInput
Maintainer  : claudiusmaximus@goto10.org
Stability   : no
Portability : no
-}
module Graphics.V4L2.VideoInput
  ( VideoInputID()
  , VideoInputInfo(..)
  , VideoInputType(..)
  , VideoInputStatus(..)
  , VideoInputCapability(..)
  , videoInputs
  , getVideoInput
  , setVideoInput
  ) where

import Prelude hiding (catch)

import Control.Exception (catch, throwIO)
import Data.Bits (testBit)
import Data.Data (Data)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import Data.Word (Word32)
import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type)

import Bindings.Linux.VideoDev2

import Foreign.Extra.CEnum (fromCEnum)
import Foreign.Extra.BitSet (fromBitSet)
import Foreign.Extra.String (fromString)
import Graphics.V4L2.Device (Device)
import Graphics.V4L2.IOCtl (ioctl, ioctl_, ioctl', zero)
import Graphics.V4L2.VideoStandard (VideoStandard)
import Graphics.V4L2.VideoStandard.Internal (fromVideoStandard)


c'V4L2_IN_CAP_PRESETS :: Word32
c'V4L2_IN_CAP_PRESETS = 1
c'V4L2_IN_CAP_CUSTOM_TIMINGS :: Word32
c'V4L2_IN_CAP_CUSTOM_TIMINGS = 2
c'V4L2_IN_CAP_STD :: Word32
c'V4L2_IN_CAP_STD = 4
newtype AudioInputID = AudioInputID Int
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
newtype TunerID = TunerID Int
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)

{- |  Video input index. -}
newtype VideoInputID = VideoInputID Int
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)

{- |  Video input info. -}
data VideoInputInfo = VideoInputInfo
  { videoInputName       :: String
  , videoInputType       :: VideoInputType
  , videoInputAudio      :: Set AudioInputID
  , videoInputTuner      :: Set TunerID
  , videoInputStandard   :: VideoStandard
  , videoInputStatus     :: Set VideoInputStatus
  , videoInputCapability :: Set VideoInputCapability
  }
  deriving (Eq, Ord, Read, Show, Typeable)

{- |  Video input type. -}
data VideoInputType
  = TunerInput
  | CameraInput
  | UnknownInput Word32
  deriving (Eq, Ord, Read, Show, Data, Typeable)

fromVideoInputType :: Word32 -> VideoInputType
fromVideoInputType = fromCEnum
  [ ( TunerInput  , c'V4L2_INPUT_TYPE_TUNER  )
  , ( CameraInput , c'V4L2_INPUT_TYPE_CAMERA )
  ]   UnknownInput

{- |  Video input status. -}
data VideoInputStatus
  = NoPower
  | NoSignal
  | NoColor
  | HFlip
  | VFlip
  | NoHLock
  | ColorKill
  | NoSync
  | NoEqu
  | NoCarrier
  | Macrovision
  | NoAccess
  | Vtr
  | UnknownStatus Word32
  deriving (Eq, Ord, Read, Show, Data, Typeable)

fromVideoInputStatus :: Word32 -> Set VideoInputStatus
fromVideoInputStatus = fromBitSet
  [ ( NoPower     , c'V4L2_IN_ST_NO_POWER    )
  , ( NoSignal    , c'V4L2_IN_ST_NO_SIGNAL   )
  , ( NoColor     , c'V4L2_IN_ST_NO_COLOR    )
  , ( HFlip       , c'V4L2_IN_ST_HFLIP       )
  , ( VFlip       , c'V4L2_IN_ST_VFLIP       )
  , ( NoHLock     , c'V4L2_IN_ST_NO_H_LOCK   )
  , ( ColorKill   , c'V4L2_IN_ST_COLOR_KILL  )
  , ( NoSync      , c'V4L2_IN_ST_NO_SYNC     )
  , ( NoEqu       , c'V4L2_IN_ST_NO_EQU      )
  , ( NoCarrier   , c'V4L2_IN_ST_NO_CARRIER  )
  , ( Macrovision , c'V4L2_IN_ST_MACROVISION )
  , ( NoAccess    , c'V4L2_IN_ST_NO_ACCESS   )
  , ( Vtr         , c'V4L2_IN_ST_VTR         )
  ]   UnknownStatus

{- |  Video input capabilitites. -}
data VideoInputCapability
  = Presets
  | CustomTimings
  | InputStd
  | UnknownCapability Word32
  deriving (Eq, Ord, Read, Show, Data, Typeable)

fromVideoInputCapability :: Word32 -> Set VideoInputCapability
fromVideoInputCapability = fromBitSet
  [ ( Presets       , c'V4L2_IN_CAP_PRESETS        )
  , ( CustomTimings , c'V4L2_IN_CAP_CUSTOM_TIMINGS )
  , ( InputStd      , c'V4L2_IN_CAP_STD            )
  ]   UnknownCapability

{- | Enumerate video inputs. -}
videoInputs :: Device -> IO (Map VideoInputID VideoInputInfo)
videoInputs = enuminputs' 0

enuminputs' :: VideoInputID -> Device -> IO (Map VideoInputID VideoInputInfo)
enuminputs' n h = do
  mi <- (Just `fmap` enuminput h n) `catch` (\e -> case ioe_type e of
    InvalidArgument -> return Nothing
    _ -> throwIO e)
  case mi of
    Just i -> M.insert n i `fmap` enuminputs' (n + 1) h
    Nothing -> return M.empty

enuminput :: Device -> VideoInputID -> IO VideoInputInfo
enuminput h n = do
  i' <- ioctl h C'VIDIOC_ENUMINPUT =<< return . (\s->s{ c'v4l2_input'index = fromIntegral n }) =<< zero
  return (decodeInput i')

decodeInput :: C'v4l2_input -> VideoInputInfo
decodeInput i = VideoInputInfo
  { videoInputName = fromString $ c'v4l2_input'name i
  , videoInputType = fromVideoInputType $ c'v4l2_input'type i
  , videoInputAudio = S.fromList [ fromIntegral ai | ai <- [0..31], c'v4l2_input'audioset i `testBit` ai ]
  , videoInputTuner = S.fromList [ fromIntegral ti | ti <- [0..31], c'v4l2_input'tuner i `testBit` ti ]
  , videoInputStandard = fromVideoStandard $ c'v4l2_input'std i
  , videoInputStatus = fromVideoInputStatus $ c'v4l2_input'status i
  , videoInputCapability = fromVideoInputCapability $ c'v4l2_input'reserved i !! 0
  }

{- | Query the current video input.

    Exceptions:

      * InvalidArgument - this device has no video inputs
-}
getVideoInput :: Device -> IO VideoInputID
getVideoInput h = fromIntegral `fmap` ioctl' h C'VIDIOC_G_INPUT

{- | Select the current video input.

     Exceptions:

       * InvalidArgument - no video input with this index

       * ResourceBusy - the video input cannot be switched now
-}
setVideoInput :: Device -> VideoInputID -> IO ()
setVideoInput h i = ioctl_ h C'VIDIOC_S_INPUT (fromIntegral i)