never executed always true always false
    1 {-# language CPP #-}
    2 {-# language QuasiQuotes #-}
    3 {-# language InstanceSigs #-}
    4 {-# language ConstraintKinds #-}
    5 {-# language TemplateHaskell #-}
    6 {-# language UndecidableInstances #-}
    7 {-# language MultiParamTypeClasses #-}
    8 {-# language ExistentialQuantification #-}
    9 
   10 #if __GLASGOW_HASKELL__ >= 800
   11 {-# options_ghc -Wno-redundant-constraints #-}
   12 #endif
   13 
   14 module OpenCV.Core.Types.Mat.Repa
   15     ( M
   16     , DIM
   17     , toRepa
   18     ) where
   19 
   20 import "base" Data.Int
   21 import "base" Data.Monoid
   22 import "base" Data.Proxy
   23 import "base" Data.Word
   24 import "base" Foreign.C.Types
   25 import "base" Foreign.Marshal.Alloc ( alloca )
   26 import "base" Foreign.Marshal.Array ( peekArray )
   27 import "base" Foreign.Ptr ( Ptr, plusPtr )
   28 import "base" Foreign.Storable ( Storable(..), peek, sizeOf )
   29 import "base" GHC.TypeLits
   30 import "base" System.IO.Unsafe ( unsafePerformIO )
   31 import "deepseq" Control.DeepSeq (NFData, rnf)
   32 import qualified "inline-c" Language.C.Inline as C
   33 import qualified "inline-c" Language.C.Inline.Unsafe as CU
   34 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
   35 import qualified "repa" Data.Array.Repa as Repa
   36 import           "repa" Data.Array.Repa.Index ( (:.) )
   37 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
   38 import "this" OpenCV.Internal.Core.Types.Mat
   39 import "this" OpenCV.Internal.C.Types
   40 import "this" OpenCV.TypeLevel
   41 
   42 
   43 --------------------------------------------------------------------------------
   44 
   45 C.context openCvCtx
   46 
   47 C.include "opencv2/core.hpp"
   48 C.using "namespace cv"
   49 
   50 
   51 --------------------------------------------------------------------------------
   52 --  Repa
   53 --------------------------------------------------------------------------------
   54 
   55 -- | Representation tag for Repa @'Repa.Array's@ for OpenCV @'Mat's@.
   56 data M (shape :: [DS Nat]) (channels :: Nat)
   57 
   58 type family DIM (n :: Nat) :: * where
   59     DIM 0 = Repa.Z
   60     DIM n = DIM (n-1) :. Int
   61 
   62 -- | Converts an OpenCV @'Mat'rix@ into a Repa array.
   63 --
   64 -- This is a zero-copy operation.
   65 toRepa
   66     :: forall (shape    :: [DS Nat])
   67               (channels :: Nat)
   68               (depth    :: *)
   69               (dims     :: Nat)
   70               (sh       :: *)
   71      . ( Storable depth
   72        , KnownNat channels
   73        , KnownNat dims
   74        , dims ~ Length shape
   75        , sh ~ DIM ((dims + 1))
   76        )
   77     => Mat ('S shape) ('S channels) ('S depth) -- ^
   78     -> Repa.Array (M shape channels) sh depth
   79 toRepa mat = unsafePerformIO $ withPtr mat $ \matPtr ->
   80     alloca $ \(sizePtr    :: Ptr (Ptr Int32)) ->
   81     alloca $ \(stepPtr    :: Ptr (Ptr CSize)) ->
   82     alloca $ \(dataPtrPtr :: Ptr (Ptr Word8)) -> do
   83       [CU.block| void {
   84         const Mat * const matPtr = $(Mat * matPtr);
   85         *$(int32_t * * const sizePtr   ) = matPtr->size.p;
   86         *$(size_t  * * const stepPtr   ) = matPtr->step.p;
   87         *$(uint8_t * * const dataPtrPtr) = matPtr->data;
   88       }|]
   89       let dims = fromInteger $ natVal (Proxy :: Proxy dims)
   90 
   91       (size :: Ptr Int32) <- peek sizePtr
   92       sizeShape <- map fromIntegral <$> peekArray dims size
   93       let sizes = sizeShape <> [fromInteger $ natVal (Proxy :: Proxy channels)]
   94 
   95       (step :: Ptr CSize) <- peek stepPtr
   96       stepShape <- map fromIntegral <$> peekArray dims step
   97       let steps = stepShape <> [sizeOf (undefined :: depth)]
   98 
   99       (dataPtr :: Ptr Word8) <- peek dataPtrPtr
  100       pure $ Array mat dataPtr sizes steps
  101 
  102 instance (Repa.Shape sh, Storable depth) => NFData (Repa.Array (M shape channels) sh depth) where
  103     rnf a = Repa.deepSeqArray a ()
  104 
  105 instance (Storable depth) => Repa.Source (M shape channels) depth where
  106     -- TODO (BvD): We might want to check for isContinuous() to optimize certain operations.
  107 
  108     data Array (M shape channels) sh depth =
  109           Array !(Mat ('S shape) ('S channels) ('S depth))
  110                  -- The Mat is kept around so that the data doesn't get garbage collected.
  111                 !(Ptr Word8) -- Pointer to the data.
  112                 ![Int] -- The shape of the extent which is determined by mat->dims and mat->size.p.
  113                 ![Int] -- The shape of the data which is determined by mat->dims and mat->step.p.
  114 
  115     extent :: (Repa.Shape sh) => Repa.Array (M shape channels) sh depth -> sh
  116     extent (Array _ _ sizeShape _) = Repa.shapeOfList sizeShape
  117 
  118     index :: (Repa.Shape sh) => Repa.Array (M shape channels) sh depth -> sh -> depth
  119     index (Array mat dataPtr sizeShape stepShape) ix =
  120         unsafePerformIO $ keepMatAliveDuring mat $ peek elemPtr
  121       where
  122         elemPtr :: Ptr depth
  123         elemPtr = dataPtr `plusPtr` offset
  124 
  125         offset :: Int
  126         offset = sum $ zipWith3 mul sizeShape stepShape (Repa.listOfShape ix)
  127 
  128         mul size step i
  129             | i < size  = step * i
  130             | otherwise = error $
  131                 "Index " <> show i <> " >= size: " <> show size
  132 
  133     unsafeIndex :: (Repa.Shape sh) => Repa.Array (M shape channels) sh depth -> sh -> depth
  134     unsafeIndex (Array mat dataPtr _ stepShape) ix =
  135         unsafePerformIO $ keepMatAliveDuring mat $ peek elemPtr
  136       where
  137         elemPtr :: Ptr depth
  138         elemPtr = matElemAddress dataPtr stepShape (Repa.listOfShape ix)
  139 
  140     linearIndex :: (Repa.Shape sh) => Repa.Array (M shape channels) sh depth -> Int -> depth
  141     linearIndex a ix = Repa.index a sh
  142         where
  143           sh = Repa.fromIndex (Repa.extent a) ix
  144 
  145     unsafeLinearIndex :: (Repa.Shape sh) => Repa.Array (M shape channels) sh depth -> Int -> depth
  146     unsafeLinearIndex a ix = Repa.unsafeIndex a sh
  147         where
  148           sh = Repa.fromIndex (Repa.extent a) ix
  149 
  150     deepSeqArray :: (Repa.Shape sh) => Repa.Array (M shape channels) sh depth -> b -> b
  151     deepSeqArray = seq
  152 
  153 -- TODO (BvD): Is it possible to define something like the following?
  154 --
  155 -- instance (Storable depth) => Repa.Target (M shape channels) depth where
  156 --
  157 --     newtype MVec (M shape channels) depth = MVec IOMat
  158 --
  159 --     newMVec :: Int -> IO (MVec (M shape channels) depth)
  160 --     newMVec size = _todo_newMVec
  161 --
  162 --     unsafeWriteMVec :: MVec (M shape channels) depth -> Int -> depth -> IO ()
  163 --     unsafeWriteMVec = _todo_unsafeWriteMVec
  164 --
  165 --     unsafeFreezeMVec :: sh  -> MVec (M shape channels) depth -> IO (Array (M shape channels) sh depth)
  166 --     unsafeFreezeMVec = _todo_unsafeFreezeMVec
  167 --
  168 --     deepSeqMVec :: MVec (M shape channels) depth -> a -> a
  169 --     deepSeqMVec = _todo_deepSeqMVec
  170 --
  171 --     touchMVec :: MVec (M shape channels) depth -> IO ()
  172 --     touchMVec = _todo_touchMVec