shaderc (empty) → 0.1.0.5
raw patch · 21 files changed
+776/−0 lines, 21 filesdep +basedep +bytestringdep +c-enumsetup-changed
Dependencies added: base, bytestring, c-enum, c-struct, data-default, exception-hierarchy, language-spir-v, mtl, nowdoc, shaderc, storable-peek-poke, template-haskell
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- data/ShaderKind.txt +44/−0
- shaderc.cabal +87/−0
- src/Language/SpirV/Shaderc.hs +42/−0
- src/Language/SpirV/Shaderc/CompileOptions.hs +5/−0
- src/Language/SpirV/Shaderc/CompileOptions/Internal.hs +88/−0
- src/Language/SpirV/Shaderc/Exception.hs +5/−0
- src/Language/SpirV/Shaderc/Exception/Enum.hsc +32/−0
- src/Language/SpirV/Shaderc/Exception/Internal.hs +26/−0
- src/Language/SpirV/Shaderc/TH.hs +73/−0
- src/Shaderc/CompilationResult/Core.hsc +34/−0
- src/Shaderc/CompileOptions/Core.hsc +45/−0
- src/Shaderc/Core.hsc +62/−0
- src/Shaderc/Enum.hsc +56/−0
- src/Shaderc/Include.hs +60/−0
- src/Shaderc/Include/Core.hsc +52/−0
- src/Shaderc/Middle.hs +27/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for try-shaderc++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Yoshikuni Jujo nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# try-shaderc
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data/ShaderKind.txt view
@@ -0,0 +1,44 @@+VertexShader+FragmentShader+ComputeShader+GeometryShader+TessControlShader+TessEvaluationShader+GlslVertexShader+GlslFragmentShader+GlslComputeShader+GlslGeometryShader+GlslTessControlShader+GlslTessEvaluationShader+GlslInferFromSource+GlslDefaultVertexShader+GlslDefaultFragmentShader+GlslDefaultComputeShader+GlslDefaultGeometryShader+GlslDefaultTessControlShader+GlslDefaultTessEvaluationShader+SpirvAssembly+RaygenShader+AnyhitShader+ClosesthitShader+MissShader+IntersectionShader+CallableShader+GlslRaygenShader+GlslAnyhitShader+GlslClosesthitShader+GlslMissShader+GlslIntersectionShader+GlslCallableShader+GlslDefaultRaygenShader+GlslDefaultAnyhitShader+GlslDefaultClosesthitShader+GlslDefaultMissShader+GlslDefaultIntersectionShader+GlslDefaultCallableShader+TaskShader+MeshShader+GlslTaskShader+GlslMeshShader+GlslDefaultTaskShader+GlslDefaultMeshShader
+ shaderc.cabal view
@@ -0,0 +1,87 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name: shaderc+version: 0.1.0.5+synopsis: A collection of tools and libraries for Vulkan shader compilation+description: Please see the README on GitHub at <https://github.com/YoshikuniJujo/shaderc#readme>+category: Language+homepage: https://github.com/YoshikuniJujo/shaderc#readme+bug-reports: https://github.com/YoshikuniJujo/shaderc/issues+author: Yoshikuni Jujo+maintainer: yoshikuni.jujo@gmail.com+copyright: 2022 Yoshikuni Jujo+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md+data-files:+ data/ShaderKind.txt++source-repository head+ type: git+ location: https://github.com/YoshikuniJujo/shaderc++library+ exposed-modules:+ Language.SpirV.Shaderc+ Language.SpirV.Shaderc.TH+ Language.SpirV.Shaderc.Exception+ Language.SpirV.Shaderc.Exception.Enum+ Language.SpirV.Shaderc.CompileOptions+ other-modules:+ Language.SpirV.Shaderc.CompileOptions.Internal+ Language.SpirV.Shaderc.Exception.Internal+ Shaderc.CompilationResult.Core+ Shaderc.CompileOptions.Core+ Shaderc.Core+ Shaderc.Enum+ Shaderc.Include+ Shaderc.Include.Core+ Shaderc.Middle+ Paths_shaderc+ hs-source-dirs:+ src+ pkgconfig-depends:+ shaderc+ build-depends:+ base >=4.7 && <5+ , bytestring <1+ , c-enum <1+ , c-struct <1+ , data-default <1+ , exception-hierarchy <1+ , language-spir-v <1+ , mtl <3+ , nowdoc <1+ , storable-peek-poke <1+ , template-haskell <3+ default-language: Haskell2010++test-suite shaderc-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_shaderc+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , bytestring <1+ , c-enum <1+ , c-struct <1+ , data-default <1+ , exception-hierarchy <1+ , language-spir-v <1+ , mtl <3+ , nowdoc <1+ , shaderc+ , storable-peek-poke <1+ , template-haskell <3+ default-language: Haskell2010
+ src/Language/SpirV/Shaderc.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}+{-# LANGUAGE DataKinds, KindSignatures #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Language.SpirV.Shaderc (+ compile, SourceText, InputFileName, EntryPointName ) where++import Foreign.Storable+import Control.Monad.Trans+import Control.Monad.Cont++import qualified Data.ByteString as BS++import Language.SpirV.Internal+import Language.SpirV.ShaderKind+import Language.SpirV.Shaderc.Exception.Internal++import qualified Shaderc.Core as C+import qualified Shaderc.Middle as M+import qualified Language.SpirV.Shaderc.CompileOptions as CompileOptions+import qualified Shaderc.CompilationResult.Core as CompilationResult++compile :: forall ud sknd . (Storable ud, IsShaderKind sknd) =>+ SourceText -> InputFileName -> EntryPointName ->+ CompileOptions.C ud -> IO (S sknd)+compile src ifnm epnm opts = ($ pure) $ runContT do+ cmp <- lift C.compilerInitialize+ rslt <- M.compileIntoSpv cmp src (shaderKind @sknd) ifnm epnm opts+ lift $ throwUnlessSuccess rslt+ lift do cspv <- CompilationResult.getBytes rslt+ (fromIntegral -> cspvln) <- CompilationResult.getLength rslt+ spv <- BS.packCStringLen (cspv, cspvln)+ CompilationResult.release rslt+ C.compilerRelease cmp+ pure $ S spv++type SourceText = BS.ByteString+type InputFileName = BS.ByteString+type EntryPointName = BS.ByteString
+ src/Language/SpirV/Shaderc/CompileOptions.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Language.SpirV.Shaderc.CompileOptions (C(..)) where++import Language.SpirV.Shaderc.CompileOptions.Internal
+ src/Language/SpirV/Shaderc/CompileOptions/Internal.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Language.SpirV.Shaderc.CompileOptions.Internal where++import Foreign.Ptr+import Foreign.Storable+import Foreign.Storable.PeekPoke+import Control.Monad.Trans+import Control.Monad.Cont+import Data.Default+import Data.Bool++import qualified Data.ByteString as BS++import Shaderc.Enum+import Shaderc.Include++import qualified Shaderc.CompileOptions.Core as C++data C ud = C {+ cMacroDefinitions :: [(BS.ByteString, BS.ByteString)],+ cSourceLanguage :: Maybe SourceLanguage,+ cGenerateDebugInfo :: Bool,+ cOptimizationLevel :: Maybe OptimizationLevel,+ cForcedVersionProfile :: Maybe (Version, Profile),+ cIncludeCallbacks :: Maybe (ResolveFn ud, Maybe ud) }++tToCore :: Storable ud => C ud -> ContT r IO C.C+tToCore C {+ cMacroDefinitions = mds,+ cSourceLanguage = lng,+ cGenerateDebugInfo = dbg,+ cOptimizationLevel = optLvl,+ cForcedVersionProfile = fvp,+ cIncludeCallbacks = mcb+ } = do+ ct <- lift C.initialize+ addMacroDefinitions ct mds+ setSourceLanguage ct lng+ setGenerateDebugInfo ct dbg+ setOptimizationLevel ct optLvl+ setForcedVersionProfile ct fvp+ maybe (pure ()) (uncurry $ setIncludeCallbacks ct) mcb+ ContT \f -> f ct <* C.release ct++addMacroDefinitions :: C.C -> [(BS.ByteString, BS.ByteString)] -> ContT r IO ()+addMacroDefinitions opts = mapM_ . uncurry $ addMacroDefinition opts++addMacroDefinition :: C.C -> BS.ByteString -> BS.ByteString -> ContT r IO ()+addMacroDefinition opts nm vl = do+ (cnm, fromIntegral -> cnmln) <- ContT $ BS.useAsCStringLen nm+ (cvl, fromIntegral -> cvlln) <- ContT $ BS.useAsCStringLen vl+ lift $ C.addMacroDefinition opts cnm cnmln cvl cvlln++setSourceLanguage :: C.C -> Maybe SourceLanguage -> ContT r IO ()+setSourceLanguage opts = maybe (pure ()) $ lift . C.setSourceLanguage opts++setGenerateDebugInfo :: C.C -> Bool -> ContT r IO ()+setGenerateDebugInfo opts = lift . bool (pure ()) (C.setGenerateDebugInfo opts)++setOptimizationLevel :: C.C -> Maybe OptimizationLevel -> ContT r IO ()+setOptimizationLevel opts = maybe (pure ()) $ lift . C.setOptimizationLevel opts++setForcedVersionProfile :: C.C -> Maybe (Version, Profile) -> ContT r IO ()+setForcedVersionProfile opts =+ maybe (pure ()) $ lift . uncurry (C.setForcedVersionProfile opts)++setIncludeCallbacks :: (Storable ud, Pokable ud) =>+ C.C -> ResolveFn ud -> Maybe ud -> ContT r IO ()+setIncludeCallbacks opts rfun mud = do+ let (crfn, crrfn) = resolveFnToCore rfun+ (castPtr -> pud) <- ContT $ withPokedMaybe mud+ lift $ C.setIncludeCallbacks opts crfn crrfn pud++instance Default (C ()) where def = defaultCompileOptions++defaultCompileOptions :: C ()+defaultCompileOptions = C {+ cMacroDefinitions = [],+ cSourceLanguage = Nothing,+ cGenerateDebugInfo = False,+ cOptimizationLevel = Nothing,+ cForcedVersionProfile = Nothing,+ cIncludeCallbacks = Nothing }
+ src/Language/SpirV/Shaderc/Exception.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Language.SpirV.Shaderc.Exception (E(..)) where++import Language.SpirV.Shaderc.Exception.Internal
+ src/Language/SpirV/Shaderc/Exception/Enum.hsc view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Language.SpirV.Shaderc.Exception.Enum where++import Foreign.Storable+import Foreign.C.Enum+import Data.Word++#include <shaderc/shaderc.h>++enum "CompilationStatus" ''#{type shaderc_compilation_status}+ [''Show, ''Storable] [+ ("CompilationStatusSuccess",+ #{const shaderc_compilation_status_success}),+ ("CompilationStatusInvalidStage",+ #{const shaderc_compilation_status_invalid_stage}),+ ("CompilationStatusError",+ #{const shaderc_compilation_status_compilation_error}),+ ("CompilationStatusInternalError",+ #{const shaderc_compilation_status_internal_error}),+ ("CompilationStatusNullResultObject",+ #{const shaderc_compilation_status_null_result_object}),+ ("CompilationStatusInvalidAssembly",+ #{const shaderc_compilation_status_invalid_assembly}),+ ("CompilationStatusValidationError",+ #{const shaderc_compilation_status_validation_error}),+ ("CompilationStatusTransformationError",+ #{const shaderc_compilation_status_transformation_error}),+ ("CompilationStatusConfigurationError",+ #{const shaderc_compilation_status_configuration_error}) ]
+ src/Language/SpirV/Shaderc/Exception/Internal.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Language.SpirV.Shaderc.Exception.Internal where++import Control.Exception+import Control.Exception.Hierarchy++import qualified Data.ByteString as BS++import Language.SpirV.Shaderc.Exception.Enum++import qualified Shaderc.CompilationResult.Core as CompilationResult++data E = E CompilationStatus BS.ByteString deriving Show++exceptionHierarchy Nothing (ExType ''E)++throwUnlessSuccess :: CompilationResult.T -> IO ()+throwUnlessSuccess rslt = do+ stt <- CompilationResult.getCompilationStatus rslt+ case stt of+ CompilationStatusSuccess -> pure ()+ _ -> do cmsg <- CompilationResult.getErrorMessage rslt+ msg <- BS.packCString cmsg+ throw $ E stt msg
+ src/Language/SpirV/Shaderc/TH.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Language.SpirV.Shaderc.TH (+ glslVertexShader, glslFragmentShader, glslComputeShader ) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Data.Default+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Language.SpirV.Internal+import Language.SpirV.ShaderKind+import Language.SpirV.Shaderc+import Language.SpirV.Shaderc.CompileOptions qualified as CompileOptions++-- GLSL VERTEX SHADER++glslVertexShader :: QuasiQuoter+glslVertexShader = generalShader @'GlslVertexShader+ "glslVertexShaderMain" 'GlslVertexShader "glslVertexShader"++-- GLSL FRAGMENT SHADER++glslFragmentShader :: QuasiQuoter+glslFragmentShader = generalShader @'GlslFragmentShader+ "glslFragmentShaderMain" 'GlslFragmentShader "glslFragmentShader"++-- GLSL COMPUTE SHADER++glslComputeShader :: QuasiQuoter+glslComputeShader = generalShader @'GlslComputeShader+ "glslComputeShaderMain" 'GlslComputeShader "glslComputeShader"++-- GENERAL++generalShader :: forall shtp . IsShaderKind shtp => String -> Name -> BS.ByteString -> QuasiQuoter+generalShader var shtp shnm = QuasiQuoter {+ quoteExp = generalShaderExp @shtp shtp shnm,+ quotePat = error "not defined",+ quoteType = error "not defined",+ quoteDec = generalShaderDec @shtp var shtp shnm }++generalShaderExp :: forall shtp . IsShaderKind shtp => Name -> BS.ByteString -> String -> ExpQ+generalShaderExp shtp shnm =+ mkShaderExp (conT ''S `appT` conT shtp) $ compileGeneralShader @shtp shnm++generalShaderDec :: forall shtp . IsShaderKind shtp => String -> Name -> BS.ByteString -> String -> DecsQ+generalShaderDec var shtp shnm =+ mkShaderDec var (conT ''S `appT` conT shtp) $ compileGeneralShader @shtp shnm++compileGeneralShader :: forall shtp . IsShaderKind shtp => BS.ByteString -> BS.ByteString -> IO BS.ByteString+compileGeneralShader nm src = (\(S spv :: S shtp) -> spv)+ <$> compile src nm "main" (def :: CompileOptions.C ())++-- BASE++mkShaderExp :: TypeQ -> (BS.ByteString -> IO BS.ByteString) -> String -> ExpQ+mkShaderExp typ cmp src =+ (`sigE` typ) . litE . stringL . BSC.unpack =<< runIO (cmp $ BSC.pack src)++mkShaderDec ::+ String -> TypeQ -> (BS.ByteString -> IO BS.ByteString) -> String -> DecsQ+mkShaderDec nm tp cmp src = sequence [+ sigD (mkName nm) tp,+ valD (varP $ mkName nm) (normalB $ mkShaderExp tp cmp src) [] ]
+ src/Shaderc/CompilationResult/Core.hsc view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Shaderc.CompilationResult.Core where++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String+import Data.Word++import Language.SpirV.Shaderc.Exception.Enum++#include <shaderc/shaderc.h>++data Tag+type T = Ptr Tag++foreign import ccall "shaderc_result_release" release :: T -> IO ()++foreign import ccall "shaderc_result_get_length"+ getLength :: T -> IO #{type size_t}++foreign import ccall "shaderc_result_get_num_warnings"+ getNumWarnings :: T -> IO #{type size_t}++foreign import ccall "shaderc_result_get_num_errors"+ getNumErrors :: T -> IO #{type size_t}++foreign import ccall "shaderc_result_get_compilation_status"+ getCompilationStatus :: T -> IO CompilationStatus++foreign import ccall "shaderc_result_get_bytes" getBytes :: T -> IO (Ptr CChar)++foreign import ccall "shaderc_result_get_error_message"+ getErrorMessage :: T -> IO CString
+ src/Shaderc/CompileOptions/Core.hsc view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Shaderc.CompileOptions.Core where++import Foreign.Ptr+import Foreign.C.Types+import Data.Word++import Shaderc.Enum+import Shaderc.Include.Core++#include <shaderc/shaderc.h>++data CTag+type C = Ptr CTag++foreign import ccall "shaderc_compile_options_initialize" initialize :: IO C+foreign import ccall "shaderc_compile_options_clone" clone :: C -> IO C+foreign import ccall "shaderc_compile_options_release" release :: C -> IO ()++foreign import ccall "shaderc_compile_options_add_macro_definition"+ addMacroDefinition ::+ C -> Ptr CChar -> #{type size_t} -> Ptr CChar -> #{type size_t} -> IO ()++foreign import ccall "shaderc_compile_options_set_source_language"+ setSourceLanguage :: C -> SourceLanguage -> IO ()++foreign import ccall "shaderc_compile_options_set_generate_debug_info"+ setGenerateDebugInfo :: C -> IO ()++foreign import ccall "shaderc_compile_options_set_optimization_level"+ setOptimizationLevel :: C -> OptimizationLevel -> IO ()++foreign import ccall "shaderc_compile_options_set_forced_version_profile"+ setForcedVersionProfile :: C -> Version -> Profile -> IO()++setIncludeCallbacks :: C -> ResolveFn -> ResultReleaseFn -> PtrVoid -> IO ()+setIncludeCallbacks opts rfn rrfn ud = do+ prfn <- wrap_resolveFn rfn+ prrfn <- wrap_resultReleaseFn rrfn+ c_shaderc_compile_options_set_include_callbacks opts prfn prrfn ud++foreign import ccall "shaderc_compile_options_set_include_callbacks"+ c_shaderc_compile_options_set_include_callbacks ::+ C -> FunPtr ResolveFn -> FunPtr ResultReleaseFn -> PtrVoid -> IO ()
+ src/Shaderc/Core.hsc view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Shaderc.Core where++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String+import Data.Word++import Language.SpirV.ShaderKind.Core++import qualified Shaderc.CompileOptions.Core as CompileOptions+import qualified Shaderc.CompilationResult.Core as CompilationResult++#include <shaderc/shaderc.h>++data CompilerTag+type CompilerT = Ptr CompilerTag++foreign import ccall "shaderc_compiler_initialize"+ compilerInitialize :: IO CompilerT++foreign import ccall "shaderc_compiler_release"+ compilerRelease :: CompilerT -> IO ()++foreign import ccall "shaderc_compile_into_spv" compileIntoSpv ::+ CompilerT -> Ptr CChar -> #{type size_t} ->+ ShaderKind -> CString -> CString ->+ CompileOptions.C -> IO CompilationResult.T++foreign import ccall "shaderc_compile_into_spv_assembly"+ compileIntoSpvAssembly ::+ CompilerT -> Ptr CChar -> #{type size_t} ->+ ShaderKind -> CString -> CString ->+ CompileOptions.C -> IO CompilationResult.T++foreign import ccall "shaderc_compile_into_preprocessed_text"+ compileIntoPreprocessedText ::+ CompilerT -> Ptr CChar -> #{type size_t} ->+ ShaderKind -> CString -> CString ->+ CompileOptions.C -> IO CompilationResult.T++glslVertexShader :: #{type shaderc_shader_kind}+glslVertexShader = #{const shaderc_glsl_vertex_shader}++vertexShader :: #{type shaderc_shader_kind}+vertexShader = #{const shaderc_vertex_shader}++sourceLanguageHlsl :: #{type shaderc_source_language}+sourceLanguageHlsl = #{const shaderc_source_language_hlsl}++optimizationLevelZero :: #{type shaderc_optimization_level}+optimizationLevelZero = #{const shaderc_optimization_level_zero}++optimizationLevelSize :: #{type shaderc_optimization_level}+optimizationLevelSize = #{const shaderc_optimization_level_size}++optimizationLevelPerformance :: #{type shaderc_optimization_level}+optimizationLevelPerformance =+ #{const shaderc_optimization_level_performance}
+ src/Shaderc/Enum.hsc view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Shaderc.Enum where++import Foreign.Storable+import Foreign.C.Enum+import Data.Word+import Data.Int++#include <shaderc/shaderc.h>++enum "CompilationStatus" ''#{type shaderc_compilation_status}+ [''Show, ''Storable] [+ ("CompilationStatusSuccess",+ #{const shaderc_compilation_status_success}),+ ("CompilationStatusInvalidStage",+ #{const shaderc_compilation_status_invalid_stage}),+ ("CompilationStatusError",+ #{const shaderc_compilation_status_compilation_error}),+ ("CompilationStatusInternalError",+ #{const shaderc_compilation_status_internal_error}),+ ("CompilationStatusNullResultObject",+ #{const shaderc_compilation_status_null_result_object}),+ ("CompilationStatusInvalidAssembly",+ #{const shaderc_compilation_status_invalid_assembly}),+ ("CompilationStatusValidationError",+ #{const shaderc_compilation_status_validation_error}),+ ("CompilationStatusTransformationError",+ #{const shaderc_compilation_status_transformation_error}),+ ("CompilationStatusConfigurationError",+ #{const shaderc_compilation_status_configuration_error}) ]++enum "SourceLanguage" ''#{type shaderc_source_language}+ [''Show, ''Storable] [+ ("SourceLanguageGlsl", #{const shaderc_source_language_glsl}),+ ("SourceLanguageHlsl", #{const shaderc_source_language_hlsl}) ]++enum "OptimizationLevel" ''#{type shaderc_optimization_level}+ [''Show, ''Eq, ''Storable] [+ ("OptimizationLevelZero", #{const shaderc_optimization_level_zero}),+ ("OptimizationLevelSize", #{const shaderc_optimization_level_size}),+ ("OptimizationLevelPerformance",+ #{const shaderc_optimization_level_performance}) ]++enum "Profile" ''#{type shaderc_profile} [''Show, ''Eq, ''Storable] [+ ("ProfileNone", #{const shaderc_profile_none}),+ ("ProfileCore", #{const shaderc_profile_core}),+ ("ProfileCompatibility", #{const shaderc_profile_compatibility}),+ ("ProfileEs", #{const shaderc_profile_es}) ]++version :: Int -> Version+version = Version . fromIntegral++newtype Version = Version #{type int} deriving Show
+ src/Shaderc/Include.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Shaderc.Include where++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable+import Foreign.Storable.PeekPoke+import Control.Monad.Trans+import Control.Monad.Cont++import qualified Data.ByteString as BS++import qualified Shaderc.Include.Core as C++data Result ud = Result {+ resultSourceName :: BS.ByteString,+ resultContent :: BS.ByteString,+ resultUserData :: Maybe ud }+ deriving Show++resultToCore :: Pokable ud => Result ud -> ContT r IO C.Result+resultToCore Result {+ resultSourceName = src,+ resultContent = cnt,+ resultUserData = ud } = do+ (csrc, fromIntegral -> csrcln) <- ContT $ BS.useAsCStringLen src+ (ccnt, fromIntegral -> ccntln) <- ContT $ BS.useAsCStringLen cnt+ (castPtr -> pud) <- ContT $ withPokedMaybe ud+ pure $ C.Result {+ C.resultSourceName = csrc,+ C.resultSourceNameLength = csrcln,+ C.resultContent = ccnt,+ C.resultContentLength = ccntln,+ C.resultUserData = pud }++type ResolveFn ud =+ Maybe ud -> BS.ByteString -> C.Type -> BS.ByteString -> Int ->+ IO (Result ud)++resolveFnToCore :: Storable ud => ResolveFn ud -> (C.ResolveFn, C.ResultReleaseFn)+resolveFnToCore f = (resolveFnToResolveFnCore f, resultReleaseFn)++resultReleaseFn :: C.ResultReleaseFn+resultReleaseFn pud prslt = free pud >> free prslt++resolveFnToResolveFnCore :: Storable ud => ResolveFn ud -> C.ResolveFn+resolveFnToResolveFnCore f pud crqtd tp crqtng dpt = do+ ud <- case pud of+ NullPtr -> pure Nothing+ _ -> Just <$> peek (castPtr pud)+ rqtd <- BS.packCString crqtd+ rqtng <- BS.packCString crqtng+ prslt <- malloc+ rslt <- f ud rqtd tp rqtng $ fromIntegral dpt+ ($ pure) . runContT+ $ lift . poke prslt =<< resultToCore rslt+ pure prslt
+ src/Shaderc/Include/Core.hsc view
@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Shaderc.Include.Core where++import Foreign.Ptr+import Foreign.Storable+import Foreign.C.String+import Foreign.C.Enum+import Foreign.C.Struct+import Data.Word++#include <shaderc/shaderc.h>++type PtrVoid = Ptr ()++struct "Result" #{size shaderc_include_result}+ #{alignment shaderc_include_result} [+ ("sourceName", ''CString,+ [| #{peek shaderc_include_result, source_name} |],+ [| #{poke shaderc_include_result, source_name} |]),+ ("sourceNameLength", ''#{type size_t},+ [| #{peek shaderc_include_result, source_name_length} |],+ [| #{poke shaderc_include_result, source_name_length} |]),+ ("content", ''CString,+ [| #{peek shaderc_include_result, content} |],+ [| #{poke shaderc_include_result, content} |]),+ ("contentLength", ''#{type size_t},+ [| #{peek shaderc_include_result, content_length} |],+ [| #{poke shaderc_include_result, content_length} |]),+ ("userData", ''PtrVoid,+ [| #{peek shaderc_include_result, user_data} |],+ [| #{poke shaderc_include_result, user_data} |]) ]+ [''Show, ''Storable]++enum "Type" ''#{type enum shaderc_include_type} [''Show, ''Storable] [+ ("TypeRelative", #{const shaderc_include_type_relative}),+ ("TypeStandard", #{const shaderc_include_type_standard}) ]++type ResolveFn =+ PtrVoid -> CString -> Type -> CString -> #{type size_t} ->+ IO (Ptr Result)++foreign import ccall "wrapper"+ wrap_resolveFn :: ResolveFn -> IO (FunPtr ResolveFn)++type ResultReleaseFn = PtrVoid -> Ptr Result -> IO ()++foreign import ccall "wrapper"+ wrap_resultReleaseFn :: ResultReleaseFn -> IO (FunPtr ResultReleaseFn)
+ src/Shaderc/Middle.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIOnS_GHC -Wall -fno-warn-tabs #-}++module Shaderc.Middle where++import Foreign.Storable+import Control.Monad.Trans+import Control.Monad.Cont++import qualified Data.ByteString as BS++import Language.SpirV.ShaderKind.Core++import qualified Shaderc.Core as C+import qualified Language.SpirV.Shaderc.CompileOptions.Internal as CompileOptions+import qualified Shaderc.CompilationResult.Core as CompilationResult++compileIntoSpv :: Storable ud =>+ C.CompilerT -> BS.ByteString -> ShaderKind ->+ BS.ByteString -> BS.ByteString -> CompileOptions.C ud ->+ ContT r IO CompilationResult.T+compileIntoSpv cmp src knd ifnm epnm opts = do+ (csrc, fromIntegral -> csrcln) <- ContT $ BS.useAsCStringLen src+ cifnm <- ContT $ BS.useAsCString ifnm+ cepnm <- ContT $ BS.useAsCString epnm+ copts <- CompileOptions.tToCore opts+ lift $ C.compileIntoSpv cmp csrc csrcln knd cifnm cepnm copts
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"