{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{- |
Module      : Graphics.V4L2.Control
Maintainer  : claudiusmaximus@goto10.org
Stability   : no
Portability : no
-}
module Graphics.V4L2.Control
  ( ControlID()
  , MenuID()
  , ControlFlag(..)
  , ControlInfo(..)
  , queryControls
  , Activate(..)
  , ControlData()
  , getControl
  , setControl
  ) where

import Prelude hiding (catch)

import Control.Exception (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)

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

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

{- |  Control flags. -}
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

{- |  Control information. -}
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)

{- |  Enumerate controls. -}
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
          ) `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"

-- FIXME: V4L2_CTRL_TYPE_CTRL_CLASS


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
         ) `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)

{- |  Control data values -}
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  

{- | Button control data. -}
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 []