{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DeriveDataTypeable #-}
{- |
ALSA does not distinguish between programming errors and runtime exceptions,
which is sad, but we have to cope with it.
-}
module Sound.ALSA.Exception where

import qualified Control.Exception.Extensible as Exc
import Control.Exception.Extensible (Exception, )

import Data.Typeable (Typeable, )
import Foreign.C.Error (Errno(Errno), ePIPE, errnoToIOError, )
import Foreign.C.String (CString, peekCString, )
import qualified Foreign.C.Types as C

import Prelude hiding (catch, show, )
import qualified Prelude as P

data T = Cons {
   T -> String
location    :: String,
   T -> String
description :: String,
   T -> Errno
code        :: Errno
   } deriving (Typeable)

instance Show T where
   showsPrec :: Int -> T -> ShowS
showsPrec Int
p (Cons String
l String
d (Errno CInt
c)) =
      Bool -> ShowS -> ShowS
showParen (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
10)
         (String -> ShowS
showString String
"AlsaException.Cons " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          String -> ShowS
forall a. Show a => a -> ShowS
shows String
l ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          String -> ShowS
forall a. Show a => a -> ShowS
shows String
d ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Bool -> ShowS -> ShowS
showParen Bool
True (String -> ShowS
showString String
"Errno " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> ShowS
forall a. Show a => a -> ShowS
shows CInt
c))

instance Exception T where

checkResult :: Integral a => String -> a -> IO a
checkResult :: String -> a -> IO a
checkResult String
f a
r =
   if a
r a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0
     then String -> Errno -> IO a
forall a. String -> Errno -> IO a
throw String
f (CInt -> Errno
Errno (CInt -> CInt
forall a. Num a => a -> a
negate (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
r)))
     else a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

checkResult_ :: Integral a => String -> a -> IO ()
checkResult_ :: String -> a -> IO ()
checkResult_ String
f a
r = String -> a -> IO a
forall a. Integral a => String -> a -> IO a
checkResult String
f a
r IO a -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkResultMaybe :: String -> (C.CInt -> a) -> (C.CInt -> Maybe a) -> C.CInt -> IO a
checkResultMaybe :: String -> (CInt -> a) -> (CInt -> Maybe a) -> CInt -> IO a
checkResultMaybe String
f CInt -> a
ok CInt -> Maybe a
err CInt
x =
   if CInt
x CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
>= CInt
0
     then a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> a
ok CInt
x)
     else case CInt -> Maybe a
err CInt
x of
             Just a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
             Maybe a
_ -> String -> Errno -> IO a
forall a. String -> Errno -> IO a
throw String
f (CInt -> Errno
Errno CInt
x)


throw :: String -> Errno -> IO a
throw :: String -> Errno -> IO a
throw String
fun Errno
err = do
   String
d <- Errno -> IO String
strerror Errno
err
   T -> IO a
forall a e. Exception e => e -> a
Exc.throw Cons :: String -> String -> Errno -> T
Cons
     { location :: String
location = String
fun
     , description :: String
description = String
d
     , code :: Errno
code = Errno
err
     }

catch :: IO a -> (T -> IO a) -> IO a
catch :: IO a -> (T -> IO a) -> IO a
catch = IO a -> (T -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exc.catch

catchErrno ::
      Errno
   -> IO a -- ^ Action
   -> IO a -- ^ Handler
   -> IO a
catchErrno :: Errno -> IO a -> IO a -> IO a
catchErrno Errno
e IO a
x IO a
h =
   IO a -> (T -> IO a) -> IO a
forall a. IO a -> (T -> IO a) -> IO a
catch IO a
x (\T
ex -> if T -> Errno
code T
ex Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
e then IO a
h else T -> IO a
forall a e. Exception e => e -> a
Exc.throw T
ex)

catchXRun ::
      IO a -- ^ Action
   -> IO a -- ^ Handler
   -> IO a
catchXRun :: IO a -> IO a -> IO a
catchXRun = Errno -> IO a -> IO a -> IO a
forall a. Errno -> IO a -> IO a -> IO a
catchErrno Errno
ePIPE

showErrno :: Errno -> String
showErrno :: Errno -> String
showErrno (Errno CInt
n) = CInt -> String
forall a. Show a => a -> String
P.show CInt
n

show :: T -> String
show :: T -> String
show T
e =
   T -> String
location T
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++
   T -> String
description T
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Errno -> String
showErrno (T -> Errno
code T
e) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

-- | Converts any 'AlsaException.T' into an 'IOError'.
-- This produces better a error message than letting an uncaught
-- 'AlsaException.T' propagate to the top.
rethrow :: IO a -> IO a
rethrow :: IO a -> IO a
rethrow IO a
x =
    IO a -> (T -> IO a) -> IO a
forall a. IO a -> (T -> IO a) -> IO a
catch IO a
x ((T -> IO a) -> IO a) -> (T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \T
e ->
       IOError -> IO a
forall a. IOError -> IO a
ioError (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError (T -> String
location T
e)
                               (T -> Errno
code T
e) Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)

-- | Returns the message for an error code.
strerror :: Errno -> IO String
strerror :: Errno -> IO String
strerror Errno
x = CString -> IO String
peekCString (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Errno -> IO CString
snd_strerror Errno
x

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