improve exceptions

4 files changed, 54 insertions, 15 deletions

diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 40abc6d..1d910a2 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -217,11 +217,11 @@ compileProgram p = do
     --putStr "    + setup shader output mapping: " >> printGLStatus
 
     glLinkProgram po
-    printProgramLog po
+    log <- printProgramLog po
 
     -- check link status
     status <- glGetProgramiv1 GL_LINK_STATUS po
-    when (status /= fromIntegral GL_TRUE) $ fail "link program failed!"
+    when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["link program failed:",log]
 
     -- check program input
     (uniforms,uniformsType) <- queryUniforms po
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index ab8350f..bbc4345 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -262,15 +262,18 @@ fromGLType (t,1)
     | otherwise = error "Failed fromGLType"
 fromGLUniformType _ = error "Failed fromGLType"
 
-printShaderLog :: GLuint -> IO ()
+printShaderLog :: GLuint -> IO String
 printShaderLog o = do
-    i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o
-    when (i > 0) $
+  i <- glGetShaderiv1 GL_INFO_LOG_LENGTH o
+  case (i > 0) of
+    False -> return ""
+    True -> do
       alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
         glGetShaderInfoLog o (fromIntegral i) sizePtr ps
         size <- peek sizePtr
         log <- peekCStringLen (castPtr ps, fromIntegral size)
         putStrLn log
+        return log
 
 glGetShaderiv1 :: GLenum -> GLuint -> IO GLint
 glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi
@@ -278,23 +281,26 @@ glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi
 glGetProgramiv1 :: GLenum -> GLuint -> IO GLint
 glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi
 
-printProgramLog :: GLuint -> IO ()
+printProgramLog :: GLuint -> IO String
 printProgramLog o = do
-    i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o
-    when (i > 0) $
+  i <- glGetProgramiv1 GL_INFO_LOG_LENGTH o
+  case (i > 0) of
+    False -> return ""
+    True -> do
       alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
         glGetProgramInfoLog o (fromIntegral i) sizePtr ps
         size <- peek sizePtr
         log <- peekCStringLen (castPtr ps, fromIntegral size)
         unless (null log) $ putStrLn log
+        return log
 
 compileShader :: GLuint -> [String] -> IO ()
 compileShader o srcl = withMany withCString srcl $! \l -> withArray l $! \p -> do
     glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
     glCompileShader o
-    printShaderLog o
+    log <- printShaderLog o
     status <- glGetShaderiv1 GL_COMPILE_STATUS o
-    when (status /= fromIntegral GL_TRUE) $ fail "compileShader failed!"
+    when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["compileShader failed:",log]
 
 checkGL :: IO String
 checkGL = do
diff --git a/testclient/TestData.hs b/testclient/TestData.hs
index a48dc42..d6d8e38 100644
--- a/testclient/TestData.hs
+++ b/testclient/TestData.hs
@@ -1,5 +1,5 @@
 -- generated file, do not modify!
--- 2016-01-28T13:15:31.27456Z
+-- 2016-02-12T16:05:13.383716000000Z
 
 {-# LANGUAGE OverloadedStrings, RecordWildCards #-}
 module TestData where
@@ -46,13 +46,21 @@ data Scene
 
   deriving (Show, Eq, Ord)
 
+data PipelineInfo
+  = PipelineInfo
+  { pipelineName :: String
+  , pipeline :: Pipeline
+  }
+
+  deriving (Show, Eq, Ord)
+
 data RenderJob
   = RenderJob
   { meshes :: Vector Mesh
   , textures :: Vector String
   , schema :: PipelineSchema
   , scenes :: Vector Scene
-  , pipelines :: Vector Pipeline
+  , pipelines :: Vector PipelineInfo
   }
 
   deriving (Show, Eq, Ord)
@@ -144,6 +152,27 @@ instance FromJSON Scene where
           } 
   parseJSON _ = mzero
 
+instance ToJSON PipelineInfo where
+  toJSON v = case v of
+    PipelineInfo{..} -> object
+      [ "tag" .= ("PipelineInfo" :: Text)
+      , "pipelineName" .= pipelineName
+      , "pipeline" .= pipeline
+      ]
+
+instance FromJSON PipelineInfo where
+  parseJSON (Object obj) = do
+    tag <- obj .: "tag"
+    case tag :: Text of
+      "PipelineInfo" -> do
+        pipelineName <- obj .: "pipelineName"
+        pipeline <- obj .: "pipeline"
+        pure $ PipelineInfo
+          { pipelineName = pipelineName
+          , pipeline = pipeline
+          } 
+  parseJSON _ = mzero
+
 instance ToJSON RenderJob where
   toJSON v = case v of
     RenderJob{..} -> object
diff --git a/testclient/client.hs b/testclient/client.hs
index 236320c..62c197f 100644
--- a/testclient/client.hs
+++ b/testclient/client.hs
@@ -44,7 +44,10 @@ main = do
     GLFW.pollEvents
     threadDelay 100000
 
-setupConnection win = withSocketsDo $ WS.runClient "192.168.0.12" 9160 "/" $ \conn -> do
+setupConnection win = withSocketsDo $ WS.runClient "192.168.0.12" 9160 "/" $ \conn -> catchAll (execConnection win conn) $ \e -> do
+  WS.sendTextData conn . encode $ RenderJobError $ displayException e
+
+execConnection win conn = do
   putStrLn "Connected!"
   -- register backend
   WS.sendTextData conn . encode $ ClientInfo
@@ -75,8 +78,9 @@ processRenderJob win conn renderJob@RenderJob{..} = do
   putStrLn "got render job"
   gpuData@GPUData{..} <- allocateGPUData renderJob
   -- foreach pipeline
-  doAfter (disposeGPUData gpuData) $ forM_ pipelines $ \pipelineDesc -> do
-    renderer <- allocRenderer pipelineDesc
+  doAfter (disposeGPUData gpuData) $ forM_ pipelines $ \PipelineInfo{..} -> do
+    putStrLn $ "use pipeline: " ++ pipelineName
+    renderer <- allocRenderer pipeline
     -- foreach scene
     doAfter (disposeRenderer renderer) $ forM_ scenes $ \Scene{..} -> do
       storage <- allocStorage schema