diff --git a/lambdacube-gl.cabal b/lambdacube-gl.cabal --- a/lambdacube-gl.cabal +++ b/lambdacube-gl.cabal @@ -1,5 +1,5 @@ name: lambdacube-gl -version: 0.5.0.1 +version: 0.5.0.3 synopsis: OpenGL 3.3 Core Profile backend for LambdaCube 3D description: OpenGL 3.3 Core Profile backend for LambdaCube 3D homepage: http://lambdacube3d.com diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs --- a/src/LambdaCube/GL/Backend.hs +++ b/src/LambdaCube/GL/Backend.hs @@ -4,6 +4,7 @@ import Control.Applicative import Control.Monad import Control.Monad.State +import Data.Maybe import Data.Bits import Data.IORef import Data.IntMap (IntMap) @@ -264,7 +265,7 @@ , inputUniforms = Map.fromList inUniforms , inputTextures = Map.fromList inTextures , inputTextureUniforms = S.fromList $ texUnis - , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let Just attrName = Map.lookup n lcStreamName] + , inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName] } compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget @@ -393,7 +394,7 @@ buffer <- compileBuffer arrays cmdRef <- newIORef [] let toStream (n,i) = (n,Stream - { streamType = fromJust $ toStreamType =<< Map.lookup n (IR.streamType s) + { streamType = fromMaybe (error $ "missing attribute: " ++ n) $ toStreamType =<< Map.lookup n (IR.streamType s) , streamBuffer = buffer , streamArrIdx = i , streamStart = 0 @@ -436,7 +437,7 @@ uniInputType (GLUniform ty _) = ty -- object attribute stream commands - streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name attrs] + streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs] where attrMap = inputStreams prg attrCmd i s = case s of @@ -603,7 +604,7 @@ return (i,Nothing) -- create input connection let sm = slotMap input - pToI = [i | n <- glSlotNames, let Just i = Map.lookup n sm] + pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "missing object array: " ++ n) $ Map.lookup n sm] iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) writeIORef glInput $ Just $ InputConnection idx input pToI iToP diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs --- a/src/LambdaCube/GL/Input.hs +++ b/src/LambdaCube/GL/Input.hs @@ -5,6 +5,7 @@ import Control.Exception import Control.Monad import Control.Monad.Writer +import Data.Maybe import Data.IORef import Data.Map (Map) import Data.IntMap (IntMap) @@ -78,15 +79,15 @@ addObject input slotName prim indices attribs uniformNames = do let sch = schema input forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of - Nothing -> throw $ userError $ "Unknown uniform: " ++ show n + Nothing -> fail $ "Unknown uniform: " ++ show n _ -> return () case Map.lookup slotName (objectArrays sch) of - Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName + Nothing -> fail $ "Unknown slot: " ++ show slotName Just (ObjectArraySchema sPrim sAttrs) -> do - when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ + when (sPrim /= (primitiveToFetchPrimitive prim)) $ fail $ "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim let sType = fmap streamToStreamType attribs - when (sType /= sAttrs) $ throw $ userError $ unlines $ + when (sType /= sAttrs) $ fail $ unlines $ [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected " , show sAttrs , " but got " @@ -101,7 +102,7 @@ enabled <- newIORef True index <- readIORef seed modifyIORef seed (1+) - (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = Map.lookup n (uniforms sch)] + (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let t = fromMaybe (error $ "missing uniform: " ++ n) $ Map.lookup n (uniforms sch)] cmdsRef <- newIORef (V.singleton V.empty) let obj = Object { objSlot = slotIdx @@ -216,7 +217,7 @@ uniInputType (GLUniform ty _) = ty -- object attribute stream commands - objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name objAttrs] + objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name objAttrs] where attrMap = inputStreams prg objAttrs = objAttributes obj diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs --- a/src/LambdaCube/GL/Mesh.hs +++ b/src/LambdaCube/GL/Mesh.hs @@ -50,7 +50,7 @@ addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do -- select proper attributes - let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input + let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input filterStream n _ = Map.member n slotStreams addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames @@ -82,7 +82,7 @@ updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do -- check type match let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 - ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA] + ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let a2 = fromMaybe (error $ "missing mesh attribute: " ++ n) $ Map.lookup n dMA] if not ok then putStrLn "updateMesh: attribute mismatch!" else do forM_ al $ \(n,a) -> do diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs --- a/src/LambdaCube/GL/Util.hs +++ b/src/LambdaCube/GL/Util.hs @@ -341,7 +341,7 @@ | 0 <= i && i < V.length a && if elem t integralTypes then elem at integralArrTypes else True -> fromStreamType t - | otherwise -> throw $ userError "streamToInputType failed" + | otherwise -> error "streamToInputType failed" where at = arrType $! (a V.! i) integralTypes = [Attribute_Word, Attribute_V2U, Attribute_V3U, Attribute_V4U, Attribute_Int, Attribute_V2I, Attribute_V3I, Attribute_V4I]