diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for try-shaderc + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# try-shaderc diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/ShaderKind.txt b/data/ShaderKind.txt new file mode 100644 --- /dev/null +++ b/data/ShaderKind.txt @@ -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 diff --git a/shaderc.cabal b/shaderc.cabal new file mode 100644 --- /dev/null +++ b/shaderc.cabal @@ -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 +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 diff --git a/src/Language/SpirV/Shaderc.hs b/src/Language/SpirV/Shaderc.hs new file mode 100644 --- /dev/null +++ b/src/Language/SpirV/Shaderc.hs @@ -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 diff --git a/src/Language/SpirV/Shaderc/CompileOptions.hs b/src/Language/SpirV/Shaderc/CompileOptions.hs new file mode 100644 --- /dev/null +++ b/src/Language/SpirV/Shaderc/CompileOptions.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Language.SpirV.Shaderc.CompileOptions (C(..)) where + +import Language.SpirV.Shaderc.CompileOptions.Internal diff --git a/src/Language/SpirV/Shaderc/CompileOptions/Internal.hs b/src/Language/SpirV/Shaderc/CompileOptions/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/SpirV/Shaderc/CompileOptions/Internal.hs @@ -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 } diff --git a/src/Language/SpirV/Shaderc/Exception.hs b/src/Language/SpirV/Shaderc/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Language/SpirV/Shaderc/Exception.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Language.SpirV.Shaderc.Exception (E(..)) where + +import Language.SpirV.Shaderc.Exception.Internal diff --git a/src/Language/SpirV/Shaderc/Exception/Enum.hsc b/src/Language/SpirV/Shaderc/Exception/Enum.hsc new file mode 100644 --- /dev/null +++ b/src/Language/SpirV/Shaderc/Exception/Enum.hsc @@ -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 + +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}) ] diff --git a/src/Language/SpirV/Shaderc/Exception/Internal.hs b/src/Language/SpirV/Shaderc/Exception/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/SpirV/Shaderc/Exception/Internal.hs @@ -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 diff --git a/src/Language/SpirV/Shaderc/TH.hs b/src/Language/SpirV/Shaderc/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/SpirV/Shaderc/TH.hs @@ -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) [] ] diff --git a/src/Shaderc/CompilationResult/Core.hsc b/src/Shaderc/CompilationResult/Core.hsc new file mode 100644 --- /dev/null +++ b/src/Shaderc/CompilationResult/Core.hsc @@ -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 + +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 diff --git a/src/Shaderc/CompileOptions/Core.hsc b/src/Shaderc/CompileOptions/Core.hsc new file mode 100644 --- /dev/null +++ b/src/Shaderc/CompileOptions/Core.hsc @@ -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 + +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 () diff --git a/src/Shaderc/Core.hsc b/src/Shaderc/Core.hsc new file mode 100644 --- /dev/null +++ b/src/Shaderc/Core.hsc @@ -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 + +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} diff --git a/src/Shaderc/Enum.hsc b/src/Shaderc/Enum.hsc new file mode 100644 --- /dev/null +++ b/src/Shaderc/Enum.hsc @@ -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 + +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 diff --git a/src/Shaderc/Include.hs b/src/Shaderc/Include.hs new file mode 100644 --- /dev/null +++ b/src/Shaderc/Include.hs @@ -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 diff --git a/src/Shaderc/Include/Core.hsc b/src/Shaderc/Include/Core.hsc new file mode 100644 --- /dev/null +++ b/src/Shaderc/Include/Core.hsc @@ -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 + +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) diff --git a/src/Shaderc/Middle.hs b/src/Shaderc/Middle.hs new file mode 100644 --- /dev/null +++ b/src/Shaderc/Middle.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"