diff --git a/src/v4l2-capture.hs b/src/v4l2-capture.hs
deleted file mode 100644
--- a/src/v4l2-capture.hs
+++ /dev/null
@@ -1,271 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface #-}
-
-{- Loosely based on: v4l-capture.c
-
-/*
- *  V4L2 video capture example
- *
- *  This program can be used and distributed without restrictions.
- *
- *      This program is provided with the V4L2 API
- * see http://linuxtv.org/docs.php for more information
- */
-
-  This version writes YUYV frames on stdout in YUV4MPEG2 format.
-  Example usage:
-  $ ./v4l2-capture |
-    y4mscaler -I ilace=none -I sar=1/1 -O chromass=420mpeg2 |
-    mplayer -demuxer y4m - -vo x11
-
-  TODO: this code is hella stinky, needs major work...
-
--}
-
-import Prelude hiding (catch)
-import System.Exit (exitFailure)
-import Bindings.Linux.VideoDev2
-import Bindings.LibV4L2
-import Bindings.MMap
-import System.C.IO
-import System.Posix.IOCtl (IOControl(..))
-import System.Posix.Types (Fd(Fd))
-import Bindings.Posix.Sys.Select (c'FD_ZERO, c'FD_SET, c'select)
-import qualified Bindings.Posix.Sys.Select as P
-import Foreign
-import Foreign.C
-import Control.Exception
-import GHC.Conc (threadDelay)
-import GHC.IO.Exception (IOErrorType(ResourceExhausted), ioe_type)
-import System.Environment (getArgs)
-import System.IO (hPutBuf, stderr, stdout, hFlush, hPutStr)
-import Control.Monad (forM, forM_, replicateM, when)
-import Data.Typeable (Typeable)
-
-writeFrames :: Bool
-writeFrames = True
-
-data Mode = Read | MMap | UserPtr
-
-data V4L2 = V4L2
-  { getFd :: IO Fd
-  , getWidth :: IO Word32
-  , getHeight :: IO Word32
-  , nextFrame :: (Ptr Word8 -> Int -> IO ()) -> IO ()
-  , finish :: IO ()
-  }
-
-data V4L2Exception = V4L2NoCapture | V4L2NoRead | V4L2NoStream | V4L2NoBuffers | V4L2NoMMap
-  deriving (Show, Typeable)
-instance Exception V4L2Exception
-
-v4l2 :: Mode -> FilePath -> IO V4L2
-v4l2 mode device = do
-  fdi <- withCString device $ \dev -> c'v4l2_open dev 2050 0 -- (c'O_RDWR .|. c'O_NONBLOCK)  -- FIXME
-  let fdfi = fromIntegral fdi
-      fd = Fd fdfi
-  cap <- ioctl fd C'VIDIOC_QUERYCAP =<< empty
-  when (c'v4l2_capability'capabilities cap .&. c'V4L2_CAP_VIDEO_CAPTURE == 0) $ throwIO V4L2NoCapture
-  case mode of
-    Read -> when (c'v4l2_capability'capabilities cap .&. c'V4L2_CAP_READWRITE == 0) $ throwIO V4L2NoRead
-    _ -> when (c'v4l2_capability'capabilities cap .&. c'V4L2_CAP_STREAMING == 0) $ throwIO V4L2NoStream
-  (do
-    cropcap <- ioctl fd C'VIDIOC_CROPCAP . (\e -> e
-      { c'v4l2_cropcap'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE }) =<< empty
-    ioctl_ fd C'VIDIOC_S_CROP . (\e -> e
-      { c'v4l2_crop'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-      , c'v4l2_crop'c = c'v4l2_cropcap'defrect cropcap }) =<< empty
-   ) `catchIO` \_ -> return ()
-  pix0 <- return . (\e -> e
-    { c'v4l2_pix_format'width = 320
-    , c'v4l2_pix_format'height = 240
-    , c'v4l2_pix_format'pixelformat = c'V4L2_PIX_FMT_YUYV
-    , c'v4l2_pix_format'field = c'V4L2_FIELD_INTERLACED }) =<< empty
-  pix1 <- (`u'v4l2_format_u'pix` pix0) =<< empty
-  ioctl_ fd C'VIDIOC_S_FMT . (\e -> e
-    { c'v4l2_format'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-    , c'v4l2_format'fmt = pix1 }) =<< empty
-  fmt <- ioctl fd C'VIDIOC_G_FMT . (\e -> e
-    { c'v4l2_format'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE }) =<< empty
-  let pix = c'v4l2_format_u'pix . c'v4l2_format'fmt $ fmt
-      w = c'v4l2_pix_format'width pix
-      h = c'v4l2_pix_format'height pix
-      bytes = fromIntegral $ c'v4l2_pix_format'sizeimage pix
-  case mode of
-    Read -> do
-      buffer <- mallocBytes bytes
-      return V4L2
-        { getFd = return fd
-        , getWidth = return w
-        , getHeight = return h
-        , nextFrame = \f -> do
-            throwErrnoIfMinus1_ "read" $ cread (fromIntegral fd) buffer bytes
-            f buffer bytes
-        , finish = do
-            free buffer
-            throwErrnoIfMinus1_ "close" $ c'v4l2_close fdi
-        }
-    MMap -> do
-      req <- ioctl fd C'VIDIOC_REQBUFS . (\e -> e
-        { c'v4l2_requestbuffers'count = 4
-        , c'v4l2_requestbuffers'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-        , c'v4l2_requestbuffers'memory = c'V4L2_MEMORY_MMAP }) =<< empty
-      let nbuffers = c'v4l2_requestbuffers'count req
-      when (nbuffers < 2) $ throwIO $ V4L2NoBuffers
-      buffers <- forM [0 .. nbuffers-1] $ \n -> do
-        buf <- ioctl fd C'VIDIOC_QUERYBUF . (\e -> e
-          { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-          , c'v4l2_buffer'memory = c'V4L2_MEMORY_MMAP
-          , c'v4l2_buffer'index = n }) =<< empty
-        let len = fromIntegral $ c'v4l2_buffer'length buf
-        ptr <- c'mmap nullPtr len (c'PROT_READ .|. c'PROT_WRITE) c'MAP_SHARED fdfi (fromIntegral . c'v4l2_buffer_u'offset . c'v4l2_buffer'u $ buf)
-        when (ptr == p'MAP_FAILED) $ throwIO V4L2NoMMap
-        return (ptr, len)
-      forM_ (buffers `zip` [0 ..]) $ \(_, i) -> do
-        ioctl_ fd C'VIDIOC_QBUF . (\e -> e
-          { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-          , c'v4l2_buffer'memory = c'V4L2_MEMORY_MMAP
-          , c'v4l2_buffer'index = i }) =<< empty
-        ioctl_ fd C'VIDIOC_STREAMON c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-      return V4L2
-        { getFd = return fd
-        , getWidth = return w
-        , getHeight = return h
-        , nextFrame = \f -> do
-            buf <- ioctl fd C'VIDIOC_DQBUF . (\e -> e
-              { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-              , c'v4l2_buffer'memory = c'V4L2_MEMORY_MMAP }) =<< empty
-            let (ptr, len) = (fst $ buffers !! fromIntegral (c'v4l2_buffer'index buf), c'v4l2_buffer'bytesused buf)
-            f (castPtr ptr) (fromIntegral len)
-            ioctl_ fd C'VIDIOC_QBUF buf
-        , finish = do
-            ioctl_ fd C'VIDIOC_STREAMOFF c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-            forM_ buffers $ \(ptr, len) -> do
-              throwErrnoIfMinus1_ "munmap" $ c'munmap ptr len
-            throwErrnoIfMinus1_ "close" $ c'v4l2_close fdi
-        }
-    UserPtr -> do
-      ioctl_ fd C'VIDIOC_REQBUFS . (\e -> e
-        { c'v4l2_requestbuffers'count = 4
-        , c'v4l2_requestbuffers'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-        , c'v4l2_requestbuffers'memory = c'V4L2_MEMORY_USERPTR }) =<< empty
-      buffers <- replicateM 4 (mallocBytes bytes)
-      forM_ buffers $ \ptr -> do
-        u <- (\e -> u'v4l2_buffer_u'userptr e ({-unsafe-} fromIntegral (ptrToWordPtr ptr))) =<< empty
-        ioctl_ fd C'VIDIOC_QBUF . (\e -> e
-          { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-          , c'v4l2_buffer'memory = c'V4L2_MEMORY_USERPTR
-          , c'v4l2_buffer'u = u
-          , c'v4l2_buffer'length = fromIntegral bytes }) =<< empty
-        ioctl_ fd C'VIDIOC_STREAMON c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-      return V4L2
-        { getFd = return fd
-        , getWidth = return w
-        , getHeight = return h
-        , nextFrame = \f -> do
-            buf <- ioctl fd C'VIDIOC_DQBUF . (\e -> e
-              { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE
-              , c'v4l2_buffer'memory = c'V4L2_MEMORY_USERPTR }) =<< empty
-            let p = wordPtrToPtr . {-unsafe-} fromIntegral . c'v4l2_buffer_u'userptr . c'v4l2_buffer'u $ buf
-            f p (fromIntegral $ c'v4l2_buffer'bytesused buf)
-            ioctl_ fd C'VIDIOC_QBUF buf
-        , finish = do
-            -- FIXME
-            mapM_ free buffers
-            throwErrnoIfMinus1_ "close" $ c'v4l2_close fdi
-       }
-
-empty :: Storable a => IO a
-empty = do
-  alloca $ \p -> do
-    _ <- c'memset p 0 (fromIntegral $ sizeOf (unsafePerformIO (peek p)))
-    peek p
-
-p'MAP_FAILED :: Ptr a
-p'MAP_FAILED = intPtrToPtr c'MAP_FAILED
-
-process_image :: V4L2 -> Ptr Word8 -> Int -> IO ()
-process_image v4 p _size = do
-  when writeFrames $ do
-    w <- getWidth v4
-    h <- getHeight v4
-    putStrLn "FRAME"
-    allocaBytes (fromIntegral $ w * h) $ \y -> do
-      forM_ ([ 0, 2 .. fromIntegral $ w * h * 2 -1]`zip`[0..]) $ \(i, j) -> do
-        pokeElemOff y j =<< peekElemOff p i
-      hPutBuf stdout y (fromIntegral $ w * h)
-    allocaBytes (fromIntegral $ (w * h)) $ \u -> do
-      forM_ ([ 1, 5 .. fromIntegral $ w * h * 2 -1]`zip`[0..]) $ \(i, j) -> do
-        pokeElemOff u j =<< peekElemOff p i
-      hPutBuf stdout u (fromIntegral $ (w`div`2) * h)
-    allocaBytes (fromIntegral $ (w * h)) $ \v -> do
-      forM_ ([ 3, 7 .. fromIntegral $ w * h * 2 -1 ]`zip`[0..]) $ \(i, j) -> do
-        pokeElemOff v j =<< peekElemOff p i
-      hPutBuf stdout v (fromIntegral $ (w`div`2) * h)
-  hFlush stderr
-  hPutStr stderr "."
-  hFlush stdout
-
-main :: IO ()
-main = do
-  (device:_) <- (++["/dev/video0"]) `fmap` getArgs
-  v <- v4l2 MMap device
-  when writeFrames $ do
-    w <- getWidth v
-    h <- getHeight v
-    putStrLn $ "YUV4MPEG2 W" ++ show w ++ " H" ++ show h ++ " C422"
-  mainLoopRetry v (process_image v)
-  hPutStr stderr "\n"
-
-mainLoopRetry :: V4L2 -> (Ptr Word8 -> Int -> IO ()) -> IO ()
-mainLoopRetry v f = do
-  fd <- fromIntegral `fmap` getFd v
-  alloca $ \fds -> do
-    c'FD_ZERO fds
-    c'FD_SET fd fds
-    with P.C'timeval{ P.c'timeval'tv_sec = 5, P.c'timeval'tv_usec = 0 } $ \tv -> do
-      r <- c'select (fd + 1) fds nullPtr nullPtr tv
-      e <- getErrno
-      if r == -1 && e == eINTR
-        then mainLoopRetry v f
-        else if r > 0
-               then do
-                      nextFrame v f `catch` \ex -> case ioe_type ex of
-                        ResourceExhausted -> threadDelay 100000 >> mainLoopRetry v f
-                        _ -> exitFailure
-                      mainLoopRetry v f
-               else return ()
-
-foreign import ccall "string.h memset" c'memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)
-
-catchIO :: IO a -> (IOException -> IO a) -> IO a
-catchIO = catch
-
---foreign import ccall "fcntl.h open" 
-
-c_ioctl' :: IOControl req d => Fd -> req -> Ptr d -> IO ()
-c_ioctl' f req p = throwErrnoIfMinus1_ "ioctl" $ c'v4l2_ioctl (fromIntegral f) (fromIntegral $ ioctlReq req) (castPtr p)
-
--- | Calls a ioctl reading the structure after the call
-ioctl :: IOControl req d
-      => Fd -- ^ The file descriptor 
-      -> req -- ^ The request
-      -> d -- ^ The data
-      -> IO d -- ^ The data after the call
-ioctl f req d = with d $ \p -> c_ioctl' f req p >> peek p
-
--- | Call a ioctl ignoring the result
-ioctl_ :: IOControl req d
-       => Fd -- ^ The file descriptor
-       -> req -- ^ The request
-       -> d -- ^ The data
-       -> IO ()
-ioctl_ f req d = with d $ \p -> c_ioctl' f req p
-
-{-
--- | Call a ioctl with uninitialized data
-ioctl' :: IOControl req d
-       => Fd -- ^ The file descriptor
-       -> req -- ^ The request
-       -> IO d -- ^ The data
-ioctl' f req = alloca $ \p -> c_ioctl' f req p >> peek p
--}
diff --git a/v4l2-capture/v4l2-capture.hs b/v4l2-capture/v4l2-capture.hs
new file mode 100644
--- /dev/null
+++ b/v4l2-capture/v4l2-capture.hs
@@ -0,0 +1,56 @@
+module Main (main) where
+
+import Control.Monad (forM_, when)
+import Foreign (Ptr)
+import System.Environment (getArgs)
+import System.Exit (exitFailure)
+import System.IO (hPutBuf, hPutStr, hPutStrLn, stdout, stderr)
+import System.IO.Error (tryIOError)
+import GHC.IO.Exception (IOErrorType(Interrupted), ioe_type)
+
+import Graphics.V4L2
+
+main :: IO ()
+main = do
+  (devname, verbose) <- checkArgs =<< getArgs
+  e <- tryIOError $ withDevice devname $ \d -> do
+    f <- setFormat d Capture . (\f->f{ imagePixelFormat = PixelRGB24 }) =<< getFormat d Capture
+    checkFormat f
+    info $ "frame size: " ++ show (imageWidth f) ++ "x" ++ show (imageHeight f) ++ " pixels (" ++ show (imageSize f) ++ " bytes)"
+    forM_ [(0 :: Int) ..] $ \i -> do
+      withFrame d f $ \p n -> do
+        if n == imageSize f
+          then do
+            when verbose $ do
+              info $ "Frame number " ++ show i
+            writePPM (imageWidth f) (imageHeight f) p
+          else warn $ "incomplete frame (" ++ show n ++ " bytes, expected " ++ show (imageSize f) ++ " bytes)"
+  case e of
+    Left f | ioe_type f == Interrupted -> return ()
+           | otherwise -> ioError f
+    Right () -> return ()
+
+writePPM :: Int -> Int -> Ptr a -> IO ()
+writePPM w h p = do
+  hPutStr stdout $ "P6\n" ++ show w ++ " " ++ show h ++ " 255\n"
+  hPutBuf stdout p (w * h * 3)
+
+checkFormat :: ImageFormat -> IO ()
+checkFormat f = do
+  when (imagePixelFormat f /= PixelRGB24) $ err "could not set RGB24 pixel format"
+  when (imageBytesPerLine f /= imageWidth f * 3) $ err "cannot handle extra padding"
+  when (imageSize f /= imageBytesPerLine f * imageHeight f) $ err "cannot handle image size"
+
+-- TODO verbosity flag
+checkArgs :: [String] -> IO (String, Bool)
+checkArgs [devname] = return (devname, False)
+checkArgs _ = err $ "bad arguments; usage: v4l2-capture /dev/video0"
+
+err :: String -> IO a
+err msg = (hPutStrLn stderr $ "**ERROR: [v4l2-capture] " ++ msg) >> exitFailure
+
+warn :: String -> IO ()
+warn msg = hPutStrLn stderr $ "++ WARN: [v4l2-capture] " ++ msg
+
+info :: String -> IO ()
+info msg = hPutStrLn stderr $ "   INFO: [v4l2-capture] " ++ msg
diff --git a/v4l2-examples.cabal b/v4l2-examples.cabal
--- a/v4l2-examples.cabal
+++ b/v4l2-examples.cabal
@@ -1,37 +1,39 @@
 Name:                v4l2-examples
-Version:             0.1
+Version:             0.1.0.2
 Synopsis:            video for linux two examples
 
 Description:
-  This package contains examples for accessing v4l2 from Haskell:
+  This package contains examples using the v4l2 package:
   .
-    * v4l2-capture - dumps frames from a video device to stdout:
+    * v4l2-capture - dumps PPM frames from a video device to stdout:
   .
-    @$  v4l2-capture |
-        y4mscaler -v0 -I ilace=none -I sar=1/1 -O chromass=420mpeg2 |
-        mplayer -demuxer y4m - -vo x11@
+    @$ v4l2-capture /dev/video0 > out.ppm@
   .
-  Currently low-level imperative code; but a mid-level v4l2 library is
-  planned which will make it less horrific.
+    * v4l2-histogram - shows RGB histogram overlaid on mirror image, using OpenGL/GLUT for display.
+  .
+    @$ v4l2-histogram /dev/video0@
 
 Homepage:            https://gitorious.org/hsv4l2
 License:             BSD3
 License-file:        LICENSE
 Author:              Claude Heiland-Allen
-Maintainer:          claudiusmaximus@goto10.org
+Maintainer:          claude@mathr.co.uk
 
 Category:            Graphics
 Build-type:          Simple
 Cabal-version:       >=1.2
 
 Executable v4l2-capture
-  Main-is:           src/v4l2-capture.hs
+  Main-is: v4l2-capture/v4l2-capture.hs
   Build-depends:
     base >= 3 && < 5,
-    bindings-libv4l2 >= 0.1 && < 0.2,
-    bindings-linux-videodev2 >= 0.1 && < 0.2,
-    bindings-mmap >= 0.1 && < 0.2,
-    bindings-posix >= 1.2 && < 1.3,
-    c-io >= 0.1 && < 0.2,
-    ioctl >= 0.0 && < 0.1
+    v4l2 >= 0.1 && < 0.2
+  ghc-options: -Wall
+
+Executable v4l2-histogram
+  Main-is: v4l2-histogram/v4l2-histogram.hs
+  Build-depends:
+    base >= 3 && < 5,
+    GLUT >= 2.1 && < 2.4,
+    v4l2 >= 0.1 && < 0.2
   ghc-options: -Wall
diff --git a/v4l2-histogram/v4l2-histogram.hs b/v4l2-histogram/v4l2-histogram.hs
new file mode 100644
--- /dev/null
+++ b/v4l2-histogram/v4l2-histogram.hs
@@ -0,0 +1,143 @@
+module Main (main) where
+
+import Prelude hiding (map, sum)
+
+import Control.Monad (when)
+import Data.Word (Word8, Word32)
+import Foreign (Ptr, nullPtr, allocaArray, peekElemOff, pokeElemOff)
+import System.Exit (exitFailure, exitSuccess)
+import System.IO (hPutStrLn, stderr)
+
+import Graphics.UI.GLUT hiding (PixelFormat, histogram, imageHeight)
+import Graphics.V4L2
+
+pixel :: PixelFormat
+pixel = PixelRGB24
+
+main :: IO ()
+main = do
+  initialWindowSize $= Size 640 480
+  initialDisplayMode $= [DoubleBuffered]
+  devname <- checkArgs . snd =<< getArgsAndInitialize
+  withDevice devname $ \d -> do
+    f <- setFormat d Capture . (\f->f{ imagePixelFormat = pixel }) =<< getFormat d Capture
+    checkFormat f
+    info $ "frame size: " ++ show (imageWidth f) ++ "x" ++ show (imageHeight f) ++ " pixels (" ++ show (imageSize f) ++ " bytes)"
+    let (_, texSize:_) = break (>= (imageWidth f `max` imageHeight f)) $ iterate (2*) 1
+    _ <- createWindow "v4l2-histogram"
+    depthFunc $= Nothing
+    texture Texture2D $= Enabled
+    [th, ti] <- genObjectNames 2
+    textureBinding Texture2D $= Just th
+    texImage2D Nothing NoProxy 0 RGBA' (TextureSize2D 256 256) 0 (PixelData RGBA UnsignedByte nullPtr)
+    textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
+    textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
+    textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
+    textureBinding Texture2D $= Just ti
+    texImage2D Nothing NoProxy 0 RGBA' (TextureSize2D (fromIntegral texSize) (fromIntegral texSize)) 0 (PixelData RGBA UnsignedByte nullPtr)
+    textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
+    textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
+    textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
+    matrixMode $= Modelview 0
+    loadIdentity
+    matrixMode $= Projection
+    loadIdentity
+    ortho2D 0 1 1 0
+    idleCallback $= Just (idle d f texSize ti th)
+    displayCallback $= display d f texSize ti th
+    keyboardMouseCallback $= Just (\_ _ _ _ -> exitSuccess)
+    mainLoop
+
+idle :: Device -> ImageFormat -> Int -> TextureObject -> TextureObject -> IO ()
+idle d f _ ti th = withFrame d f $ \p n -> do
+  if n == imageSize f
+    then allocaArray (256 * 3) $ \h -> allocaArray (256 * 256 * 4) $ \q -> do
+      histogram (imageWidth f * imageHeight f * 3) p h
+      expand (fromIntegral $ imageWidth f * imageHeight f) h q
+      textureBinding Texture2D $= Just ti
+      texSubImage2D Nothing 0 (TexturePosition2D 0 0) (TextureSize2D (fromIntegral $ imageWidth f) (fromIntegral $ imageHeight f)) (PixelData RGB UnsignedByte p)
+      textureBinding Texture2D $= Just th
+      texSubImage2D Nothing 0 (TexturePosition2D 0 0) (TextureSize2D 256 256) (PixelData RGBA UnsignedByte q)
+      postRedisplay Nothing      
+    else warn $ "incomplete frame (" ++ show n ++ " bytes, expected " ++ show (imageSize f) ++ " bytes)"
+
+display:: Device -> ImageFormat -> Int -> TextureObject -> TextureObject -> IO ()
+display _ f texSize ti th = do
+  textureBinding Texture2D $= Just ti
+  renderPrimitive Quads (u 0 0 >> u 0 1 >> u 1 1 >> u 1 0)
+  blend $= Enabled
+  blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
+  textureBinding Texture2D $= Just th
+  renderPrimitive Quads (v 0 0 >> v 0 1 >> v 1 1 >> v 1 0)
+  blend $= Disabled
+  swapBuffers
+  where
+    u :: GLfloat -> GLfloat -> IO ()
+    u x y = texCoord (TexCoord2 (x * fromIntegral (imageWidth f) / fromIntegral texSize) (y * fromIntegral (imageHeight f) / fromIntegral texSize)) >> vertex (Vertex2 (1 - x) y)
+    v :: GLfloat -> GLfloat -> IO ()
+    v x y = texCoord (TexCoord2 x y) >> vertex (Vertex2 x y)
+
+histogram :: Int -> Ptr Word8 -> Ptr Word32 -> IO ()
+histogram m p q = c 0 >> h 0 >> h 1 >> h 2
+  where
+    c i | i >= 256 * 3 = return ()
+        | otherwise = do
+            pokeElemOff q i 0
+            c (i + 1)
+    h i0 = h' i0
+      where
+        h' i  | i >= m = return ()
+              | otherwise = do
+                  j <- peekElemOff p i
+                  let j' = fromIntegral j * 3 + i0
+                  t <- peekElemOff q j'
+                  pokeElemOff q j' (t + 1)
+                  h' (i + 3)
+
+expand :: Float -> Ptr Word32 -> Ptr Word8 -> IO ()
+expand m p q = e 0 >> a 0
+  where
+    e i | i >= 256 = return ()
+        | otherwise = e' 0 >> e' 1 >> e' 2 >> e (i + 1)
+      where
+        e' c = do
+          s <- peekElemOff p (3 * i + c)
+          let t | s == 0 = 255
+                | otherwise = round . max 0 . min 255 $ 256 * log (m / fromIntegral s) / log 256
+          f t
+          where
+            f t = g 0
+              where
+                g j | j == 256 = return ()
+                    | otherwise = do
+                        pokeElemOff q ((j * 256 + i) * 4 + c) $ if j > t then 255 else 0
+                        g (j + 1)
+    a i | i >= 256 * 256 * 4 = return ()
+        | otherwise = do
+            r <- peekElemOff q i
+            if r > 0 then pokeElemOff q (i + 3) 255 else do
+              g <- peekElemOff q (i + 1)
+              if g > 0 then pokeElemOff q (i + 3) 255 else do
+                b <- peekElemOff q (i + 2)
+                if b > 0 then pokeElemOff q (i + 3) 255 else do
+                  pokeElemOff q (i + 3) 0
+            a (i + 4)
+
+checkFormat :: ImageFormat -> IO ()
+checkFormat f = do
+  when (imagePixelFormat f /= pixel) $ err ("could not set pixel format " ++ show pixel)
+  when (imageBytesPerLine f /= imageWidth f * 3) $ err "cannot handle extra padding"
+  when (imageSize f /= imageBytesPerLine f * imageHeight f) $ err "cannot handle image size"
+
+checkArgs :: [String] -> IO String
+checkArgs [devname] = return devname
+checkArgs _ = err $ "bad arguments; usage: v4l2-histogram /dev/video0"
+
+err :: String -> IO a
+err msg = (hPutStrLn stderr $ "**ERROR: [v4l2-histogram] " ++ msg) >> exitFailure
+
+warn :: String -> IO ()
+warn msg = hPutStrLn stderr $ "++ WARN: [v4l2-histogram] " ++ msg
+
+info :: String -> IO ()
+info msg = hPutStrLn stderr $ "   INFO: [v4l2-histogram] " ++ msg