never executed always true always false
1 {-# language CPP #-}
2 {-# language RankNTypes #-}
3 {-# language QuasiQuotes #-}
4 {-# language ConstraintKinds #-}
5 {-# language TemplateHaskell #-}
6 {-# language UndecidableInstances #-}
7
8 #if __GLASGOW_HASKELL__ >= 800
9 {-# options_ghc -Wno-redundant-constraints #-}
10 #endif
11
12 {-# options_ghc -fno-warn-orphans #-}
13
14 #ifndef ENABLE_INTERNAL_DOCUMENTATION
15 {-# OPTIONS_HADDOCK hide #-}
16 #endif
17
18 module OpenCV.Internal.Core.Types.Mat
19 ( -- * Matrix
20 Mat(..)
21
22 , typeCheckMat
23 , relaxMat
24 , coerceMat
25 , unsafeCoerceMat
26
27 , keepMatAliveDuring
28 , newEmptyMat
29 , newMat
30 , withMatData
31 , matElemAddress
32 , mkMat
33 , cloneMat
34
35 -- * Mutable matrix
36 , typeCheckMatM
37 , relaxMatM
38 , coerceMatM
39 , unsafeCoerceMatM
40
41 , mkMatM
42 , createMat
43 , withMatM
44 , cloneMatM
45 , deallocateMatM
46
47 -- * Meta information
48 , MatInfo(..)
49 , matInfo
50
51 , dimPositions
52
53 , Depth(..)
54 , marshalDepth
55 , unmarshalDepth
56 , marshalFlags
57 , unmarshalFlags
58
59 , ShapeT
60 , ChannelsT
61 , DepthT
62 , StaticDepthT
63
64 , ToShape(toShape)
65 , ToShapeDS(toShapeDS)
66 , ToChannels, toChannels
67 , ToChannelsDS, toChannelsDS
68 , ToDepth(toDepth)
69 , ToDepthDS(toDepthDS)
70 ) where
71
72 import "base" Control.Exception ( throwIO )
73 import "base" Control.Monad.ST ( ST )
74 import "base" Data.Int
75 import "base" Data.Maybe
76 import "base" Data.Monoid ( (<>) )
77 import "base" Data.Proxy
78 import "base" Data.Word
79 import "base" Foreign.C.Types
80 import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, touchForeignPtr )
81 import "base" Foreign.Marshal.Alloc ( alloca )
82 import "base" Foreign.Marshal.Array ( allocaArray, peekArray )
83 import "base" Foreign.Ptr ( Ptr, plusPtr )
84 import "base" Foreign.Storable ( Storable(..), peek )
85 import "base" GHC.TypeLits
86 import "base" System.IO.Unsafe ( unsafePerformIO )
87 import "base" Unsafe.Coerce ( unsafeCoerce )
88 import qualified "inline-c" Language.C.Inline as C
89 import qualified "inline-c" Language.C.Inline.Unsafe as CU
90 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
91 import "primitive" Control.Monad.Primitive ( PrimMonad, PrimState, unsafePrimToPrim )
92 import "this" OpenCV.Internal
93 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
94 import "this" OpenCV.Internal.C.Types
95 import "this" OpenCV.Internal.C.PlacementNew.TH
96 import "this" OpenCV.Internal.Core.Types
97 import "this" OpenCV.Internal.Core.Types.Mat.Depth
98 import "this" OpenCV.Internal.Core.Types.Mat.Marshal
99 import "this" OpenCV.Internal.Exception
100 import "this" OpenCV.Internal.Mutable
101 import "this" OpenCV.TypeLevel
102 import "transformers" Control.Monad.Trans.Except
103 import qualified "vector" Data.Vector as V
104 import qualified "vector" Data.Vector.Generic as VG
105
106 --------------------------------------------------------------------------------
107
108 C.context openCvCtx
109
110 C.include "opencv2/core.hpp"
111 C.using "namespace cv"
112
113 --------------------------------------------------------------------------------
114 -- Matrix
115 --------------------------------------------------------------------------------
116
117 newtype Mat (shape :: DS [DS Nat])
118 (channels :: DS Nat)
119 (depth :: DS *)
120 = Mat {unMat :: ForeignPtr (C (Mat shape channels depth))}
121
122 type instance C (Mat shape channels depth) = C'Mat
123
124 type instance Mutable (Mat shape channels depth) = Mut (Mat shape channels depth)
125
126 instance WithPtr (Mat shape channels depth) where
127 withPtr = withForeignPtr . unMat
128
129 instance FromPtr (Mat shape channels depth) where
130 fromPtr = objFromPtr Mat $ \ptr ->
131 [CU.exp| void { delete $(Mat * ptr) }|]
132
133 instance FreezeThaw (Mat shape channels depth) where
134 freeze = cloneMatM . unMut
135 thaw = fmap Mut . cloneMatM
136
137 unsafeFreeze = pure . unMut
138 unsafeThaw = pure . Mut
139
140 {- | Tests whether a 'Mat' is deserving of its type level attributes
141
142 Checks if the properties encoded in the type of a 'Mat' correspond to
143 the value level representation. For each property that does not hold
144 this function will produce an error message. If everything checks out
145 it will produce an empty list.
146
147 The following properties are checked:
148
149 * Dimensionality
150 * Size of each dimension
151 * Number of channels
152 * Depth (data type of elements)
153
154 If a property is explicitly encoded as statically unknown ('D'ynamic)
155 it will not be checked.
156 -}
157 typeCheckMat
158 :: forall shape channels depth
159 . ( ToShapeDS (Proxy shape)
160 , ToChannelsDS (Proxy channels)
161 , ToDepthDS (Proxy depth)
162 )
163 => Mat shape channels depth -- ^ The matrix to be checked.
164 -> [CoerceMatError] -- ^ Error messages.
165 typeCheckMat mat =
166 fromMaybe [] (checkShape <$> dsToMaybe dsExpectedShape)
167 <> maybeToList (dsToMaybe dsExpectedNumChannels >>= checkNumChannels)
168 <> maybeToList (dsToMaybe dsExpectedDepth >>= checkDepth)
169 where
170 mi = matInfo mat
171
172 dsExpectedShape :: DS [DS Int32]
173 dsExpectedShape = toShapeDS (Proxy :: Proxy shape)
174
175 dsExpectedNumChannels :: DS Int32
176 dsExpectedNumChannels = toChannelsDS (Proxy :: Proxy channels)
177
178 dsExpectedDepth :: DS Depth
179 dsExpectedDepth = toDepthDS (Proxy :: Proxy depth)
180
181 checkShape :: [DS Int32] -> [CoerceMatError]
182 checkShape expectedShape = maybe checkSizes (:[]) dimCheck
183 where
184 dimCheck :: Maybe CoerceMatError
185 dimCheck | expectedDim == actualDim = Nothing
186 | otherwise = Just $ ShapeError $ ExpectationError expectedDim actualDim
187 where
188 expectedDim = length expectedShape
189 actualDim = length (miShape mi)
190
191 checkSizes :: [CoerceMatError]
192 checkSizes = catMaybes $ zipWith3 checkSize [1..] expectedShape (miShape mi)
193 where
194 checkSize :: Int -> DS Int32 -> Int32 -> Maybe CoerceMatError
195 checkSize dimIx dsExpected actual = dsToMaybe dsExpected >>= \expected ->
196 if expected == actual
197 then Nothing
198 else Just $ SizeError dimIx
199 $ fromIntegral
200 <$> ExpectationError expected actual
201
202 checkNumChannels :: Int32 -> Maybe CoerceMatError
203 checkNumChannels expectedNumChannels
204 | miChannels mi == expectedNumChannels = Nothing
205 | otherwise = Just $ ChannelError
206 $ fromIntegral
207 <$> ExpectationError expectedNumChannels (miChannels mi)
208
209 checkDepth :: Depth -> Maybe CoerceMatError
210 checkDepth expectedDepth
211 | miDepth mi == expectedDepth = Nothing
212 | otherwise = Just $ DepthError
213 $ ExpectationError expectedDepth (miDepth mi)
214
215 -- | Relaxes the type level constraints
216 --
217 -- Only identical or looser constraints are allowed. For tighter
218 -- constraints use 'coerceMat'.
219 --
220 -- This allows you to \'forget\' type level guarantees for zero
221 -- cost. Similar to 'unsafeCoerceMat', but totally safe.
222 --
223 -- [Identical] @a@ to @b@ with @a ~ b@
224 -- [Looser] @(\''S' a)@ to @\''D'@ or @(\''S' a)@ to @(\''S' b)@ with @'MayRelax' a b@
225 -- [Tighter] @\''D'@ to @(\''S' a)@
226 relaxMat
227 :: ( MayRelax shapeIn shapeOut
228 , MayRelax channelsIn channelsOut
229 , MayRelax depthIn depthOut
230 )
231 => Mat shapeIn channelsIn depthIn -- ^ Original 'Mat'.
232 -> Mat shapeOut channelsOut depthOut -- ^ 'Mat' with relaxed constraints.
233 relaxMat = unsafeCoerce
234
235 coerceMat
236 :: ( ToShapeDS (Proxy shapeOut)
237 , ToChannelsDS (Proxy channelsOut)
238 , ToDepthDS (Proxy depthOut)
239 )
240 => Mat shapeIn channelsIn depthIn -- ^
241 -> CvExcept (Mat shapeOut channelsOut depthOut)
242 coerceMat matIn | null errors = pure matOut
243 | otherwise = throwE $ CoerceMatError errors
244 where
245 matOut = unsafeCoerceMat matIn
246 errors = typeCheckMat matOut
247
248 unsafeCoerceMat
249 :: Mat shapeIn channelsIn depthIn
250 -> Mat shapeOut channelsOut depthOut
251 unsafeCoerceMat = unsafeCoerce
252
253 -- | Similar to 'withPtr' in that it keeps the 'ForeignPtr' alive
254 -- during the execution of the given action but it doesn't extract the 'Ptr'
255 -- from the 'ForeignPtr'.
256 keepMatAliveDuring :: Mat shape channels depth -> IO a -> IO a
257 keepMatAliveDuring mat m = do
258 x <- m
259 touchForeignPtr $ unMat mat
260 pure x
261
262 newEmptyMat :: IO (Mat ('S '[]) ('S 1) ('S Word8))
263 newEmptyMat = unsafeCoerceMat <$> fromPtr [CU.exp|Mat * { new Mat() }|]
264
265 -- TODO (RvD): what happens if we construct a mat with more than 4 channels?
266 -- A scalar is just 4 values. What would be the default value of the 5th channel?
267 newMat
268 :: ( ToShape shape
269 , ToChannels channels
270 , ToDepth depth
271 , ToScalar scalar
272 -- , MinLengthDS 2 shape
273 -- , 1 .<=? channels
274 -- , channels .<=? 512
275 -- , 2 <= Length shape
276 -- , 1 <= channels
277 -- , channels <= 512
278 )
279 => shape -- ^
280 -> channels
281 -> depth
282 -> scalar
283 -> CvExceptT IO (Mat (ShapeT shape) (ChannelsT channels) (DepthT depth))
284 newMat shape channels depth defValue = ExceptT $ do
285 dst <- newEmptyMat
286 handleCvException (pure $ unsafeCoerceMat dst) $
287 withVector shape' $ \shapePtr ->
288 withPtr (toScalar defValue) $ \scalarPtr ->
289 withPtr dst $ \dstPtr ->
290 [cvExcept|
291 *$(Mat * dstPtr) =
292 Mat( $(int32_t c'ndims)
293 , $(int32_t * shapePtr)
294 , $(int32_t c'type)
295 , *$(Scalar * scalarPtr)
296 );
297 |]
298 where
299 c'ndims = fromIntegral $ VG.length shape'
300 c'type = marshalFlags depth' channels'
301
302 shape' = toShape shape
303 channels' = toChannels channels
304 depth' = toDepth depth
305
306 -- TODO (BvD): Move to some Utility module.
307 withVector
308 :: (VG.Vector v a, Storable a)
309 => v a -- ^
310 -> (Ptr a -> IO b)
311 -> IO b
312 withVector v f =
313 allocaArray n $ \ptr ->
314 let go !ix
315 | ix < n = do
316 pokeElemOff ptr ix (VG.unsafeIndex v ix)
317 go (ix+1)
318 | otherwise = f ptr
319 in go 0
320 where
321 n = VG.length v
322
323 withMatData
324 :: Mat shape channels depth -- ^
325 -> ([CSize] -> Ptr Word8 -> IO a)
326 -> IO a
327 withMatData mat f = withPtr mat $ \matPtr ->
328 alloca $ \(dimsPtr :: Ptr Int32 ) ->
329 alloca $ \(stepPtr2 :: Ptr (Ptr CSize)) ->
330 alloca $ \(dataPtr2 :: Ptr (Ptr Word8)) -> do
331 [CU.block|void {
332 const Mat * const matPtr = $(Mat * matPtr);
333 *$(int32_t * const dimsPtr ) = matPtr->dims;
334 *$(size_t * * const stepPtr2) = matPtr->step.p;
335 *$(uint8_t * * const dataPtr2) = matPtr->data;
336 }|]
337 dims <- peek dimsPtr
338 stepPtr <- peek stepPtr2
339 dataPtr <- peek dataPtr2
340 step <- peekArray (fromIntegral dims) stepPtr
341 f step dataPtr
342
343 matElemAddress :: Ptr Word8 -> [Int] -> [Int] -> Ptr a
344 matElemAddress dataPtr step pos = dataPtr `plusPtr` offset
345 where
346 offset = sum $ zipWith (*) step pos
347
348 -- TODO (RvD): check for negative sizes
349 -- This crashes OpenCV
350 mkMat
351 :: ( ToShape shape
352 , ToChannels channels
353 , ToDepth depth
354 , ToScalar scalar
355 )
356 => shape -- ^
357 -> channels -- ^
358 -> depth -- ^
359 -> scalar -- ^
360 -> CvExcept (Mat (ShapeT shape) (ChannelsT channels) (DepthT depth))
361 mkMat shape channels depth defValue =
362 unsafeCvExcept $ newMat shape channels depth defValue
363
364 cloneMat :: Mat shape channels depth
365 -> Mat shape channels depth
366 cloneMat = unsafePerformIO . cloneMatIO
367
368 cloneMatIO :: Mat shape channels depth
369 -> IO (Mat shape channels depth)
370 cloneMatIO mat =
371 fmap unsafeCoerceMat $ fromPtr $ withPtr mat $ \matPtr ->
372 [C.exp|Mat * { new Mat($(Mat * matPtr)->clone()) }|]
373
374 --------------------------------------------------------------------------------
375 -- Mutable matrix
376 --------------------------------------------------------------------------------
377
378 typeCheckMatM
379 :: forall shape channels depth s
380 . ( ToShapeDS (Proxy shape)
381 , ToChannelsDS (Proxy channels)
382 , ToDepthDS (Proxy depth)
383 )
384 => Mut (Mat shape channels depth) s -- ^ The matrix to be checked.
385 -> [CoerceMatError] -- ^ Error messages.
386 typeCheckMatM = typeCheckMat . unMut
387
388 relaxMatM
389 :: ( MayRelax shapeIn shapeOut
390 , MayRelax channelsIn channelsOut
391 , MayRelax depthIn depthOut
392 )
393 => Mut (Mat shapeIn channelsIn depthIn ) s -- ^ Original 'Mat'.
394 -> Mut (Mat shapeOut channelsOut depthOut) s -- ^ 'Mat' with relaxed constraints.
395 relaxMatM = unsafeCoerce
396
397 coerceMatM
398 :: ( ToShapeDS (Proxy shapeOut)
399 , ToChannelsDS (Proxy channelsOut)
400 , ToDepthDS (Proxy depthOut)
401 )
402 => Mut (Mat shapeIn channelsIn depthIn) s -- ^
403 -> CvExcept (Mut (Mat shapeOut channelsOut depthOut) s)
404 coerceMatM = fmap Mut . coerceMat . unMut
405
406 unsafeCoerceMatM
407 :: Mut (Mat shapeIn channelsIn depthIn ) s
408 -> Mut (Mat shapeOut channelsOut depthOut) s
409 unsafeCoerceMatM = unsafeCoerce
410
411 -- TODO (RvD): check for negative sizes
412 -- This crashes OpenCV
413 mkMatM
414 :: ( PrimMonad m
415 , ToShape shape
416 , ToChannels channels
417 , ToDepth depth
418 , ToScalar scalar
419 )
420 => shape -- ^
421 -> channels -- ^
422 -> depth -- ^
423 -> scalar -- ^
424 -> CvExceptT m (Mut (Mat (ShapeT shape) (ChannelsT channels) (DepthT depth)) (PrimState m))
425 mkMatM shape channels depth defValue = do
426 mat <- mapExceptT unsafePrimToPrim $ newMat shape channels depth defValue
427 unsafeThaw mat
428
429 createMat
430 :: (forall s. CvExceptT (ST s) (Mut (Mat shape channels depth) s)) -- ^
431 -> CvExcept (Mat shape channels depth)
432 createMat mk = runCvExceptST $ unsafeFreeze =<< mk
433
434 withMatM
435 :: ( ToShape shape
436 , ToChannels channels
437 , ToDepth depth
438 , ToScalar scalar
439 )
440 => shape -- ^
441 -> channels -- ^
442 -> depth -- ^
443 -> scalar -- ^
444 -> ( forall s
445 . Mut (Mat (ShapeT shape) (ChannelsT channels) (DepthT depth)) (PrimState (ST s))
446 -> CvExceptT (ST s) ()
447 )
448 -> CvExcept (Mat (ShapeT shape) (ChannelsT channels) (DepthT depth))
449 withMatM shape channels depth defValue f = createMat $ do
450 matM <- mkMatM shape channels depth defValue
451 f matM
452 pure matM
453
454 cloneMatM :: (PrimMonad m)
455 => Mat shape channels depth
456 -> m (Mat shape channels depth)
457 cloneMatM = unsafePrimToPrim . cloneMatIO
458
459 -- | Deallocates the matrix data.
460 --
461 -- Highly unsafe. Subsequent operations that need the data will
462 -- generate exceptions (or segfaults).
463 deallocateMatM
464 :: (PrimMonad m)
465 => Mut (Mat shape channels depth) (PrimState m)
466 -> m ()
467 deallocateMatM mutMat = unsafePrimToPrim $ do
468 e <- handleCvException (pure ()) $
469 withPtr mutMat $ \mutMatPtr ->
470 [cvExcept| $(Mat * mutMatPtr)->deallocate(); |]
471 either throwIO pure e
472
473 --------------------------------------------------------------------------------
474 -- Meta information
475 --------------------------------------------------------------------------------
476
477 data MatInfo
478 = MatInfo
479 { miShape :: ![Int32]
480 , miDepth :: !Depth
481 , miChannels :: !Int32
482 } deriving (Show, Eq)
483
484 matInfo :: Mat shape channels depth -> MatInfo
485 matInfo mat = unsafePerformIO $
486 withPtr mat $ \matPtr ->
487 alloca $ \(flagsPtr :: Ptr Int32) ->
488 alloca $ \(dimsPtr :: Ptr Int32) ->
489 alloca $ \(sizePtr :: Ptr (Ptr Int32)) -> do
490 [CU.block|void {
491 const Mat * const matPtr = $(Mat * matPtr);
492 *$(int32_t * const flagsPtr) = matPtr->flags;
493 *$(int32_t * const dimsPtr ) = matPtr->dims;
494 *$(int32_t * * const sizePtr ) = matPtr->size.p;
495 }|]
496 (depth, channels) <- unmarshalFlags <$> peek flagsPtr
497 dims <- peek dimsPtr
498 size <- peek sizePtr
499 shape <- peekArray (fromIntegral dims) size
500 pure MatInfo
501 { miShape = shape
502 , miDepth = depth
503 , miChannels = channels
504 }
505
506 -- | All possible positions (indexes) for a given shape (list of
507 -- sizes per dimension).
508 --
509 -- @
510 -- dimPositions [3, 4]
511 -- [ [0, 0], [0, 1], [0, 2], [0, 3]
512 -- , [1, 0], [1, 1], [1, 2], [1, 3]
513 -- , [2, 0], [2, 1], [2, 2], [2, 3]
514 -- ]
515 -- @
516 dimPositions :: (Num a, Enum a) => [a] -> [[a]]
517 dimPositions = traverse (enumFromTo 0 . pred)
518
519 --------------------------------------------------------------------------------
520
521 type family ShapeT (a :: ka) :: DS [DS Nat] where
522 ShapeT [Int32] = 'D
523 ShapeT (V.Vector Int32) = 'D
524 ShapeT (x ::: xs) = 'S (DSNats (x ::: xs))
525 ShapeT (xs :: [Nat]) = 'S (DSNats xs)
526 ShapeT (Proxy a) = ShapeT a
527
528 type ChannelsT a = DSNat a
529
530 --------------------------------------------------------------------------------
531
532 class ToShape a where
533 toShape :: a -> V.Vector Int32
534
535 -- | identity
536 instance ToShape (V.Vector Int32) where
537 toShape = id
538
539 -- | direct conversion to 'V.Vector'
540 instance ToShape [Int32] where
541 toShape = V.fromList
542
543 -- | empty 'V.Vector'
544 instance ToShape (Proxy '[]) where
545 toShape _proxy = V.empty
546
547 -- | fold over the type level list
548 instance (ToInt32 (Proxy a), ToShape (Proxy as))
549 => ToShape (Proxy (a ': as)) where
550 toShape _proxy =
551 V.cons
552 (toInt32 (Proxy :: Proxy a))
553 (toShape (Proxy :: Proxy as))
554
555 -- | empty 'V.Vector'
556 instance ToShape Z where
557 toShape Z = V.empty
558
559 -- | fold over ':::'
560 instance (ToInt32 a, ToShape as) => ToShape (a ::: as) where
561 toShape (a ::: as) = V.cons (toInt32 a) (toShape as)
562
563 --------------------------------------------------------------------------------
564
565 class ToShapeDS a where
566 toShapeDS :: a -> DS [DS Int32]
567
568 instance ToShapeDS (proxy 'D) where
569 toShapeDS _proxy = D
570
571 instance (ToNatListDS (Proxy as)) => ToShapeDS (Proxy ('S as)) where
572 toShapeDS _proxy = S $ toNatListDS (Proxy :: Proxy as)
573
574 --------------------------------------------------------------------------------
575
576 type ToChannels a = ToInt32 a
577
578 toChannels :: (ToInt32 a) => a -> Int32
579 toChannels = toInt32
580
581 type ToChannelsDS a = ToNatDS a
582
583 toChannelsDS :: (ToChannelsDS a) => a -> DS Int32
584 toChannelsDS = toNatDS
585
586 --------------------------------------------------------------------------------
587
588 mkPlacementNewInstance ''Mat