{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module Types.Graphics.Shader where

import SDL (($=), get)

import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL as GLRaw

import Data.List as L

import Data.StateVar

import qualified Data.ByteString as B

import Data.Maybe (fromJust)

import Control.Concurrent.MVar

import Linear

import Foreign.Marshal.Utils (with)
import Foreign.Marshal.Array (withArray)
import Foreign.Storable
import Foreign.Ptr

-- internal imports

import Classes.Graphics.Bindable

data Shader = Shader
  { shaderId :: GL.Program
  , shaderSources  :: [ShaderSource]
  , shaderUniforms :: MVar [ShaderUniform]
  }

-- make Shader Bindable
instance Bindable Shader where

  bind s = GL.currentProgram $= Just (shaderId s)

  unbind _ = GL.currentProgram $= Nothing

data ShaderSource = ShaderSource
  { shaderSourceType :: GL.ShaderType
  , shaderPath       :: FilePath
  }

data ShaderUniform = ShaderUniform
  { shaderUniformName     :: String
  , shaderUniformLocation :: GL.UniformLocation
  }

-- orphan instance to make linear's M44 uniforms
instance GL.Uniform (M44 GL.GLfloat) where
  uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter
    where
      getter = error "cannot implement: get uniform M44 GLfloat"
        -- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
      setter (V4
        (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)
        (V4 m n o p)) = do
          mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat)
          GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor
  uniformv (GL.UniformLocation ul) count buf = error "can not implement uniformv for M44 GLfloat"
    -- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
    -- where
    --   elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c

-- getUniformWith :: (GL.GLuint -> GL.GLint -> Ptr a -> IO ()) -> GL.UniformLocation -> Ptr a -> IO ()
-- getUniformWith getter (GL.UniformLocation ul) buf = do
--   program <- fmap (GL.programID . fromJust) $ get GL.currentProgram
--   getter program ul buf

isRowMajor :: GL.MatrixOrder -> GL.GLboolean
isRowMajor p = if (GL.RowMajor == p) then 1 else 0

-- create new data object of type Shader
newShader :: [ShaderSource] -> IO Shader
newShader shaderSrc = do
  -- create program Object
  program <- GL.createProgram

  -- create shaders from the source codes given
  compilates <- mapM
    (\(ShaderSource type_ path) -> do
      -- read in shader source from File
      source<- B.readFile path
      
      -- compile the shader
      compiledShader <- compileShaderSource type_ source
      return (type_, compiledShader)
      )
    shaderSrc

  -- attach, link and validate the shader program
  GL.attachedShaders program $= map snd compilates
  GL.linkProgram program
  GL.validateProgram program 

  ok <- get (GL.validateStatus program)
  if ok
  then
    putStrLn "Shaderprogram linked successfully!"
  else do
    info <- get (GL.programInfoLog program)
    putStrLn "Shaderprogram linking failed!\nInfo log says:"
    putStrLn info
    GL.deleteObjectName program

  -- throw away the shaders, since they are linked into the shader program
  mapM_ (\s -> GL.deleteObjectName s) (map snd compilates)

  -- return data object
  Shader program shaderSrc <$> newMVar []

-- pass uniform values into Shader program
setUniformList :: (Storable a, GL.Uniform a) => Shader -> String -> [a] -> IO ()
setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
  -- check if uniform location is already cached
  locs <- readMVar shaderUniforms

  -- retrieve uniform location
  let unilocs = filter
        (\(ShaderUniform name _) -> name == uniname)
        locs

  case unilocs of
    [] -> do
      print ("Unknown uniform: " <> uniname)
      print "Retrieving uniform location from shader program"
      loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
      if locNum < 0
      then
        print ("Uniform does not exist in shader program: " <> uniname)
      else do
        -- set the data
        withArray data_ $ \ptr ->
          GL.uniformv loc (fromIntegral $ length data_) ptr
        --GL.uniform loc $= data_
        -- add uniform to cache
        modifyMVar_ shaderUniforms
          (\list -> return $ ShaderUniform uniname loc : list)
    [ShaderUniform _ loc] ->
        -- set the data
        withArray data_ $ \ptr ->
          GL.uniformv loc (fromIntegral $ length data_) ptr

setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
setUniform (Shader shaderProgram _ shaderUniforms) uniname data_ = do
  -- check if uniform location is already cached
  locs <- readMVar shaderUniforms

  -- retrieve uniform location
  let unilocs = filter
        (\(ShaderUniform name _) -> name == uniname)
        locs

  case unilocs of
    [] -> do
      print ("Unknown uniform: " <> uniname)
      print "Retrieving uniform location from shader program"
      loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
      if locNum < 0
      then
        print ("Uniform does not exist in shader program: " <> uniname)
      else do
        -- set the data
        --withArray data_ $ \ptr ->
        --  GL.uniformv loc (length data_) ptr
        GL.uniform loc $= data_
        -- add uniform to cache
        modifyMVar_ shaderUniforms
          (\list -> return $ ShaderUniform uniname loc : list)
    [ShaderUniform _ loc] ->
        -- set the data
        GL.uniform loc $= data_

-- | compile a shader from source
compileShaderSource
  :: GL.ShaderType -- ^ what type of shader we are compiling
  -> B.ByteString    -- ^ its source code
  -> IO GL.Shader
compileShaderSource type_ source = do
  -- create shader object of specified type
  shaderObject <- GL.createShader type_

  -- assign source code to shader object
  GL.shaderSourceBS shaderObject $= source

  -- actually compile the shader
  GL.compileShader shaderObject

  -- error handling
  ok <- GL.compileStatus shaderObject

  if ok
  then
    putStrLn (show type_ ++ ": compilation successful!")
  else do
    info <- get (GL.shaderInfoLog shaderObject)
    putStrLn (show type_ ++ ": compilation failed!\nInfo log says:")
    putStrLn info
    GL.deleteObjectName shaderObject

  return shaderObject
