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
|
{-# 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
|
