{-# OPTIONS -Wall #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Raylib.Util
(
withWindow,
drawing,
mode2D,
mode3D,
textureMode,
shaderMode,
blendMode,
scissorMode,
vrStereoMode,
raylibApplication,
whileWindowOpen,
whileWindowOpen_,
whileWindowOpen0,
cameraDirectionRay,
setMaterialShader,
inGHCi,
inWeb,
WindowResources,
Freeable (..),
)
where
import Control.Monad (void)
import Control.Monad.Catch (MonadMask, bracket, bracket_)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Raylib.Core (beginBlendMode, beginDrawing, beginMode2D, beginMode3D, beginScissorMode, beginShaderMode, beginTextureMode, beginVrStereoMode, closeWindow, endBlendMode, endDrawing, endMode2D, endMode3D, endScissorMode, endShaderMode, endTextureMode, endVrStereoMode, initWindow, setTargetFPS, windowShouldClose)
import Raylib.Internal (WindowResources)
import Raylib.Internal.Foreign (Freeable (..))
import Raylib.Types
( BlendMode,
Camera2D,
Camera3D (camera3D'position, camera3D'target),
Material (material'shader),
Model (model'materials),
Ray (Ray),
RenderTexture,
Shader,
VrStereoConfig,
)
import Raylib.Util.Math (Vector (vectorNormalize, (|-|)))
#ifdef WEB_FFI
import Foreign (Ptr, castPtrToStablePtr, castStablePtrToPtr, deRefStablePtr, freeStablePtr, newStablePtr)
import Language.Haskell.TH (Body (NormalB), Callconv (CCall), Clause (Clause), Dec (ForeignD, FunD, SigD), DecsQ, Exp (AppE, VarE), Foreign (ExportF), Name, Pat (VarP), Q, Type (AppT, ArrowT, ConT, TupleT), mkName, ppr, reifyType)
import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName))
#else
import Language.Haskell.TH (Name, DecsQ, Type (AppT, ConT, ArrowT, TupleT), Q, reifyType, mkName, ppr, Dec (SigD, FunD), Clause (Clause), Body (NormalB), Exp (VarE, AppE))
import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName))
#endif
withWindow ::
(MonadIO m, MonadMask m) =>
Int ->
Int ->
String ->
Int ->
(WindowResources -> m b) ->
m b
withWindow :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
Int -> Int -> String -> Int -> (WindowResources -> m b) -> m b
withWindow Int
w Int
h String
title Int
fps = m WindowResources
-> (WindowResources -> m ()) -> (WindowResources -> m b) -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO WindowResources -> m WindowResources
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WindowResources -> m WindowResources)
-> IO WindowResources -> m WindowResources
forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> IO WindowResources
initWindow Int
w Int
h String
title IO WindowResources -> IO () -> IO WindowResources
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> IO ()
setTargetFPS Int
fps) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (WindowResources -> IO ()) -> WindowResources -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowResources -> IO ()
closeWindow)
drawing :: (MonadIO m, MonadMask m) => m b -> m b
drawing :: forall (m :: * -> *) b. (MonadIO m, MonadMask m) => m b -> m b
drawing = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
beginDrawing) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endDrawing)
mode2D :: (MonadIO m, MonadMask m) => Camera2D -> m b -> m b
mode2D :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
Camera2D -> m b -> m b
mode2D Camera2D
camera = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Camera2D -> IO ()
beginMode2D Camera2D
camera)) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endMode2D)
mode3D :: (MonadIO m, MonadMask m) => Camera3D -> m b -> m b
mode3D :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
Camera3D -> m b -> m b
mode3D Camera3D
camera = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Camera3D -> IO ()
beginMode3D Camera3D
camera)) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endMode3D)
textureMode :: (MonadIO m, MonadMask m) => RenderTexture -> m b -> m b
textureMode :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
RenderTexture -> m b -> m b
textureMode RenderTexture
rt = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (RenderTexture -> IO ()
beginTextureMode RenderTexture
rt)) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endTextureMode)
shaderMode :: (MonadIO m, MonadMask m) => Shader -> m b -> m b
shaderMode :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
Shader -> m b -> m b
shaderMode Shader
shader = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Shader -> IO ()
beginShaderMode Shader
shader)) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endShaderMode)
blendMode :: (MonadIO m, MonadMask m) => BlendMode -> m b -> m b
blendMode :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
BlendMode -> m b -> m b
blendMode BlendMode
bm = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BlendMode -> IO ()
beginBlendMode BlendMode
bm)) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endBlendMode)
scissorMode :: (MonadIO m, MonadMask m) => Int -> Int -> Int -> Int -> m b -> m b
scissorMode :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
Int -> Int -> Int -> Int -> m b -> m b
scissorMode Int
x Int
y Int
width Int
height = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> Int -> Int -> Int -> IO ()
beginScissorMode Int
x Int
y Int
width Int
height)) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endScissorMode)
vrStereoMode :: (MonadIO m, MonadMask m) => VrStereoConfig -> m b -> m b
vrStereoMode :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
VrStereoConfig -> m b -> m b
vrStereoMode VrStereoConfig
config = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (VrStereoConfig -> IO ()
beginVrStereoMode VrStereoConfig
config)) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
endVrStereoMode)
cameraDirectionRay :: Camera3D -> Ray
cameraDirectionRay :: Camera3D -> Ray
cameraDirectionRay Camera3D
camera = Vector3 -> Vector3 -> Ray
Ray (Camera3D -> Vector3
camera3D'position Camera3D
camera) (Vector3 -> Vector3
forall a. Vector a => a -> a
vectorNormalize (Vector3 -> Vector3) -> Vector3 -> Vector3
forall a b. (a -> b) -> a -> b
$ Camera3D -> Vector3
camera3D'target Camera3D
camera Vector3 -> Vector3 -> Vector3
forall a. Vector a => a -> a -> a
|-| Camera3D -> Vector3
camera3D'position Camera3D
camera)
raylibApplication ::
Name ->
Name ->
Name ->
Name ->
DecsQ
#ifdef WEB_FFI
raylibApplication
startup@(Name (OccName sun) _)
mainLoop@(Name (OccName mln) _)
shouldClose@(Name (OccName scn) _)
teardown@(Name (OccName tdn) _) =
do
assertTypes startup mainLoop shouldClose teardown
let _startupN = mkName ('_' : sun)
_startupT = ConT ''IO `AppT` (ConT ''Ptr `AppT` TupleT 0)
_startupS = SigD _startupN _startupT
_startupF =
FunD
_startupN
[Clause [] (NormalB ((VarE '(>>=) `AppE` VarE startup) `AppE` VarE 'createStablePtr)) []]
let _mainLoopN = mkName ('_' : mln)
_mainLoopPtrN = mkName "ptr"
_mainLoopT = (ArrowT `AppT` (ConT ''Ptr `AppT` TupleT 0)) `AppT` (ConT ''IO `AppT` (ConT ''Ptr `AppT` TupleT 0))
_mainLoopS = SigD _mainLoopN _mainLoopT
_mainLoopF =
FunD
_mainLoopN
[ Clause
[VarP _mainLoopPtrN]
(NormalB ((VarE '(>>=) `AppE` ((VarE '(>>=) `AppE` (VarE 'popStablePtr `AppE` VarE _mainLoopPtrN)) `AppE` VarE mainLoop)) `AppE` VarE 'createStablePtr))
[]
]
let _shouldCloseN = mkName ('_' : scn)
_shouldClosePtrN = mkName "ptr"
_shouldCloseT = (ArrowT `AppT` (ConT ''Ptr `AppT` TupleT 0)) `AppT` (ConT ''IO `AppT` ConT ''Bool)
_shouldCloseS = SigD _shouldCloseN _shouldCloseT
_shouldCloseF =
FunD
_shouldCloseN
[ Clause
[VarP _shouldClosePtrN]
(NormalB ((VarE '(>>=) `AppE` (VarE 'readStablePtr `AppE` VarE _shouldClosePtrN)) `AppE` VarE shouldClose))
[]
]
let _teardownN = mkName ('_' : tdn)
_teardownPtrN = mkName "ptr"
_teardownT = (ArrowT `AppT` (ConT ''Ptr `AppT` TupleT 0)) `AppT` (ConT ''IO `AppT` TupleT 0)
_teardownS = SigD _teardownN _teardownT
_teardownF =
FunD
_teardownN
[ Clause
[VarP _teardownPtrN]
(NormalB ((VarE '(>>=) `AppE` (VarE 'popStablePtr `AppE` VarE _teardownPtrN)) `AppE` VarE teardown))
[]
]
return
[ _startupS,
_startupF,
_mainLoopS,
_mainLoopF,
_shouldCloseS,
_shouldCloseF,
_teardownS,
_teardownF,
ForeignD (ExportF CCall "startup" _startupN _startupT),
ForeignD (ExportF CCall "mainLoop" _mainLoopN _mainLoopT),
ForeignD (ExportF CCall "shouldClose" _shouldCloseN _shouldCloseT),
ForeignD (ExportF CCall "teardown" _teardownN _teardownT)
]
createStablePtr :: a -> IO (Ptr ())
createStablePtr val = castStablePtrToPtr <$> newStablePtr val
readStablePtr :: Ptr () -> IO a
readStablePtr ptr = deRefStablePtr $ castPtrToStablePtr ptr
popStablePtr :: Ptr () -> IO a
popStablePtr ptr = do
let sptr = castPtrToStablePtr ptr
val <- deRefStablePtr sptr
freeStablePtr sptr
return val
#else
raylibApplication :: Name -> Name -> Name -> Name -> DecsQ
raylibApplication Name
startup Name
mainLoop Name
shouldClose Name
teardown = do
Name -> Name -> Name -> Name -> Q ()
assertTypes Name
startup Name
mainLoop Name
shouldClose Name
teardown
[Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
[
Name -> Type -> Dec
SigD Name
main (Name -> Type
ConT ''IO Type -> Type -> Type
`AppT` Int -> Type
TupleT Int
0),
Name -> [Clause] -> Dec
FunD Name
main [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB ((((Name -> Exp
VarE 'runRaylibProgram Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
startup) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
mainLoop) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
shouldClose) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
teardown)) []]
]
where main :: Name
main = String -> Name
mkName String
"main"
runRaylibProgram :: IO a -> (a -> IO a) -> (a -> IO Bool) -> (a -> IO ()) -> IO ()
runRaylibProgram :: forall a.
IO a -> (a -> IO a) -> (a -> IO Bool) -> (a -> IO ()) -> IO ()
runRaylibProgram IO a
startup a -> IO a
mainLoop a -> IO Bool
shouldClose a -> IO ()
teardown = do
a
st <- IO a
startup
a -> IO ()
helper a
st
where helper :: a -> IO ()
helper a
s = a -> IO Bool
shouldClose a
s IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Bool
close -> if Bool
close then a -> IO ()
teardown a
s else a -> IO a
mainLoop a
s IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO ()
helper)
#endif
assertTypes :: Name -> Name -> Name -> Name -> Q ()
assertTypes :: Name -> Name -> Name -> Name -> Q ()
assertTypes Name
startup Name
mainLoop Name
shouldClose Name
teardown = do
Type
sut <- Name -> Q Type
reifyType Name
startup
Type
state <-
case Type
sut of
Type
m `AppT` Type
st ->
if Type
m Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''IO
then Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
st
else Name -> Type -> Type -> Q Type
forall a. Name -> Type -> Type -> a
typeErr Name
startup (Name -> Type
ConT ''IO Type -> Type -> Type
`AppT` Name -> Type
ConT (String -> Name
mkName String
"AppState")) Type
sut
Type
_ -> Name -> Type -> Type -> Q Type
forall a. Name -> Type -> Type -> a
typeErr Name
startup (Name -> Type
ConT ''IO Type -> Type -> Type
`AppT` Name -> Type
ConT (String -> Name
mkName String
"AppState")) Type
sut
Type
mlt <- Name -> Q Type
reifyType Name
mainLoop
Name -> Type -> Type -> Q ()
assertType Name
mainLoop ((Type
ArrowT Type -> Type -> Type
`AppT` Type
state) Type -> Type -> Type
`AppT` (Name -> Type
ConT ''IO Type -> Type -> Type
`AppT` Type
state)) Type
mlt
Type
sct <- Name -> Q Type
reifyType Name
shouldClose
Name -> Type -> Type -> Q ()
assertType Name
shouldClose ((Type
ArrowT Type -> Type -> Type
`AppT` Type
state) Type -> Type -> Type
`AppT` (Name -> Type
ConT ''IO Type -> Type -> Type
`AppT` Name -> Type
ConT ''Bool)) Type
sct
Type
tdt <- Name -> Q Type
reifyType Name
teardown
Name -> Type -> Type -> Q ()
assertType Name
teardown ((Type
ArrowT Type -> Type -> Type
`AppT` Type
state) Type -> Type -> Type
`AppT` (Name -> Type
ConT ''IO Type -> Type -> Type
`AppT` Int -> Type
TupleT Int
0)) Type
tdt
assertType :: Name -> Type -> Type -> Q ()
assertType :: Name -> Type -> Type -> Q ()
assertType Name
n Type
expected Type
actual = if Type
expected Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
actual then () -> Q ()
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return () else Name -> Type -> Type -> Q ()
forall a. Name -> Type -> Type -> a
typeErr Name
n Type
expected Type
actual
typeErr :: Name -> Type -> Type -> a
typeErr :: forall a. Name -> Type -> Type -> a
typeErr (Name (OccName String
n) NameFlavour
_) Type
expected Type
actual =
String -> a
forall a. HasCallStack => String -> a
error (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was not the expected type\n\nexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
expected) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\ngot " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
actual) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
whileWindowOpen ::
(MonadIO m) =>
(a -> m a) ->
a ->
m a
whileWindowOpen :: forall (m :: * -> *) a. MonadIO m => (a -> m a) -> a -> m a
whileWindowOpen a -> m a
f a
state = do
a
newState <- a -> m a
f a
state
Bool
shouldClose <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
windowShouldClose
if Bool
shouldClose
then a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
newState
else (a -> m a) -> a -> m a
forall (m :: * -> *) a. MonadIO m => (a -> m a) -> a -> m a
whileWindowOpen a -> m a
f a
newState
whileWindowOpen_ ::
(MonadIO m) =>
(a -> m a) ->
a ->
m ()
whileWindowOpen_ :: forall (m :: * -> *) a. MonadIO m => (a -> m a) -> a -> m ()
whileWindowOpen_ a -> m a
f a
state = m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((a -> m a) -> a -> m a
forall (m :: * -> *) a. MonadIO m => (a -> m a) -> a -> m a
whileWindowOpen a -> m a
f a
state)
whileWindowOpen0 ::
(MonadIO m) =>
m () ->
m ()
whileWindowOpen0 :: forall (m :: * -> *). MonadIO m => m () -> m ()
whileWindowOpen0 m ()
f = (() -> m ()) -> () -> m ()
forall (m :: * -> *) a. MonadIO m => (a -> m a) -> a -> m a
whileWindowOpen (m () -> () -> m ()
forall a b. a -> b -> a
const m ()
f) ()
setMaterialShader ::
Model ->
Int ->
Shader ->
Model
setMaterialShader :: Model -> Int -> Shader -> Model
setMaterialShader Model
model Int
matIdx Shader
shader = Model
model {model'materials = setIdx mats matIdx newMat}
where
mats :: [Material]
mats = Model -> [Material]
model'materials Model
model
newMat :: Material
newMat = ([Material]
mats [Material] -> Int -> Material
forall a. HasCallStack => [a] -> Int -> a
!! Int
matIdx) {material'shader = shader}
setIdx :: [a] -> Int -> a -> [a]
setIdx [a]
l Int
i a
v = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
i [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
v] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
l
inGHCi :: Bool
#ifdef GHCI
inGHCi = True
#else
inGHCi :: Bool
inGHCi = Bool
False
#endif
inWeb :: Bool
#ifdef WEB_FFI
inWeb = True
#else
inWeb :: Bool
inWeb = Bool
False
#endif