never executed always true always false

    1 {-# language CPP #-}
    2 {-# language DeriveFunctor #-}
    3 {-# language QuasiQuotes #-}
    4 {-# language RankNTypes #-}
    5 {-# language TemplateHaskell #-}
    6 
    7 #ifndef ENABLE_INTERNAL_DOCUMENTATION
    8 {-# OPTIONS_HADDOCK hide #-}
    9 #endif
   10 
   11 module OpenCV.Internal.Exception
   12     ( -- * Exception type
   13       CvException(..)
   14     , CoerceMatError(..)
   15     , ExpectationError(..)
   16     , CvCppException
   17 
   18       -- * Handling C++ exceptions
   19     , handleCvException
   20 
   21       -- * Quasi quoters
   22     , cvExcept
   23     , cvExceptU
   24 
   25       -- * Monadic interface
   26     , CvExcept
   27     , CvExceptT
   28     , pureExcept
   29 
   30       -- * Promoting exceptions to errors
   31     , exceptError
   32     , exceptErrorIO
   33     , exceptErrorM
   34     , runCvExceptST
   35 
   36       -- * Unsafe stuff
   37     , unsafeCvExcept
   38     , unsafeWrapException
   39     ) where
   40 
   41 import "base" Control.Monad.ST ( ST, runST )
   42 import "base" Control.Exception ( Exception, mask_, throw, throwIO )
   43 import "base" Control.Monad ( (<=<) )
   44 import "base" Data.Functor.Identity
   45 import "base" Data.Monoid ( (<>) )
   46 import "base" Foreign.C.String ( peekCString )
   47 import "base" Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
   48 import "base" Foreign.Ptr ( Ptr, nullPtr )
   49 import "base" System.IO.Unsafe ( unsafePerformIO )
   50 import qualified "inline-c" Language.C.Inline as C
   51 import qualified "inline-c" Language.C.Inline.Unsafe as CU
   52 import qualified "inline-c-cpp" Language.C.Inline.Cpp as C
   53 import "template-haskell" Language.Haskell.TH.Quote ( QuasiQuoter, quoteExp )
   54 import "this" OpenCV.Internal.C.Inline ( openCvCtx )
   55 import "this" OpenCV.Internal.C.Types
   56 import "this" OpenCV.Internal.Core.Types.Mat.Depth
   57 import "this" OpenCV.Internal ( objFromPtr )
   58 import "transformers" Control.Monad.Trans.Except
   59 
   60 --------------------------------------------------------------------------------
   61 
   62 C.context openCvCtx
   63 
   64 C.include "opencv2/core.hpp"
   65 C.using "namespace cv"
   66 
   67 
   68 --------------------------------------------------------------------------------
   69 -- Exceptions
   70 --------------------------------------------------------------------------------
   71 
   72 data CvException
   73    = BindingException !CvCppException
   74    | CoerceMatError ![CoerceMatError]
   75      deriving Show
   76 
   77 data CoerceMatError
   78    = ShapeError        !(ExpectationError Int)
   79    | SizeError    !Int !(ExpectationError Int)
   80    | ChannelError      !(ExpectationError Int)
   81    | DepthError        !(ExpectationError Depth)
   82      deriving Show
   83 
   84 data ExpectationError a
   85    = ExpectationError
   86      { expectedValue :: !a
   87      , actualValue   :: !a
   88      } deriving (Show, Functor)
   89 
   90 instance Exception CvException
   91 
   92 newtype CvCppException = CvCppException { unCvCppException :: ForeignPtr (C CvCppException) }
   93 
   94 type instance C CvCppException = C'CvCppException
   95 
   96 instance WithPtr CvCppException where
   97     withPtr = withForeignPtr . unCvCppException
   98 
   99 instance FromPtr CvCppException where
  100     fromPtr = objFromPtr CvCppException $ \ptr ->
  101                 [CU.exp| void { delete $(Exception * ptr) }|]
  102 
  103 instance Show CvCppException where
  104     show cvException = unsafePerformIO $
  105         withPtr cvException $ \cvExceptionPtr -> do
  106           charPtr <- [CU.exp| const char * { $(Exception * cvExceptionPtr)->what() } |]
  107           peekCString charPtr
  108 
  109 handleCvException
  110     :: IO a
  111     -> IO (Ptr (C CvCppException))
  112     -> IO (Either CvException a)
  113 handleCvException okAct act = mask_ $ do
  114     exceptionPtr <- act
  115     if exceptionPtr /= nullPtr
  116       then do cppErr <- fromPtr (pure exceptionPtr)
  117               pure $ Left $ BindingException cppErr
  118       else Right <$> okAct
  119 
  120 cvExcept :: QuasiQuoter
  121 cvExcept = C.block {quoteExp = \s -> quoteExp C.block $ cvExceptWrap s}
  122 
  123 cvExceptU :: QuasiQuoter
  124 cvExceptU = CU.block {quoteExp = \s -> quoteExp CU.block $ cvExceptWrap s}
  125 
  126 cvExceptWrap :: String -> String
  127 cvExceptWrap s = unlines
  128    [ "Exception * {"
  129    , "  try"
  130    , "  {   " <> s <> ""
  131    , "    return NULL;"
  132    , "  }"
  133    , "  catch (const cv::Exception & e)"
  134    , "  {"
  135    , "    return new cv::Exception(e);"
  136    , "  }"
  137    , "}"
  138    ]
  139 
  140 type CvExcept    a = Except  CvException   a
  141 type CvExceptT m a = ExceptT CvException m a
  142 
  143 pureExcept :: (Applicative m) => CvExcept a -> CvExceptT m a
  144 pureExcept = mapExceptT (pure . runIdentity)
  145 
  146 exceptError :: CvExcept a -> a
  147 exceptError = either throw id . runExcept
  148 
  149 exceptErrorIO :: CvExceptT IO a -> IO a
  150 exceptErrorIO = either throwIO pure <=< runExceptT
  151 
  152 exceptErrorM :: (Monad m) => CvExceptT m a -> m a
  153 exceptErrorM = either throw pure <=< runExceptT
  154 
  155 runCvExceptST :: (forall s. CvExceptT (ST s) a) -> CvExcept a
  156 runCvExceptST act = except $ runST $ runExceptT act
  157 
  158 unsafeCvExcept :: CvExceptT IO a -> CvExcept a
  159 unsafeCvExcept = mapExceptT (Identity . unsafePerformIO)
  160 
  161 unsafeWrapException :: IO (Either CvException a) -> CvExcept a
  162 unsafeWrapException = unsafeCvExcept . ExceptT