diff options
Diffstat (limited to 'UtilGL.hs')
-rw-r--r-- | UtilGL.hs | 138 |
1 files changed, 138 insertions, 0 deletions
diff --git a/UtilGL.hs b/UtilGL.hs new file mode 100644 index 0000000..22347c3 --- /dev/null +++ b/UtilGL.hs | |||
@@ -0,0 +1,138 @@ | |||
1 | {-# LANGUAGE QuasiQuotes #-} | ||
2 | module UtilGL where | ||
3 | |||
4 | import Control.Concurrent (threadDelay, yield) | ||
5 | import Control.Monad | ||
6 | import Data.Bool | ||
7 | import Data.ByteString (ByteString) | ||
8 | import Data.Maybe | ||
9 | import Data.IORef | ||
10 | import System.IO | ||
11 | import System.Directory | ||
12 | import System.Process | ||
13 | import System.Exit | ||
14 | import Graphics.Rendering.OpenGL as GL | ||
15 | import Language.Haskell.TH | ||
16 | import Language.Haskell.TH.Quote | ||
17 | import Text.Printf | ||
18 | |||
19 | data Env = Env | ||
20 | { mycolor :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat | ||
21 | } | ||
22 | |||
23 | |||
24 | cbDebugMessage :: GL.DebugMessage -> IO () | ||
25 | cbDebugMessage (DebugMessage src typ mid severity msg) = do | ||
26 | let src' = take 14 $ drop 11 $ show src ++ repeat ' ' | ||
27 | hPutStrLn stderr $ concat [src', ": ", msg] | ||
28 | |||
29 | notify :: String -> IO () | ||
30 | notify msg = do | ||
31 | cb <- get GL.debugMessageCallback | ||
32 | (maybe cbDebugMessage (const GL.debugMessageInsert) cb) | ||
33 | $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification msg | ||
34 | |||
35 | invertedColor4 :: Num a => a -> a -> a -> a -> Color4 a | ||
36 | invertedColor4 r g b a = Color4 (1-r) (1-g) (1-b) a | ||
37 | |||
38 | initGL :: IO Env | ||
39 | initGL = do | ||
40 | GL.debugOutput $=! Enabled | ||
41 | dbref <- newIORef Nothing | ||
42 | let setDebugMessageCallback _ = do | ||
43 | writeIORef dbref $ Just cbDebugMessage | ||
44 | hPutStrLn stderr "Application : Debug log enabled." | ||
45 | GL.debugMessageCallback $=! Just setDebugMessageCallback | ||
46 | GL.debugMessageInsert | ||
47 | $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification | ||
48 | "Debug log test: timeout." | ||
49 | stamp <- fmap (++ "/.config/inverted") getHomeDirectory | ||
50 | mycolor <- bool Color4 invertedColor4 <$> doesFileExist stamp | ||
51 | yield | ||
52 | threadDelay 10000 | ||
53 | dbc <- readIORef dbref | ||
54 | GL.debugMessageCallback $=! dbc | ||
55 | notify "Initialized." | ||
56 | return Env { mycolor = mycolor } | ||
57 | |||
58 | makeShader :: ShaderType -> ByteString -> IO (Maybe Shader) | ||
59 | makeShader typ src = do | ||
60 | shader <- GL.createShader typ | ||
61 | GL.shaderSourceBS shader $= src | ||
62 | GL.compileShader shader | ||
63 | stv <- get (GL.compileStatus shader) | ||
64 | nfo <- get (GL.shaderInfoLog shader) | ||
65 | when (not stv) $ hPutStrLn stderr nfo | ||
66 | return $ guard stv >> Just shader | ||
67 | |||
68 | makeProgram :: Maybe Shader -> Maybe Shader -> IO (Maybe Program) | ||
69 | makeProgram vshader fshader = mkP $ catMaybes [vshader,fshader] | ||
70 | where | ||
71 | mkP [vshader,fshader] = do | ||
72 | prog <- GL.createProgram | ||
73 | GL.attachShader prog vshader | ||
74 | GL.attachShader prog fshader | ||
75 | GL.linkProgram prog | ||
76 | stp <- get (GL.linkStatus prog) | ||
77 | nfo <- get(GL.programInfoLog prog) | ||
78 | when (not stp) $ hPutStrLn stderr nfo | ||
79 | return $ guard stp >> Just prog | ||
80 | mkP _ = return Nothing | ||
81 | |||
82 | |||
83 | |||
84 | unsupported :: Monad m => p -> m a | ||
85 | unsupported _ = fail "not supported." | ||
86 | |||
87 | qw :: QuasiQuoter | ||
88 | qw = QuasiQuoter f unsupported unsupported unsupported | ||
89 | where unsupported _ = fail "not supported." | ||
90 | f x = return $ ListE $ map (LitE . StringL) $ words x | ||
91 | |||
92 | str :: QuasiQuoter | ||
93 | str = QuasiQuoter { | ||
94 | quoteExp = stringE, | ||
95 | quotePat = unsupported, | ||
96 | quoteDec = unsupported, | ||
97 | quoteType = unsupported | ||
98 | } | ||
99 | |||
100 | glslVertex :: QuasiQuoter | ||
101 | glslVertex = QuasiQuoter glslE unsupported unsupported unsupported | ||
102 | where | ||
103 | glslE xs = do | ||
104 | let _packUtf8 = VarE $ mkName "packUtf8" | ||
105 | _string = LitE $ StringL xs | ||
106 | (code,e) <- runIO $ do | ||
107 | (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") "" | ||
108 | if gotvalidator == ExitSuccess | ||
109 | then do | ||
110 | writeFile "/tmp/glsl-shader.vert" xs | ||
111 | (code,out,err) <- readCreateProcessWithExitCode (shell "glslangValidator /tmp/glsl-shader.vert") "" | ||
112 | return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs))) | ||
113 | else | ||
114 | return (ExitSuccess, "") | ||
115 | when (code /= ExitSuccess) $ do | ||
116 | fail e | ||
117 | return $ AppE _packUtf8 _string | ||
118 | |||
119 | glslFragment :: QuasiQuoter | ||
120 | glslFragment = QuasiQuoter glslE unsupported unsupported unsupported | ||
121 | where | ||
122 | glslE xs = do | ||
123 | let _packUtf8 = VarE $ mkName "packUtf8" | ||
124 | _string = LitE $ StringL xs | ||
125 | (code,e) <- runIO $ do | ||
126 | (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") "" | ||
127 | if gotvalidator == ExitSuccess | ||
128 | then do | ||
129 | (pth,h) <-openTempFile "/tmp" "glsl.frag" | ||
130 | hPutStr h xs | ||
131 | hClose h | ||
132 | (code,out,err) <- readCreateProcessWithExitCode (shell $ "glslangValidator "++pth) "" | ||
133 | return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs))) | ||
134 | else | ||
135 | return (ExitSuccess, "") | ||
136 | when (code /= ExitSuccess) $ do | ||
137 | fail e | ||
138 | return $ AppE _packUtf8 _string | ||