Format.hs

{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{- |
Module      : Graphics.V4L2.Format
Maintainer  : claudiusmaximus@goto10.org
Stability   : no
Portability : no
-}
module Graphics.V4L2.Format
  ( BufferType(..)
  , Direction(..)
  , Format(..)
  , FormatID()
  , FormatDescription(..)
  , FormatFlag(..)
  , queryFormats
  , FrameSize(..)
  , FrameSizes(..)
  , queryFrameSizes
  , FrameIntervals(..)
  , queryFrameIntervals
  , ImageFormat(..)
  ) where

import Prelude hiding (catch)

import Control.Exception (catch, throwIO)
import Control.Monad (when)
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.BitSet (fromBitSet)
import Foreign.Extra.CEnum (toCEnum)
import Foreign.Extra.String (fromString)
import Graphics.V4L2.Device (Device)
import Graphics.V4L2.IOCtl (ioctl, zero)
import Graphics.V4L2.Field (Field)
import Graphics.V4L2.Field.Internal (fromField, toField)
import Graphics.V4L2.PixelFormat (PixelFormat)
import Graphics.V4L2.PixelFormat.Internal (fromPixelFormat, toPixelFormat)
import Graphics.V4L2.ColorSpace (ColorSpace)
import Graphics.V4L2.ColorSpace.Internal (fromColorSpace, toColorSpace)
import Graphics.V4L2.Types (Fraction(..))
import Graphics.V4L2.Types.Internal (fromFraction)

-- FIXME {
{-
c'V4L2_BUF_TYPE_VIDEO_CAPTURE_MPLANE = 9
c'V4L2_BUF_TYPE_VIDEO_OUTPUT_MPLANE = 10
V4L2_BUF_TYPE_VIDEO_OVERLAY
V4L2_BUF_TYPE_VBI_CAPTURE
V4L2_BUF_TYPE_VBI_OUTPUT
V4L2_BUF_TYPE_SLICED_VBI_CAPTURE
V4L2_BUF_TYPE_SLICED_VBI_OUTPUT
V4L2_BUF_TYPE_VIDEO_OUTPUT_OVERLAY
V4L2_BUF_TYPE_PRIVATE
-}
-- FIXME }

data BufferType = BufferVideoCapture | BufferVideoOutput | BufferUnknown Word32
  deriving (Eq, Ord, Read, Show, Data, Typeable)

toBufferType :: BufferType -> C'v4l2_buf_type
toBufferType = toCEnum
  [ ( BufferVideoCapture , c'V4L2_BUF_TYPE_VIDEO_CAPTURE )
  , ( BufferVideoOutput  , c'V4L2_BUF_TYPE_VIDEO_OUTPUT  )
  ] isU unU
  where
    isU (BufferUnknown _) = True
    isU _ = False
    unU (BufferUnknown b) = fromIntegral b
    unU _ = error "err"

data Direction = Capture | Output
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable)

class Format f where
  formatBufferType :: f -> Direction -> BufferType
  getFormat :: Device -> Direction -> IO f
  setFormat :: Device -> Direction -> f -> IO f
  tryFormat :: Device -> Direction -> f -> IO f

data ImageFormat = ImageFormat
  { imageWidth, imageHeight :: Int
  , imagePixelFormat :: PixelFormat
  , imageField :: Field
  , imageBytesPerLine :: Int
  , imageSize :: Int
  , imageColorSpace :: ColorSpace
  }
  deriving (Eq, Ord, Read, Show, Data, Typeable)

instance Format ImageFormat where
  formatBufferType _ = imageBufferType
  getFormat d dir   =
    return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_G_FMT . (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir }) =<< zero
  setFormat d dir f = do
    u <- (`u'v4l2_format_u'pix` encodeImageFormat f) =<< zero
    return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_S_FMT =<< (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir, c'v4l2_format'fmt = u }) `fmap` zero
  tryFormat d dir f = do
    u <- (`u'v4l2_format_u'pix` encodeImageFormat f) =<< zero
    return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_TRY_FMT =<< (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir, c'v4l2_format'fmt = u }) `fmap` zero

encodeImageFormat :: ImageFormat -> C'v4l2_pix_format
encodeImageFormat f = C'v4l2_pix_format
  { c'v4l2_pix_format'width = fromIntegral $ imageWidth f
  , c'v4l2_pix_format'height = fromIntegral $ imageHeight f
  , c'v4l2_pix_format'pixelformat = toPixelFormat $ imagePixelFormat f
  , c'v4l2_pix_format'field = toField $ imageField f
  , c'v4l2_pix_format'bytesperline = fromIntegral $ imageBytesPerLine f
  , c'v4l2_pix_format'sizeimage = fromIntegral $ imageSize f
  , c'v4l2_pix_format'colorspace = toColorSpace $ imageColorSpace f
  , c'v4l2_pix_format'priv = 0
  }     

decodeImageFormat :: C'v4l2_pix_format -> ImageFormat
decodeImageFormat f = ImageFormat
  { imageWidth = fromIntegral $ c'v4l2_pix_format'width f
  , imageHeight = fromIntegral $ c'v4l2_pix_format'height f
  , imagePixelFormat = fromPixelFormat $ c'v4l2_pix_format'pixelformat f
  , imageField = fromField $ c'v4l2_pix_format'field f
  , imageBytesPerLine = fromIntegral $ c'v4l2_pix_format'bytesperline f
  , imageSize = fromIntegral $ c'v4l2_pix_format'sizeimage f
  , imageColorSpace = fromColorSpace $ c'v4l2_pix_format'colorspace f
  }

imageBufferType :: Direction -> BufferType
imageBufferType Capture = BufferVideoCapture
imageBufferType Output = BufferVideoOutput


{- |  Format flags. -}
data FormatFlag
  = FormatCompressed
  | FormatEmulated
  | FormatUnknown Word32
  deriving (Eq, Ord, Read, Show, Data, Typeable)
  
fromFormatFlag :: Word32 -> Set FormatFlag
fromFormatFlag = fromBitSet
  [ ( FormatCompressed , c'V4L2_FMT_FLAG_COMPRESSED )
  , ( FormatEmulated   , c'V4L2_FMT_FLAG_EMULATED   )
  ]   FormatUnknown

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

{- | Video format description -}
data FormatDescription = FormatDescription
  { formatDescription :: String
  , formatPixelFormat :: PixelFormat
  , formatFlags :: Set FormatFlag
  }
  deriving (Eq, Ord, Read, Show, Data, Typeable)

enumfmt :: Device -> BufferType -> FormatID -> IO FormatDescription
enumfmt h t n = do
  d <- ioctl h C'VIDIOC_ENUM_FMT . (\s->s{ c'v4l2_fmtdesc'index = fromIntegral n, c'v4l2_fmtdesc'type = toBufferType t }) =<< zero
  return FormatDescription
    { formatDescription = fromString $ c'v4l2_fmtdesc'description d
    , formatPixelFormat = fromPixelFormat $ c'v4l2_fmtdesc'pixelformat d
    , formatFlags = fromFormatFlag $ c'v4l2_fmtdesc'flags d
    }

{- |  Enumerate supported buffer formats.

      Exceptions:

        * InvalidArgument - buffer type not supported or index out of range
-}     
queryFormats :: Device -> BufferType -> IO (Map FormatID FormatDescription)
queryFormats = enumfmts' 0

enumfmts' :: FormatID -> Device -> BufferType -> IO (Map FormatID FormatDescription)
enumfmts' n h t = do
  mi <- (Just `fmap` enumfmt h t n) `catch` (\e -> case ioe_type e of
    InvalidArgument -> return Nothing
    _ -> throwIO e)
  case mi of
    Just i -> M.insert n i `fmap` enumfmts' (n + 1) h t
    Nothing -> return M.empty

{- |  Enumerate supported frame sizes. -}
queryFrameSizes :: Device -> PixelFormat -> IO FrameSizes
queryFrameSizes h p = do
  fs <- enumframesizes0 h p `catch` (\e -> case ioe_type e of
    InvalidArgument -> return (DiscreteSizes S.empty)
    _ -> throwIO e)
  case fs of
    DiscreteSizes f | not $ S.null f -> do
      fs' <- enumframesizesD 1 h p
      return . DiscreteSizes $ f `S.union` fs'
    _ -> return fs

enumframesizes0 :: Device -> PixelFormat -> IO FrameSizes
enumframesizes0 h p = do
  f <- ioctl h C'VIDIOC_ENUM_FRAMESIZES . (\s->s{ c'v4l2_frmsizeenum'index = 0, c'v4l2_frmsizeenum'pixel_format = toPixelFormat p }) =<< zero
  case c'v4l2_frmsizeenum'type f of
    x | x == c'V4L2_FRMSIZE_TYPE_DISCRETE -> return . DiscreteSizes . S.singleton . decodeFrameSize . c'v4l2_frmsizeenum_u'discrete . c'v4l2_frmsizeenum'u $ f
      | x == c'V4L2_FRMSIZE_TYPE_STEPWISE ||
        x == c'V4L2_FRMSIZE_TYPE_CONTINUOUS -> do
          let s = c'v4l2_frmsizeenum_u'stepwise . c'v4l2_frmsizeenum'u $ f
          return StepwiseSizes
            { stepwiseMinWidth = fromIntegral $ c'v4l2_frmsize_stepwise'min_width s
            , stepwiseMaxWidth = fromIntegral $ c'v4l2_frmsize_stepwise'max_width s
            , stepwiseStepWidth = fromIntegral $ c'v4l2_frmsize_stepwise'step_width s
            , stepwiseMinHeight = fromIntegral $ c'v4l2_frmsize_stepwise'min_height s
            , stepwiseMaxHeight = fromIntegral $ c'v4l2_frmsize_stepwise'max_height s
            , stepwiseStepHeight = fromIntegral $ c'v4l2_frmsize_stepwise'step_height s
            }
      | otherwise -> error "err"

enumframesizesD :: Word32 -> Device -> PixelFormat -> IO (Set FrameSize)
enumframesizesD n h p = do
  f <- (do
    f' <- ioctl h C'VIDIOC_ENUM_FRAMESIZES . (\s->s{ c'v4l2_frmsizeenum'index = n, c'v4l2_frmsizeenum'pixel_format = toPixelFormat p }) =<< zero
    when (c'v4l2_frmsizeenum'type f' /= c'V4L2_FRMSIZE_TYPE_DISCRETE) $ error "err"
    return (Just f')) `catch` (\e -> case ioe_type e of
    InvalidArgument -> return Nothing
    _ -> throwIO e)
  case f of
    Nothing -> return S.empty
    Just fs -> S.insert (decodeFrameSize . c'v4l2_frmsizeenum_u'discrete . c'v4l2_frmsizeenum'u $ fs) `fmap` enumframesizesD (n + 1) h p

{- |  Single frame size. -}
data FrameSize = FrameSize
  { frameWidth
  , frameHeight :: Int
  }
  deriving (Eq, Ord, Read, Show, Data, Typeable)

{- |  Discrete and continuous frame sizes. -}
data FrameSizes
  = DiscreteSizes
      { discreteSizes :: Set FrameSize }
  | StepwiseSizes
      { stepwiseMinWidth
      , stepwiseMaxWidth
      , stepwiseStepWidth
      , stepwiseMinHeight
      , stepwiseMaxHeight
      , stepwiseStepHeight :: Int
      }
  deriving (Eq, Ord, Read, Show, Data, Typeable)

decodeFrameSize :: C'v4l2_frmsize_discrete -> FrameSize
decodeFrameSize d = FrameSize
  { frameWidth = fromIntegral $ c'v4l2_frmsize_discrete'width  d
  , frameHeight = fromIntegral $ c'v4l2_frmsize_discrete'height d
  }

{- |  Enumerate frame intervals. -}
queryFrameIntervals :: Device -> PixelFormat -> FrameSize -> IO FrameIntervals
queryFrameIntervals h p f = do
  fi <- enumframeintervals0 h p f `catch` (\e -> case ioe_type e of
    InvalidArgument -> return (DiscreteIntervals S.empty)
    _ -> throwIO e)
  case fi of
    DiscreteIntervals i | not $ S.null i -> do
      is <- enumframeintervalsD 1 h p f
      return . DiscreteIntervals $ i `S.union` is
    _ -> return fi

enumframeintervals0 :: Device -> PixelFormat -> FrameSize -> IO FrameIntervals
enumframeintervals0 h p f = do
  i <- ioctl h C'VIDIOC_ENUM_FRAMEINTERVALS . (\s->s{ c'v4l2_frmivalenum'index = 0, c'v4l2_frmivalenum'pixel_format = toPixelFormat p, c'v4l2_frmivalenum'width = fromIntegral (frameWidth f), c'v4l2_frmivalenum'height = fromIntegral (frameHeight f) }) =<< zero
  case c'v4l2_frmivalenum'type i of
    x | x == c'V4L2_FRMIVAL_TYPE_DISCRETE -> return . DiscreteIntervals . S.singleton . fromFraction . c'v4l2_frmivalenum_u'discrete . c'v4l2_frmivalenum'u $ i
      | x == c'V4L2_FRMIVAL_TYPE_STEPWISE ||
        x == c'V4L2_FRMIVAL_TYPE_CONTINUOUS -> do
          let s = c'v4l2_frmivalenum_u'stepwise . c'v4l2_frmivalenum'u $ i
          return StepwiseIntervals
            { stepwiseMin = fromFraction $ c'v4l2_frmival_stepwise'min s
            , stepwiseMax = fromFraction $ c'v4l2_frmival_stepwise'max s
            , stepwiseStep = fromFraction $ c'v4l2_frmival_stepwise'step s
            }
      | otherwise -> error "err"

enumframeintervalsD :: Word32 -> Device -> PixelFormat -> FrameSize -> IO (Set Fraction)
enumframeintervalsD n h p f = do
  i <- (do
    f' <- ioctl h C'VIDIOC_ENUM_FRAMEINTERVALS . (\s->s{ c'v4l2_frmivalenum'index = n, c'v4l2_frmivalenum'pixel_format = toPixelFormat p, c'v4l2_frmivalenum'width = fromIntegral (frameWidth f), c'v4l2_frmivalenum'height = fromIntegral (frameHeight f) }) =<< zero
    when (c'v4l2_frmivalenum'type f' /= c'V4L2_FRMIVAL_TYPE_DISCRETE) $ error "err"
    return (Just f')) `catch` (\e -> case ioe_type e of
    InvalidArgument -> return Nothing
    _ -> throwIO e)
  case i of
    Nothing -> return S.empty
    Just fs -> S.insert (fromFraction . c'v4l2_frmivalenum_u'discrete . c'v4l2_frmivalenum'u $ fs) `fmap` enumframeintervalsD (n + 1) h p f

{- | Discrete and continuous frame intervals. -}
data FrameIntervals
  = DiscreteIntervals
      { discreteIntervals :: Set Fraction }
  | StepwiseIntervals
      { stepwiseMin, stepwiseMax, stepwiseStep :: Fraction }
  deriving (Eq, Ord, Read, Show, Data, Typeable)