1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
#include "SDL.h"
#ifdef main
#undef main
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Graphics.UI.SDL.General
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
-----------------------------------------------------------------------------
module Graphics.UI.SDL.General
( init
, withInit
, initSubSystem
, quitSubSystem
, quit
, wasInit
, getError
, failWithError
, unwrapBool
, unwrapMaybe
, unwrapInt
, InitFlag(..)
) where
import Foreign.C (peekCString,CString)
import Data.Maybe (fromMaybe)
import Control.Monad (when)
import Data.Word (Word32)
import Control.Exception (bracket_)
import Prelude hiding (init,Enum(..))
import Graphics.UI.SDL.Utilities (Enum(..), toBitmask, fromBitmask)
data InitFlag = InitTimer
| InitAudio
| InitVideo
| InitCDROM
| InitJoystick
| InitNoParachute
| InitEventthread
| InitEverything
deriving (Eq, Ord, Show, Read)
instance Bounded InitFlag where
minBound = InitTimer
maxBound = InitEventthread
instance Enum InitFlag Word32 where
fromEnum InitTimer = #{const SDL_INIT_TIMER}
fromEnum InitAudio = #{const SDL_INIT_AUDIO}
fromEnum InitVideo = #{const SDL_INIT_VIDEO}
fromEnum InitCDROM = #{const SDL_INIT_CDROM}
fromEnum InitJoystick = #{const SDL_INIT_JOYSTICK}
fromEnum InitNoParachute = #{const SDL_INIT_NOPARACHUTE}
fromEnum InitEventthread = #{const SDL_INIT_EVENTTHREAD}
fromEnum InitEverything = #{const SDL_INIT_EVERYTHING}
toEnum #{const SDL_INIT_TIMER} = InitTimer
toEnum #{const SDL_INIT_AUDIO} = InitAudio
toEnum #{const SDL_INIT_VIDEO}= InitVideo
toEnum #{const SDL_INIT_CDROM} = InitCDROM
toEnum #{const SDL_INIT_JOYSTICK} = InitJoystick
toEnum #{const SDL_INIT_NOPARACHUTE} = InitNoParachute
toEnum #{const SDL_INIT_EVENTTHREAD} = InitEventthread
toEnum #{const SDL_INIT_EVERYTHING} = InitEverything
toEnum _ = error "Graphics.UI.SDL.General.toEnum: bad argument"
succ InitTimer = InitAudio
succ InitAudio = InitVideo
succ InitVideo = InitCDROM
succ InitCDROM = InitJoystick
succ InitJoystick = InitNoParachute
succ InitNoParachute = InitEventthread
succ InitEventthread = InitEverything
succ _ = error "Graphics.UI.SDL.General.succ: bad argument"
pred InitAudio = InitTimer
pred InitVideo = InitAudio
pred InitCDROM = InitVideo
pred InitJoystick = InitCDROM
pred InitNoParachute = InitJoystick
pred InitEventthread = InitNoParachute
pred InitEverything = InitEventthread
pred _ = error "Graphics.UI.SDL.General.pred: bad argument"
enumFromTo x y | x > y = []
| x == y = [y]
| True = x : enumFromTo (succ x) y
unwrapMaybe :: String -> IO (Maybe a) -> IO a
unwrapMaybe errMsg action
= do val <- action
case val of
Just a -> return a
Nothing -> failWithError errMsg
unwrapInt :: (Int -> Bool) -> String -> IO Int -> IO Int
unwrapInt fn errMsg action
= do val <- action
if fn val
then return val
else failWithError errMsg
unwrapBool :: String -> IO Bool -> IO ()
unwrapBool errMsg action
= do val <- action
case val of
True -> return ()
False -> failWithError errMsg
foreign import ccall unsafe "SDL_Init" sdlInit :: Word32 -> IO Int
-- | Initializes SDL. This should be called before all other SDL functions.
init :: [InitFlag] -> IO ()
init flags
= do ret <- sdlInit (fromIntegral (toBitmask flags))
when (ret == (-1)) (failWithError "SDL_Init")
withInit :: [InitFlag] -> IO a -> IO a
withInit flags action
= bracket_ (init flags) quit action
foreign import ccall unsafe "SDL_InitSubSystem" sdlInitSubSystem :: Word32 -> IO Int
-- | After SDL has been initialized with SDL_Init you may initialize
-- uninitialized subsystems with SDL_InitSubSystem.
initSubSystem :: [InitFlag] -> IO ()
initSubSystem flags
= do ret <- sdlInitSubSystem (fromIntegral (toBitmask flags))
when (ret == (-1)) (failWithError "SDL_InitSubSystem")
foreign import ccall unsafe "SDL_QuitSubSystem" sdlQuitSubSystem :: Word32 -> IO ()
quitSubSystem :: [InitFlag] -> IO ()
quitSubSystem = sdlQuitSubSystem . fromIntegral . toBitmask
foreign import ccall unsafe "SDL_Quit" sdlQuit :: IO ()
quit :: IO ()
quit = sdlQuit
foreign import ccall unsafe "SDL_WasInit" sdlWasInit :: Word32 -> IO Word32
-- | wasInit allows you to see which SDL subsytems have been initialized
wasInit :: [InitFlag] -> IO [InitFlag]
wasInit flags
= do ret <- sdlWasInit (fromIntegral (toBitmask flags))
return (fromBitmask (fromIntegral ret))
foreign import ccall unsafe "SDL_GetError" sdlGetError :: IO CString
-- | Returns a string containing the last error. Nothing if no error.
getError :: IO (Maybe String)
getError
= do str <- peekCString =<< sdlGetError
if null str
then return Nothing
else return (Just str)
failWithError :: String -> IO a
failWithError msg
= do err <- fmap (fromMaybe "No SDL error") getError
ioError $ userError $ msg ++ "\nSDL message: " ++ err
|
