Error.hs

{-#  LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving,
              DeriveDataTypeable
  #-}
module Sound.Alsa.Error where

import Control.Exception.Extensible (Exception, throw, catch, )
import Data.Typeable (Typeable, )
import Foreign.C.Error (Errno(Errno), ePIPE, errnoToIOError, )
import Foreign.C.String (CString, peekCString, )
import Prelude hiding (catch, )

data AlsaException =
  AlsaException { exception_location    :: String
                , exception_description :: String
                , exception_code        :: Errno
                } deriving (Typeable)

instance Show AlsaException where
   showsPrec p (AlsaException l d (Errno c)) =
      showParen (p>10)
         (showString "AlsaException " .
          shows l . showString " " .
          shows d . showString " " .
          showParen True (showString "Errno " . shows c))

instance Exception AlsaException where

checkResult :: Integral a => String -> a -> IO a
checkResult f r
  | r < 0 = throwAlsa f (Errno (negate (fromIntegral r)))
  | otherwise = return r

checkResult_ :: Integral a => String -> a -> IO ()
checkResult_ f r = checkResult f r >> return ()

throwAlsa :: String -> Errno -> IO a
throwAlsa fun err = do d <- strerror err
                       throw AlsaException
                         { exception_location = fun
                         , exception_description = d
                         , exception_code = err
                         }

catchAlsa :: IO a -> (AlsaException -> IO a) -> IO a
catchAlsa = catch

catchAlsaErrno :: Errno
               -> IO a -- ^ Action
               -> IO a -- ^ Handler
               -> IO a
catchAlsaErrno e x h =
    catchAlsa x (\ex -> if exception_code ex == e then h else throw ex)

catchXRun :: IO a -- ^ Action
          -> IO a -- ^ Handler
          -> IO a
catchXRun = catchAlsaErrno ePIPE

showAlsaException :: AlsaException -> String
showAlsaException e = exception_location e ++ ": " ++ exception_description e

-- | Converts any 'AlsaException' into an 'IOError'.
-- This produces better a error message than letting an uncaught
-- 'AlsaException' propagate to the top.
rethrowAlsaExceptions :: IO a -> IO a
rethrowAlsaExceptions x =
    catchAlsa x $ \e ->
       ioError (errnoToIOError (exception_location e)
                               (exception_code e) Nothing Nothing)

-- | Returns the message for an error code.
strerror :: Errno -> IO String
strerror x = peekCString =<< snd_strerror x

foreign import ccall "alsa/asoundlib.h snd_strerror"
  snd_strerror :: Errno -> IO CString