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