{-# LANGUAGE QuasiQuotes #-}
module UtilGL where

import Control.Concurrent (threadDelay, yield)
import Control.Monad
import Data.Bool
import Data.ByteString (ByteString)
import Data.Maybe
import Data.IORef
import System.IO
import System.Directory
import System.Process
import System.Exit
import Graphics.Rendering.OpenGL as GL
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.Printf

data Env = Env
    { mycolor :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
    }


cbDebugMessage :: GL.DebugMessage -> IO ()
cbDebugMessage (DebugMessage src typ mid severity msg) = do
    let src' = take 14 $ drop 11 $ show src ++ repeat ' '
    hPutStrLn stderr $ concat [src', ": ", msg]

notify :: String -> IO ()
notify msg = do
    cb <- get GL.debugMessageCallback
    (maybe cbDebugMessage (const GL.debugMessageInsert) cb)
        $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification msg

invertedColor4 :: Num a => a -> a -> a -> a -> Color4 a
invertedColor4 r g b a = Color4 (1-r) (1-g) (1-b) a

initGL :: IO Env
initGL = do
    GL.debugOutput $=! Enabled
    dbref <- newIORef Nothing
    let setDebugMessageCallback _ = do
            writeIORef dbref $ Just cbDebugMessage
            hPutStrLn stderr "Application   : Debug log enabled."
    GL.debugMessageCallback $=! Just setDebugMessageCallback
    GL.debugMessageInsert
        $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification
                       "Debug log test: timeout."
    stamp <- fmap (++ "/.config/inverted") getHomeDirectory
    mycolor <- bool Color4 invertedColor4 <$> doesFileExist stamp
    yield
    threadDelay 10000
    dbc <- readIORef dbref
    GL.debugMessageCallback $=! dbc
    notify "Initialized."
    return Env { mycolor = mycolor }

makeShader :: ShaderType -> ByteString -> IO (Maybe Shader)
makeShader typ src = do
    shader <- GL.createShader typ
    GL.shaderSourceBS shader $= src
    GL.compileShader shader
    stv <- get (GL.compileStatus shader)
    nfo <- get (GL.shaderInfoLog shader)
    when (not stv) $ hPutStrLn stderr nfo
    return $ guard stv >> Just shader

makeProgram :: Maybe Shader -> Maybe Shader -> IO (Maybe Program)
makeProgram vshader fshader = mkP $ catMaybes [vshader,fshader]
 where
    mkP [vshader,fshader] = do
        prog <- GL.createProgram
        GL.attachShader prog vshader
        GL.attachShader prog fshader
        GL.linkProgram prog
        stp <- get (GL.linkStatus prog)
        nfo <- get(GL.programInfoLog prog)
        when (not stp) $ hPutStrLn stderr nfo
        return $ guard stp >> Just prog
    mkP _ = return Nothing



unsupported :: Monad m => p -> m a
unsupported _ = fail "not supported."

qw :: QuasiQuoter
qw = QuasiQuoter f unsupported unsupported unsupported
 where unsupported _ = fail "not supported."
       f x = return $ ListE $ map (LitE . StringL) $ words x

str :: QuasiQuoter
str  = QuasiQuoter {
        quoteExp = stringE,
        quotePat = unsupported,
        quoteDec = unsupported,
        quoteType = unsupported
       }

glslVertex :: QuasiQuoter
glslVertex = QuasiQuoter glslE unsupported unsupported unsupported
 where
    glslE xs = do
        let _packUtf8 = VarE $ mkName "packUtf8"
            _string   = LitE $ StringL xs
        (code,e) <- runIO $ do
            (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") ""
            if gotvalidator == ExitSuccess
              then do
                writeFile "/tmp/glsl-shader.vert" xs
                (code,out,err) <- readCreateProcessWithExitCode (shell "glslangValidator /tmp/glsl-shader.vert") ""
                return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs)))
              else
                return (ExitSuccess, "")
        when (code /= ExitSuccess) $ do
            fail e
        return $ AppE _packUtf8 _string

glslFragment :: QuasiQuoter
glslFragment = QuasiQuoter glslE unsupported unsupported unsupported
 where
    glslE xs = do
        let _packUtf8 = VarE $ mkName "packUtf8"
            _string   = LitE $ StringL xs
        (code,e) <- runIO $ do
            (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") ""
            if gotvalidator == ExitSuccess
              then do
                (pth,h) <-openTempFile "/tmp" "glsl.frag"
                hPutStr h xs
                hClose h
                (code,out,err) <- readCreateProcessWithExitCode (shell $ "glslangValidator "++pth) ""
                return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs)))
              else
                return (ExitSuccess, "")
        when (code /= ExitSuccess) $ do
            fail e
        return $ AppE _packUtf8 _string