    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Sound.ALUT.Initialization
    -- Copyright   :  (c) Sven Panne 2005-2009
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- Stability   :  stable
    -- Portability :  portable
    --
    --------------------------------------------------------------------------------

    module Sound.ALUT.Initialization (
       ArgumentConsumer, Runner, runALUT, runALUTUsingCurrentContext,
       withProgNameAndArgs
    )  where

    import Data.List ( genericLength )
    import Foreign.C.String ( CString, withCString, peekCString )
    import Foreign.C.Types ( CInt )
    import Foreign.Marshal.Array ( withArray0, peekArray )
    import Foreign.Marshal.Utils ( with, withMany )
    import Foreign.Ptr ( Ptr, nullPtr )
    import Foreign.Storable ( Storable(peek) )
    import Sound.ALUT.Errors ( throwIfALfalse )
    import Sound.ALUT.Config ( alut_Init, alut_InitWithoutContext, alut_Exit )
    import Sound.OpenAL.AL.BasicTypes ( ALboolean )
    import System.Environment ( getProgName, getArgs )

    -- Ugly: I see something like this in almost every package now...
    #ifdef __NHC__
    import IO ( bracket )

    finally :: IO a -> IO b -> IO a
    action `finally` sequel = bracket (return ()) (const sequel) (const action)

    #else
    import Control.Exception ( finally )
    #endif

    --------------------------------------------------------------------------------

    type ArgumentConsumer a = String -> [String] -> a

    type Runner a = ArgumentConsumer (IO a) -> IO a

    --------------------------------------------------------------------------------

    runALUT :: ArgumentConsumer (Runner a)
    runALUT = runner "runALUT" alut_Init

    --------------------------------------------------------------------------------

    runALUTUsingCurrentContext :: ArgumentConsumer (Runner a)
    runALUTUsingCurrentContext =
       runner "runALUTUsingCurrentContext" alut_InitWithoutContext

    --------------------------------------------------------------------------------

    runner :: String -> (Ptr CInt -> Ptr CString -> IO ALboolean) -> String
           -> [String] -> Runner a
    runner name initAction progName args action =
       with (1 + genericLength args) $ \argcBuf ->
          withMany withCString (progName : args) $ \argvPtrs ->
             withArray0 nullPtr argvPtrs $ \argvBuf -> do
                throwIfALfalse name $ initAction argcBuf argvBuf
                newArgc <- peek argcBuf
                newArgvPtrs <- peekArray (fromIntegral newArgc) argvBuf
                newArgv <- mapM peekCString newArgvPtrs
                action (head newArgv) (tail newArgv)
                   `finally` throwIfALfalse name alut_Exit

    --------------------------------------------------------------------------------

    withProgNameAndArgs :: (ArgumentConsumer (Runner a)) -> Runner a
    withProgNameAndArgs alutRunner action = do
       n <- getProgName
       a <- getArgs
       alutRunner n a action