{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module FreeType.Exception.Internal where import FreeType.Exception.Types import Control.Monad (unless) import Control.Exception import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Storable #include "ft2build.h" #include FT_FREETYPE_H -- | An internal function for throwing 'FtError's ftError :: String -> IO FT_Error -> IO () ftError name action = do code <- action unless (code == 0) . throwIO $ FtError name code class AutoError a b where -- | @ -- autoError name f = \a b c ... -> -- ftError name $ f a b c ... -- @ autoError :: String -> a -> b instance AutoError (a -> IO FT_Error) (a -> IO ()) where autoError name f = ftError name . f instance AutoError (b -> c) (b -> d) => AutoError (a -> b -> c) (a -> b -> d) where autoError name f = autoError name . f class AutoAllocaError a b where -- | @ -- autoAllocaError name f = \a b c -> -- alloca $ \ptr -> do -- ftError name $ f a b c ... ptr -- peek ptr -- @ autoAllocaError :: String -> a -> b instance Storable a => AutoAllocaError (Ptr a -> IO FT_Error) (IO a) where autoAllocaError name f = alloca $ \ptr -> do ftError name $ f ptr peek ptr instance Storable b => AutoAllocaError (a -> Ptr b -> IO FT_Error) (a -> IO b) where autoAllocaError name f = \a -> alloca $ \ptr -> do ftError name $ f a ptr peek ptr instance AutoAllocaError (b -> c) (b -> d) => AutoAllocaError (a -> b -> c) (a -> b -> d) where autoAllocaError name f = autoAllocaError name . f