spade-0.1.0.9: src/Interpreter/Lib/SDL.hs

module Interpreter.Lib.SDL where

import qualified Data.Text as T
import Control.Monad.IO.Class
import Control.Monad.Loops
import Control.Monad.State.Strict
import qualified Data.ByteString as BS
import System.Process (createPipe)
import Data.Coerce
import Data.IORef
import Data.Int (Int16, Int32)
import qualified Data.List as DL
import qualified Data.Map as M
import Data.Maybe
import Data.WAVE
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Data.Word
import Foreign.C.Types
import SDL hiding (Keycode, Scancode, get)
import qualified SDL
import SDL.Mixer as SDLM
import qualified SDL.Primitive as SDLP
import qualified SDL.Font as SDLF

import Interpreter.Common
import Interpreter.Interpreter
import qualified Interpreter.Lib.Fonts as Fonts

makeSinWaveChunk :: Double -> BS.ByteString
makeSinWaveChunk freq = BS.pack $
  fmap (\n ->
         let t = fromIntegral n / 22050 :: Double
         in round $ 127 + (127 * sin (2 * pi * freq * t)))
      [0 :: Int32 .. 22050]

createGraphicsWindow :: BuiltInFnWithDoc ['("width", Int), '("height", Int), '("accelerated", Maybe Bool)]
createGraphicsWindow ((coerce -> w) :> (coerce -> h) :>  (coerce -> maccelerated) :>_) =
  initGraphics (Just (w, h)) False (fromMaybe False maccelerated)

createGraphicsFullscrenRes :: BuiltInFnWithDoc ['("width", Int), '("height", Int), '("accelerated", Maybe Bool)]
createGraphicsFullscrenRes ((coerce -> w) :> (coerce -> h) :> (coerce -> maccelerated) :>_) =
  initGraphics (Just (w, h)) True (fromMaybe False maccelerated)

createGraphicsFullscreen :: BuiltInFnWithDoc '[ '("accelerated", Maybe Bool)]
createGraphicsFullscreen ((coerce -> maccelerated) :>_) =
  initGraphics Nothing True (fromMaybe False maccelerated)

initGraphics :: Maybe (Int, Int) -> Bool -> Bool -> InterpretM (Maybe Value)
initGraphics md isfulscren acc = do
  let windowName = "S.P.A.D.E Program"
  (renderer, window) <- liftIO $ do
    SDL.initialize [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer]
    SDLF.initialize
    SDLM.openAudio SDLM.defaultAudio 256
    window <- if isfulscren
      then case md of
        Just (w, h) -> SDL.createWindow windowName (fullscreenConfigRes (fromIntegral w) (fromIntegral h))
        Nothing     -> SDL.createWindow windowName fullscreenConfig
      else case md of
        Just (w, h) -> SDL.createWindow windowName (windowConfig w h)
        Nothing     -> SDL.createWindow windowName (windowConfig 800 600)
    renderer <- case acc of
      True -> SDL.createRenderer window (-1) SDL.defaultRenderer
      _ -> SDL.createRenderer window (-1) $ SDL.defaultRenderer { rendererType = SoftwareRenderer }
    SDL.rendererDrawColor renderer $= V4 255 255 255 255
    pure (renderer, window)
  sdlWindowRefs <- isSDLWindows <$> getInterpretM
  liftIO $ modifyIORef sdlWindowRefs (\l -> (window : l))
  font <- SDLF.decode Fonts.defaultFont 10
  modifyInterpretM (\x -> x
    { isDefaultWindow = Just window
    , isDefaultRenderer = Just renderer
    , isAccelerated = Just acc
    , isDefaultFont = Just font
    })
  pure $ Just $ SDLValue $ Renderer renderer

fullscreenConfig :: SDL.WindowConfig
fullscreenConfig = SDL.defaultWindow
  { windowHighDPI = False
  , windowMode = FullscreenDesktop
  }

fullscreenConfigRes :: CInt -> CInt -> SDL.WindowConfig
fullscreenConfigRes x y = SDL.defaultWindow
  { windowHighDPI = False
  , windowMode = FullscreenDesktop
  , windowInitialSize = V2 x y
  }

windowConfig :: Int -> Int -> SDL.WindowConfig
windowConfig w h = SDL.defaultWindow
  { windowHighDPI = False
  , windowInitialSize = (SDL.V2 (fromIntegral w) (fromIntegral h))
  , windowMode = Windowed
  }

setLogicalSize :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt)]
setLogicalSize ((coerce -> (lx :: CInt)) :> (coerce -> (ly :: CInt)) :> _) =
  isDefaultRenderer <$> getInterpretM >>= \case
    Just renderer  -> do
      SDL.V2 x y <- getWindowSize'
      SDL.rendererScale renderer SDL.$= (SDL.V2 (realToFrac x/realToFrac lx) (realToFrac y/realToFrac ly))
      pure Nothing
    Nothing -> throwErr $ SDLError "Graphics not Initialized"

createTextTexture :: BuiltInFnWithDoc '[ '("content", T.Text)]
createTextTexture ((coerce -> (content :: T.Text)) :> _) = do
  isDefaultRenderer <$> getInterpretM >>= \case
    Just renderer  -> do
      (V4 r g b a) <- SDL.get (SDL.rendererDrawColor renderer)
      (Just . SDLValue . Texture) <$> createTextTexture' (r, g, b, a) content
    Nothing -> throwErr $ SDLError "Graphics not Initialized"

loadFont :: BuiltInFnWithDoc ['("pointSize", SDLF.PointSize), '("filePath", Maybe FilePath)]
loadFont ( (coerce -> pointSize) :> (coerce -> mFilePath) :> _) = do
  fontSrc <- case mFilePath of
    Just filePath -> liftIO $ BS.readFile filePath
    Nothing -> pure $ Fonts.defaultFont
  font <- SDLF.decode fontSrc pointSize
  pure $ Just $ SDLValue $ Font font

setFont :: BuiltInFnWithDoc '[ '("font", Value)]
setFont ((coerce -> fsValue) :> _) = do
  case fsValue of
    SDLValue (Font f) -> modifyInterpretM (\im -> im { isDefaultFont = Just f })
    _ -> throwErr $ SDLError "Font value expected"
  pure Nothing

drawTextAt
  :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt), '("content", T.Text)]
drawTextAt ((coerce -> x) :> (coerce -> y) :> (coerce -> (content :: T.Text)) :> _) = do
  drawTextAt' x y 0 content
  pure Nothing

drawTextAtRotated
  :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt), '("angle", CDouble), '("content", T.Text)]
drawTextAtRotated ((coerce -> x) :> (coerce -> y) :> (coerce -> rotAng) :> (coerce -> (content :: T.Text)) :> _) = do
  drawTextAt' x y rotAng content
  pure Nothing

drawTextAt' :: CInt -> CInt -> CDouble -> T.Text -> InterpretM ()
drawTextAt' x y rotAng content = do
  renderer <- getDefaultRenderer
  (V4 r g b a) <- SDL.get (SDL.rendererDrawColor renderer)
  texture <- createTextTexture' (r, g, b, a) content
  ti <- SDL.queryTexture texture
  SDL.copyEx renderer texture Nothing (Just $ SDL.Rectangle (SDL.P (SDL.V2 x y)) (SDL.V2 (SDL.textureWidth ti) (SDL.textureHeight ti))) rotAng (Just $ mkPoint 0 (SDL.textureHeight ti)) (SDL.V2 False False)
  drawIfNotAccelerated

createTextTexture' :: (Word8, Word8, Word8, Word8) -> T.Text -> InterpretM SDL.Texture
createTextTexture' (r, g, b, a) t = do
  renderer <- getDefaultRenderer
  isDefaultFont <$> getInterpretM >>= \case
    Just font -> do
      texture <- SDLF.solid font (V4 r g b a) t >>= SDL.createTextureFromSurface renderer
      pure texture
    Nothing -> throwErr $ SDLError "Font not set"

loadTexture' :: FilePath -> InterpretM Value
loadTexture' fp = do
  renderer <- getDefaultRenderer
  surface <- SDL.loadBMP fp
  texture <- SDL.createTextureFromSurface renderer surface
  pure $ SDLValue $ Texture texture

textureInfo' :: SDL.Texture -> InterpretM (CInt, CInt)
textureInfo' texture = do
  ti <- SDL.queryTexture texture
  pure (SDL.textureWidth ti, SDL.textureHeight ti)

copyTexture' :: SDL.Texture -> CInt -> CInt -> CInt -> CInt -> InterpretM ()
copyTexture' texture x y w h = do
  renderer <- getDefaultRenderer
  SDL.copy renderer texture Nothing (Just $ SDL.Rectangle (SDL.P (SDL.V2 x y)) (SDL.V2 w h))
  drawIfNotAccelerated

copyTexturePart' :: SDL.Texture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> InterpretM ()
copyTexturePart' texture sx sy sw sh x y w h = do
  renderer <- getDefaultRenderer
  SDL.copy renderer texture
    (Just $ SDL.Rectangle (SDL.P (SDL.V2 sx sy)) (SDL.V2 sw sh))
    (Just $ SDL.Rectangle (SDL.P (SDL.V2 x y)) (SDL.V2 w h))
  drawIfNotAccelerated

copyTextureRotated'
  :: SDL.Texture
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> CDouble
  -> CInt
  -> CInt
  -> Bool
  -> Bool
  -> InterpretM ()
copyTextureRotated' texture sx sy sw sh x y w h rotationDeg rx ry fx fy = do
  renderer <- getDefaultRenderer
  SDL.copyEx renderer texture
    (Just $ SDL.Rectangle (SDL.P (SDL.V2 sx sy)) (SDL.V2 sw sh))
    (Just $ SDL.Rectangle (SDL.P (SDL.V2 x y)) (SDL.V2 w h))
    rotationDeg
    (Just $ mkPoint rx ry)
    (SDL.V2 fx fy)
  drawIfNotAccelerated

loadTexture :: BuiltInFnWithDoc '[ '("bmp_file", FilePath)]
loadTexture ((coerce -> fp) :> EmptyArgs) =
  Just <$> loadTexture' fp

destroyTexture :: BuiltInFnWithDoc '[ '("texture", SDL.Texture)]
destroyTexture ((coerce -> texture) :> EmptyArgs) = do
  SDL.destroyTexture texture
  pure Nothing

textureInfo :: BuiltInFnWithDoc
  '[ '("texture", SDL.Texture)
   ]
textureInfo
  ( (coerce -> texture) :> EmptyArgs) = do
    (w, h) <- textureInfo' texture
    pure $ Just $ ObjectValue $ M.fromList
      [ ("width", NumberValue $ NumberInt $ fromIntegral w)
      , ("height", NumberValue $ NumberInt $ fromIntegral h)
      ]

copyTexture :: BuiltInFnWithDoc
  '[ '("texture", SDL.Texture)
   , '("dst_x", CInt)
   , '("dst_y", CInt)
   , '("dst_w", CInt)
   , '("dst_h", CInt)
   ]
copyTexture
  ( (coerce -> texture)
  :> (coerce -> dx)
  :> (coerce -> dy)
  :> (coerce -> dh)
  :> (coerce -> dw)
  :> EmptyArgs) = do
  copyTexture' texture dx dy dh dw
  pure Nothing

copyTexturePart :: BuiltInFnWithDoc
  '[ '("texture", SDL.Texture)
   , '("src_x", CInt)
   , '("src_y", CInt)
   , '("src_w", CInt)
   , '("src_h", CInt)

   , '("dst_x", CInt)
   , '("dst_y", CInt)
   , '("dst_w", CInt)
   , '("dst_h", CInt)
   ]
copyTexturePart
  ( (coerce -> texture)

  :> (coerce -> sx)
  :> (coerce -> sy)
  :> (coerce -> sh)
  :> (coerce -> sw)

  :> (coerce -> dx)
  :> (coerce -> dy)
  :> (coerce -> dh)
  :> (coerce -> dw)
  :> EmptyArgs) = do
  copyTexturePart' texture sx sy sh sw dx dy dh dw
  pure Nothing

copyTextureRotated :: BuiltInFnWithDoc
  '[ '("texture", SDL.Texture)
   , '("src_x", CInt)
   , '("src_y", CInt)
   , '("src_w", CInt)
   , '("src_h", CInt)

   , '("dst_x", CInt)
   , '("dst_y", CInt)
   , '("dst_w", CInt)
   , '("dst_h", CInt)

   , '("rotation_deg", CDouble)
   , '("rotation_x", CInt)
   , '("rotation_y", CInt)

   , '("flipx", Bool)
   , '("flipy", Bool)
   ]
copyTextureRotated
  ( (coerce -> texture)

  :> (coerce -> sx)
  :> (coerce -> sy)
  :> (coerce -> sh)
  :> (coerce -> sw)

  :> (coerce -> dx)
  :> (coerce -> dy)
  :> (coerce -> dh)
  :> (coerce -> dw)

  :> (coerce -> rDeg)
  :> (coerce -> rx)
  :> (coerce -> ry)

  :> (coerce -> flipx)
  :> (coerce -> flipy)

  :> EmptyArgs) = do
  copyTextureRotated' texture sx sy sh sw dx dy dh dw rDeg rx ry flipx flipy
  pure Nothing

getDefaultWindow :: InterpretM SDL.Window
getDefaultWindow = isDefaultWindow <$> getInterpretM >>= \case
  Just x  -> pure x
  Nothing -> throwErr $ SDLError "Graphics not Initialized"

getDefaultRenderer :: InterpretM SDL.Renderer
getDefaultRenderer = isDefaultRenderer <$> getInterpretM >>= \case
  Just x  -> pure x
  Nothing -> throwErr $ SDLError "Graphics not Initialized"

draw :: BuiltInFnWithDoc '[]
draw _ = do
  draw'
  pure Nothing

draw' :: InterpretM ()
draw' = getDefaultRenderer >>= SDL.present

drawIfNotAccelerated :: InterpretM ()
drawIfNotAccelerated = (isAccelerated <$> getInterpretM) >>= \case
  (Just False) -> draw'
  _            -> pure ()

setDrawColor :: BuiltInFnWithDoc '[ '("red_component", Word8), '("green_component", Word8), '("blue_component", Word8)]
setDrawColor ((coerce -> r) :> (coerce -> g) :> (coerce -> b) :> _) = do
  setDrawColor' r g b 255
  pure Nothing

setBgColor :: BuiltInFnWithDoc '[ '("red_component", Word8), '("green_component", Word8), '("blue_component", Word8)]
setBgColor ((coerce -> r) :> (coerce -> g) :> (coerce -> b) :> _) = do
  setBgColor' r g b 255
  pure Nothing

setDrawColorAlpha :: BuiltInFnWithDoc '[ '("red_component", Word8), '("green_component", Word8), '("blue_component", Word8), '("transparency", Word8)]
setDrawColorAlpha ((coerce -> r) :> (coerce -> g) :> (coerce -> b) :> (coerce -> t) :> _) = do
  setDrawColor' r g b t
  pure Nothing

setDrawColor' :: Word8 -> Word8 -> Word8 -> Word8 -> InterpretM ()
setDrawColor' r g b a = do
  getDefaultRenderer >>= \renderer -> do
    SDL.rendererDrawColor renderer $= V4 r g b a

setBgColor' :: Word8 -> Word8 -> Word8 -> Word8 -> InterpretM ()
setBgColor' r g b a = modifyInterpretM (\im -> im { isBgColor = Just (r, g, b, a) })

clear :: BuiltInFnWithDoc '[]
clear _ =
  getDefaultRenderer >>= \renderer -> do
    isBgColor <$> getInterpretM >>= \case
      Just (r, g, b, a) -> do
        (V4 r' g' b' a') <- SDL.get (SDL.rendererDrawColor renderer)
        SDL.rendererDrawColor renderer $= V4 r g b a
        SDL.clear renderer
        SDL.rendererDrawColor renderer $= V4 r' g' b' a'
        drawIfNotAccelerated
      Nothing -> throwErr $ SDLError "Background color not set"
    pure Nothing

drawPoint :: BuiltInFnWithDoc ['("x", CInt), '("y", CInt)]
drawPoint ((coerce -> x) :> (coerce -> y) :> _) = do
  renderer <- getDefaultRenderer
  SDL.drawPoint renderer (mkPoint x y)
  drawIfNotAccelerated
  pure Nothing

drawPoints :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt))]
drawPoints ((coerce -> v) :> _) = do
  renderer <- getDefaultRenderer
  SDL.drawPoints renderer v
  drawIfNotAccelerated
  pure Nothing

drawLines :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 CInt))]
drawLines ((coerce -> v) :> _) = do
  drawLines' v
  pure Nothing

drawLines' :: VS.Vector (SDL.Point V2 CInt) -> InterpretM ()
drawLines' v = do
  renderer <- getDefaultRenderer
  SDL.drawLines renderer v
  if VS.length v > 0 then do
    let last' = VS.last v
    SDL.drawPoint renderer last'
    SDL.drawPoint renderer last'
  else pure ()
  drawIfNotAccelerated

v2ToTuple :: Point V2 a -> (a, a)
v2ToTuple (P (V2 a b)) = (a, b)

v2Fst :: Point V2 a -> a
v2Fst (P (V2 a _)) = a

v2Snd :: Point V2 a -> a
v2Snd (P (V2 _ a)) = a

drawPoly :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 Int16)), '("fill", Maybe Bool)]
drawPoly ((coerce -> v) :> (coerce -> f) :> EmptyArgs) = do
  drawPoly' v False f
  pure Nothing

drawPolySmooth :: BuiltInFnWithDoc '[ '("points", VS.Vector (SDL.Point V2 Int16))]
drawPolySmooth ((coerce -> v) :> EmptyArgs) = do
  drawPoly' v True Nothing
  pure Nothing

drawPoly' :: VS.Vector (SDL.Point V2 Int16) -> Bool -> Maybe Bool -> InterpretM ()
drawPoly' v smth f = do
  renderer <- getDefaultRenderer
  dcl <- SDL.get (SDL.rendererDrawColor renderer)
  if (fromMaybe False f)
    then SDLP.fillPolygon renderer (toSingle (\(P (V2 a _)) -> a) v) (toSingle (\(P (V2 _ b)) -> b) v) dcl
    else if smth
      then SDLP.smoothPolygon renderer (toSingle (\(P (V2 a _)) -> a) v) (toSingle (\(P (V2 _ b)) -> b) v) dcl
      else SDLP.polygon renderer (toSingle (\(P (V2 a _)) -> a) v) (toSingle (\(P (V2 _ b)) -> b) v) dcl
  drawIfNotAccelerated
  where
    toSingle :: (SDL.Point V2 Int16 -> Int16) ->  VS.Vector (SDL.Point V2 Int16) -> VS.Vector Int16
    toSingle fn vec = VS.map fn vec

drawLine :: BuiltInFnWithDoc ['("start_x", CInt), '("start_y", CInt), '("end_x", CInt), '("end_y", CInt)]
drawLine ((coerce -> x) :> (coerce -> y) :> (coerce -> xEnd) :> (coerce -> yEnd) :>_) = do
  renderer <- getDefaultRenderer
  let endpoint = mkPoint xEnd yEnd
  SDL.drawLine renderer (mkPoint x y) endpoint
  SDL.drawPoint renderer endpoint
  SDL.drawPoint renderer endpoint
    -- Due to some bug in SDL, without these extra call
    -- the next draw item appear to have a stray pixel with the same color
    -- that was used to draw this one.
  drawIfNotAccelerated
  pure Nothing

drawBox :: BuiltInFnWithDoc ['("start_x", CInt), '("start_y", CInt), '("width", CInt), '("height", CInt), '("fill", Maybe Bool)]
drawBox ((coerce -> x) :> (coerce -> y) :> (coerce -> width) :> (coerce -> height) :> (coerce -> fill) :> _) = do
  renderer <- getDefaultRenderer
  let
    f = case fill of
      Just b -> b
      Nothing -> False
  if f
    then SDL.fillRect renderer $ Just $ SDL.Rectangle (mkPoint x y) (SDL.V2 width height)
    else SDL.drawRect renderer $ Just $ SDL.Rectangle (mkPoint x y) (SDL.V2 width height)
  drawIfNotAccelerated
  pure Nothing

drawArc :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radius", CInt), '("angle_start", CInt),  '("angle_end", CInt)]
drawArc ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> (coerce -> angles) :> (coerce -> anglee) :> _) = do
  renderer <- getDefaultRenderer
  dcl <- SDL.get (SDL.rendererDrawColor renderer)
  SDLP.arc renderer (SDL.V2 x y) radius angles anglee dcl
  drawIfNotAccelerated
  pure Nothing

drawPie :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radius", CInt), '("angle_start", CInt), '("angle_end", CInt), '("fill", Maybe Bool)]
drawPie ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> (coerce -> angles) :> (coerce -> anglee) :> (coerce -> (f :: Maybe Bool)) :> _)  = do
  renderer <- getDefaultRenderer
  dcl <- SDL.get (SDL.rendererDrawColor renderer)
  case f of
    Just True -> SDLP.fillPie renderer (SDL.V2 x y) radius angles anglee dcl
    _ -> SDLP.pie renderer (SDL.V2 x y) radius angles anglee dcl
  drawIfNotAccelerated
  pure Nothing

drawCircle :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radius", CInt), '("fill", Maybe Bool)]
drawCircle ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> (coerce -> (f :: Maybe Bool)) :> _) = do
  renderer <- getDefaultRenderer
  dcl <- SDL.get (SDL.rendererDrawColor renderer)
  case f of
    Just True -> SDLP.fillCircle renderer (SDL.V2 x y) radius dcl
    _ -> SDLP.circle renderer (SDL.V2 x y) radius dcl
  drawIfNotAccelerated
  pure Nothing

drawEllipse :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radiusx", CInt), '("radiusy", CInt), '("fill", Maybe Bool)]
drawEllipse ((coerce -> x) :> (coerce -> y) :> (coerce -> radiusx) :> (coerce -> radiusy) :> (coerce -> (f :: Maybe Bool)) :> _) = do
  renderer <- getDefaultRenderer
  dcl <- SDL.get (SDL.rendererDrawColor renderer)
  case f of
    Just True -> SDLP.fillEllipse renderer (SDL.V2 x y) radiusx radiusy dcl
    _ -> SDLP.ellipse renderer (SDL.V2 x y) radiusx radiusy dcl
  drawIfNotAccelerated
  pure Nothing

drawSmoothEllipse :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radiusx", CInt), '("radiusy", CInt)]
drawSmoothEllipse ((coerce -> x) :> (coerce -> y) :> (coerce -> radiusx) :> (coerce -> radiusy) :> _) = do
  renderer <- getDefaultRenderer
  dcl <- SDL.get (SDL.rendererDrawColor renderer)
  SDLP.smoothEllipse renderer (SDL.V2 x y) radiusx radiusy dcl
  drawIfNotAccelerated
  pure Nothing

drawSmoothCircle :: BuiltInFnWithDoc ['("center_x", CInt), '("center_y", CInt), '("radius", CInt)]
drawSmoothCircle ((coerce -> x) :> (coerce -> y) :> (coerce -> radius) :> _) = do
  renderer <- getDefaultRenderer
  dcl <- SDL.get (SDL.rendererDrawColor renderer)
  SDLP.smoothCircle renderer (SDL.V2 x y) radius dcl
  drawIfNotAccelerated
  pure Nothing

waitForSDLKey :: BuiltInFnWithDoc '[]
waitForSDLKey _ = do
  mv <- iterateWhile isNothing $ do
    events <- (filter filterEvent) <$> pollEvents
    case events of
      [] -> pure Nothing
      (h:_) -> pure $ convertEvent h
  pure mv
  where
    convertEvent :: Event -> Maybe Value
    convertEvent event =
      case eventPayload event of
        KeyboardEvent keyboardEvent ->
           Just $ SDLValue $ Keycode ((keysymKeycode (keyboardEventKeysym keyboardEvent)))
        _ -> Nothing

    filterEvent :: Event -> Bool
    filterEvent event =
      case eventPayload event of
        KeyboardEvent keyboardEvent ->
          (keyboardEventKeyMotion keyboardEvent == Pressed)
        _ -> False

getWindowSize' :: InterpretM (SDL.V2 CInt)
getWindowSize' = do
  window <- getDefaultWindow
  liftIO $ SDL.get (windowSize window)

getWindowSize :: BuiltInFnWithDoc '[]
getWindowSize _ = do
  (SDL.V2 x y) <- getWindowSize'
  pure $ Just $ ObjectValue $ M.fromList [("width", NumberValue $ NumberInt $ fromIntegral x), ("height", NumberValue $ NumberInt $ fromIntegral y)]

getKeyboardState :: BuiltInFnWithDoc '[]
getKeyboardState _ = do
  SDL.pumpEvents
  fn <- SDL.getKeyboardState
  pure $ Just $ SDLValue $ KeyboardState $ SDLKeyboardStateCallback fn

wasKeyDownIn :: BuiltInFnWithDoc '[ '("keyboard_state", SDLKeyboardStateCallback), '("key", SDL.Scancode) ]
wasKeyDownIn ((coerce -> (SDLKeyboardStateCallback cb)) :> (coerce -> scancode ) :> _) =
  pure $ Just $ BoolValue $ cb scancode

getKeys :: BuiltInFnWithDoc '[]
getKeys _ = do
  events <- pollEvents
  pure $ Just $ ArrayValue $ DL.foldl' convertEvent V.empty events
  where
    convertEvent :: V.Vector Value -> Event -> V.Vector Value
    convertEvent inp event =
      case eventPayload event of
        KeyboardEvent keyboardEvent ->
            V.cons (SDLValue $ Keycode ((keysymKeycode (keyboardEventKeysym keyboardEvent)))) inp
        _ -> inp

builtInSetSampleVolume :: BuiltInFnWithDoc '[ '("channel", Channel), '("volume", Int)]
builtInSetSampleVolume ((coerce -> (channel :: Channel)) :> (coerce -> volume) :> _) = do
  SDLM.setVolume volume channel
  pure Nothing

builtInSetSampleLRVolume :: BuiltInFnWithDoc '[ '("sample", Channel), '("volume_left", Int), '("volume_right", Int)]
builtInSetSampleLRVolume ((coerce -> (channel :: Channel)) :> (coerce -> volumel) :> (coerce -> volumer) :> _) = do
  void $ SDLM.effectPan channel volumel volumer
  pure Nothing

builtInPlaySoundSample :: BuiltInFnWithDoc '[ '("sample", Sample), '("channel", Int)]
builtInPlaySoundSample ((coerce -> sample) :> (coerce -> (channel :: Int)) :> _) = do
  void $ SDLM.playOn (fromIntegral channel) SDLM.Forever sample
  pure Nothing

makeSound :: (Int, [WAVESample]) -> InterpretM Value
makeSound (sampleCount, samplesRaw) = do
  (rEnd, wEnd) <- liftIO createPipe
  let waveData = WAVE (WAVEHeader 1 44100 16 $ Just sampleCount) [samplesRaw]
  waveEncodedData <- liftIO $ do
    hPutWAVE wEnd waveData
    BS.hGetContents rEnd
  chunk <- liftIO $ SDLM.decode waveEncodedData
  pure $ SDLValue $ SoundSample chunk

builtInMakeTone :: BuiltInFnWithDoc '[ '("freq", Double) ]
builtInMakeTone ((coerce -> freq) :> _) = do
  let samplesInOneCycle = 44100 / freq
  let multiplier = (2 * pi)/samplesInOneCycle
  let samplesRaw = [doubleToSample $ sin (realToFrac x * multiplier) | x <- [0 .. (round samplesInOneCycle - 1)]]
  Just <$> makeSound (round samplesInOneCycle, samplesRaw)

builtInMakeSoundSample :: BuiltInFnWithDoc '[ '("samplecount", Int), '("callback", Callback)]
builtInMakeSoundSample ((coerce -> sampleCount) :> (coerce -> (cb :: Callback)) :> _) = do
  samplesRaw <- getSamples sampleCount
  Just <$> makeSound (sampleCount , samplesRaw)
  where
    getSamples :: Int -> InterpretM [WAVESample]
    getSamples sc = mapM (\x -> mapFn x) [1..(fromIntegral sc)]

    mapFn :: Integer -> InterpretM WAVESample
    mapFn si = (doubleToSample . (fromValue @Double) . fromMaybe (throwErr MissingProcedureReturn)) <$>
      evaluateCallback cb [NumberValue $ NumberInt si]

builtInMakeSoundSampleFromFile :: BuiltInFnWithDoc '[ '("filepath", FilePath)]
builtInMakeSoundSampleFromFile ((coerce -> filePath) :> _) = do
  chunk <- liftIO $ SDLM.load filePath
  pure $ Just $ SDLValue $ SoundSample chunk

cleanupSDL :: InterpretM ()
cleanupSDL = do
  sdlWindowRefs <- isSDLWindows <$> getInterpretM
  windows <- liftIO $ readIORef sdlWindowRefs
  mapM_ (liftIO . SDL.destroyWindow) windows
  modifyInterpretM (\x -> x { isDefaultRenderer = Nothing })
  modifyInterpretM (\x -> x { isDefaultWindow = Nothing })
  SDLM.closeAudio
  SDL.quit

keycodes :: Value
keycodes = ObjectValue $ M.fromList
  [ ("up", SDLValue $ Keycode KeycodeUp)
  , ("down", SDLValue $ Keycode KeycodeDown)
  , ("left", SDLValue $ Keycode KeycodeLeft)
  , ("right", SDLValue $ Keycode KeycodeRight)
  , ("a", SDLValue $ Keycode KeycodeA)
  , ("b", SDLValue $ Keycode KeycodeB)
  , ("c", SDLValue $ Keycode KeycodeC)
  , ("d", SDLValue $ Keycode KeycodeD)
  , ("e", SDLValue $ Keycode KeycodeE)
  , ("f", SDLValue $ Keycode KeycodeF)
  , ("g", SDLValue $ Keycode KeycodeG)
  , ("h", SDLValue $ Keycode KeycodeH)
  , ("i", SDLValue $ Keycode KeycodeI)
  , ("j", SDLValue $ Keycode KeycodeJ)
  , ("k", SDLValue $ Keycode KeycodeK)
  , ("l", SDLValue $ Keycode KeycodeL)
  , ("m", SDLValue $ Keycode KeycodeM)
  , ("n", SDLValue $ Keycode KeycodeN)
  , ("o", SDLValue $ Keycode KeycodeO)
  , ("p", SDLValue $ Keycode KeycodeP)
  , ("q", SDLValue $ Keycode KeycodeQ)
  , ("r", SDLValue $ Keycode KeycodeR)
  , ("s", SDLValue $ Keycode KeycodeS)
  , ("t", SDLValue $ Keycode KeycodeT)
  , ("u", SDLValue $ Keycode KeycodeU)
  , ("v", SDLValue $ Keycode KeycodeV)
  , ("w", SDLValue $ Keycode KeycodeW)
  , ("x", SDLValue $ Keycode KeycodeX)
  , ("y", SDLValue $ Keycode KeycodeY)
  , ("z", SDLValue $ Keycode KeycodeZ)
  , ("return", SDLValue $ Keycode KeycodeReturn)
  , ("escape", SDLValue $ Keycode KeycodeEscape)
  ]

scancodes :: Value
scancodes = ObjectValue $ M.fromList
  [ ("up", SDLValue $ Scancode ScancodeUp)
  , ("down", SDLValue $ Scancode ScancodeDown)
  , ("left", SDLValue $ Scancode ScancodeLeft)
  , ("right", SDLValue $ Scancode ScancodeRight)
  , ("a", SDLValue $ Scancode ScancodeA)
  , ("b", SDLValue $ Scancode ScancodeB)
  , ("c", SDLValue $ Scancode ScancodeC)
  , ("d", SDLValue $ Scancode ScancodeD)
  , ("e", SDLValue $ Scancode ScancodeE)
  , ("f", SDLValue $ Scancode ScancodeF)
  , ("g", SDLValue $ Scancode ScancodeG)
  , ("h", SDLValue $ Scancode ScancodeH)
  , ("i", SDLValue $ Scancode ScancodeI)
  , ("j", SDLValue $ Scancode ScancodeJ)
  , ("k", SDLValue $ Scancode ScancodeK)
  , ("l", SDLValue $ Scancode ScancodeL)
  , ("m", SDLValue $ Scancode ScancodeM)
  , ("n", SDLValue $ Scancode ScancodeN)
  , ("o", SDLValue $ Scancode ScancodeO)
  , ("p", SDLValue $ Scancode ScancodeP)
  , ("q", SDLValue $ Scancode ScancodeQ)
  , ("r", SDLValue $ Scancode ScancodeR)
  , ("s", SDLValue $ Scancode ScancodeS)
  , ("t", SDLValue $ Scancode ScancodeT)
  , ("u", SDLValue $ Scancode ScancodeU)
  , ("v", SDLValue $ Scancode ScancodeV)
  , ("w", SDLValue $ Scancode ScancodeW)
  , ("x", SDLValue $ Scancode ScancodeX)
  , ("y", SDLValue $ Scancode ScancodeY)
  , ("z", SDLValue $ Scancode ScancodeZ)
  ]