diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,6 @@ -import Distribution.Simple -main = defaultMain +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,10 @@ ## WIP +## [0.1.3] - 2020-11-12 + +- Add `glsl` interpolating quasiquoter + ## [0.1.2.1] - 2020-11-01 - Raise bound on base diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: vulkan-utils -version: "0.1.2.1" +version: "0.1.3" synopsis: Utils for the vulkan package category: Graphics maintainer: Joe Hermaszewski @@ -23,6 +23,23 @@ - temporary - typed-process - vulkan + +tests: + doctests: + main: Doctests.hs + other-modules: "" + source-dirs: + - test/doctest + dependencies: + - base + - doctest + - vulkan-utils + +custom-setup: + dependencies: + - base + - Cabal + - cabal-doctest >= 1 && <1.1 default-extensions: - AllowAmbiguousTypes diff --git a/src/Vulkan/Utils/ShaderQQ.hs b/src/Vulkan/Utils/ShaderQQ.hs --- a/src/Vulkan/Utils/ShaderQQ.hs +++ b/src/Vulkan/Utils/ShaderQQ.hs @@ -1,5 +1,6 @@ module Vulkan.Utils.ShaderQQ - ( comp + ( glsl + , comp , frag , geom , tesc @@ -25,41 +26,93 @@ import System.FilePath import System.IO.Temp import System.Process.Typed +import Vulkan.Utils.ShaderQQ.Interpolate --- | QuasiQuoter for creating a compute shader +-- $setup +-- >>> :set -XQuasiQuotes + +-- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@ +-- directives inserted so that error locations point to the correct location in +-- the Haskell source file. It also permits basic string interpolation. +-- +-- - Interpolated variables are prefixed with @$@ +-- - They can optionally be surrounded with braces like @${foo}@ +-- - Interpolated variables are converted to strings with 'show' +-- - To escape a @$@ use @\\$@ +-- +-- It is intended to be used in concert with 'compileShaderQ' like so +-- +-- @ +-- myConstant = 3.141 -- Note that this will have to be in a different module +-- myFragmentShader = $(compileShaderQ "frag" [glsl| +-- #version 450 +-- const float myConstant = ${myConstant}; +-- main (){ +-- } +-- |]) +-- @ +-- +-- An explicit example (@@ is from doctest): +-- +-- >>> let version = 450 :: Int in [glsl|#version $version|] +-- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line 32 \"\"\n" +-- +-- Note that line number will be thrown off if any of the interpolated +-- variables contain newlines. +glsl :: QuasiQuoter +glsl = (badQQ "glsl") + { quoteExp = \s -> do + loc <- location + -- Insert the directive here, `compileShaderQ` will insert + -- another one, but it's before this one, so who cares. + let codeWithLineDirective = insertLineDirective s loc + interpExp codeWithLineDirective + } + +-- | QuasiQuoter for creating a compute shader. +-- +-- Equivalent to calling @$(compileShaderQ "comp" [glsl|...|])@ without +-- interpolation support. comp :: QuasiQuoter comp = shaderQQ "comp" --- | QuasiQuoter for creating a fragment shader +-- | QuasiQuoter for creating a fragment shader. +-- +-- Equivalent to calling @$(compileShaderQ "frag" [glsl|...|])@ without +-- interpolation support. frag :: QuasiQuoter frag = shaderQQ "frag" --- | QuasiQuoter for creating a geometry shader +-- | QuasiQuoter for creating a geometry shader. +-- +-- Equivalent to calling @$(compileShaderQ "geom" [glsl|...|])@ without +-- interpolation support. geom :: QuasiQuoter geom = shaderQQ "geom" --- | QuasiQuoter for creating a tessellation control shader +-- | QuasiQuoter for creating a tessellation control shader. +-- +-- Equivalent to calling @$(compileShaderQ "tesc" [glsl|...|])@ without +-- interpolation support. tesc :: QuasiQuoter tesc = shaderQQ "tesc" --- | QuasiQuoter for creating a tessellation evaluation shader +-- | QuasiQuoter for creating a tessellation evaluation shader. +-- +-- Equivalent to calling @$(compileShaderQ "tese" [glsl|...|])@ without +-- interpolation support. tese :: QuasiQuoter tese = shaderQQ "tese" --- | QuasiQuoter for creating a vertex shader +-- | QuasiQuoter for creating a vertex shader. +-- +-- Equivalent to calling @$(compileShaderQ "vert" [glsl|...|])@ without +-- interpolation support. vert :: QuasiQuoter vert = shaderQQ "vert" shaderQQ :: String -> QuasiQuoter -shaderQQ stage = QuasiQuoter - { quoteExp = compileShaderQ stage - , quotePat = bad "pattern" - , quoteType = bad "type" - , quoteDec = bad "declaration" - } - where - bad :: String -> a - bad s = error $ "Can't use " <> stage <> " quote in a " <> s <> " context" +shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ stage } -- | Compile a glsl shader to spir-v using glslangValidator. -- @@ -152,3 +205,17 @@ in case afterVersion of [] -> code v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs + +---------------------------------------------------------------- +-- Utils +---------------------------------------------------------------- + +badQQ :: String -> QuasiQuoter +badQQ name = QuasiQuoter (bad "expression") + (bad "pattern") + (bad "type") + (bad "declaration") + where + bad :: String -> a + bad context = + error $ "Can't use " <> name <> " quote in a " <> context <> " context" diff --git a/src/Vulkan/Utils/ShaderQQ/Interpolate.hs b/src/Vulkan/Utils/ShaderQQ/Interpolate.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/Interpolate.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} + +module Vulkan.Utils.ShaderQQ.Interpolate + ( interpExp + ) where + +import Control.Applicative ( liftA2 ) +import Data.Char +import Language.Haskell.TH +import Text.ParserCombinators.ReadP + +-- $setup +-- >>> :set -XTemplateHaskell +-- >>> import Data.Proxy + +-- | 'interpExp' performs very simple interpolation of Haskell +-- values into 'String's. +-- +-- - Interpolated variables are prefixed with @$@ +-- - They can optionally be surrounded with braces like @${foo}@ +-- - Interpolated variables are converted to strings with 'show' +-- - To escape a @$@ use @\\$@ +-- +-- >>> let foo = 123 in $(interpExp "hello, $foo") +-- "hello, 123" +-- +-- >>> let foo = "world" in $(interpExp "hello, \\$foo") +-- "hello, $foo" +-- +-- >>> let foo = "world" in $(interpExp "hello\r\n\rworld") +-- "hello\r\n\rworld" +interpExp :: String -> Q Exp +interpExp = + foldEither (litE (stringL "")) + (appE (varE 'show) . varOrConE) + (litE . stringL) + (\e1 e2 -> [|$e1 <> $e2|]) + . parse + +---------------------------------------------------------------- +-- The parser +---------------------------------------------------------------- + +type Var = String + +-- | Extract variables and literals from string to be interpolated +-- +-- >>> parse "" +-- [] +-- +-- >>> parse "hello $world" +-- [Right "hello ",Left "world"] +-- +-- >>> parse "$hello$world" +-- [Left "hello",Left "world"] +-- +-- >>> parse "$" +-- [Right "$"] +-- +-- >>> parse "hi" +-- [Right "hi"] +-- +-- >>> parse "h$hi" +-- [Right "h",Left "hi"] +-- +-- >>> parse "$$hi" +-- [Right "$",Left "hi"] +-- +-- >>> parse "$1" +-- [Right "$1"] +-- +-- >>> parse "$$$" +-- [Right "$$$"] +-- +-- >>> parse "\\" +-- [Right "\\"] +-- +-- >>> parse "\\$" +-- [Right "$"] +-- +-- >>> parse "\\$hi" +-- [Right "$hi"] +-- +-- >>> parse "\\\\$hi" +-- [Right "\\$hi"] +-- +-- >>> parse "\\hi" +-- [Right "\\hi"] +-- +-- >>> parse "$hi\\$foo" +-- [Left "hi",Right "$foo"] +-- +-- >>> parse "hello, \\$foo" +-- [Right "hello, $foo"] +-- +-- >>> parse "${fo'o}bar" +-- [Left "fo'o",Right "bar"] +-- +-- >>> parse "\\" +-- [Right "\\"] +-- +-- >>> parse "\\\\$" +-- [Right "\\$"] +-- +-- >>> parse "$" +-- [Right "$"] +parse :: String -> [Either Var String] +parse s = + let -- A haskell var or con + ident = (:) <$> satisfy (isLower <||> isUpper <||> (== '_')) <*> munch + (isAlphaNum <||> (== '\'') <||> (== '_')) + braces = between (char '{') (char '}') + -- parse a var, a '$' followed by an ident + var = + char '$' *> ((Left <$> (ident +++ braces ident)) <++ pure (Right "$")) + -- Everything up to a '$' or '\' + normal = Right <$> munch1 ((/= '$') <&&> (/= '\\')) + -- escape a $ + escape = char '\\' *> (Right <$> (string "$" <++ pure "\\")) + -- One normal or var + -- - Check escaped '$' first + -- - variables, starting with $ + -- - normal string + one = normal +++ var +++ escape + parser = many one <* eof + in + case readP_to_S parser s of + [(r, "")] -> foldr mergeRights [] r + _ -> error "Failed to parse string" + +mergeRights :: Either Var String -> [Either Var String] -> [Either Var String] +mergeRights = \case + Left v -> (Left v :) + Right n -> \case + (Right m : xs) -> Right (n <> m) : xs + xs -> Right n : xs + +(<&&>), (<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) = liftA2 (||) +(<&&>) = liftA2 (&&) + +---------------------------------------------------------------- +-- Misc utilities +---------------------------------------------------------------- + +varOrConE :: String -> ExpQ +varOrConE n = (if isLower (head n) then varE else conE) . mkName $ n + +foldEither + :: (Foldable t, Functor t) + => c + -> (a -> c) + -> (b -> c) + -> (c -> c -> c) + -> t (Either a b) + -> c +foldEither i l r f = foldr f i . fmap (either l r) diff --git a/test/doctest/Doctests.hs b/test/doctest/Doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctest/Doctests.hs @@ -0,0 +1,10 @@ +module Main where + +import Build_doctests ( flags + , module_sources + , pkgs + ) +import Test.DocTest ( doctest ) + +main :: IO () +main = doctest $ flags ++ pkgs ++ module_sources diff --git a/vulkan-utils.cabal b/vulkan-utils.cabal --- a/vulkan-utils.cabal +++ b/vulkan-utils.cabal @@ -1,13 +1,13 @@ -cabal-version: 1.12 +cabal-version: 1.24 -- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack -- --- hash: 02cd419c730d93f7db6f291f1fac9c67d943c8c7a6d2be902231c4c693a58d51 +-- hash: 6d99c3af4fa07ab496a943502da39d9e6a6a8d08636c91bcee01195c4a2149d3 name: vulkan-utils -version: 0.1.2.1 +version: 0.1.3 synopsis: Utils for the vulkan package category: Graphics homepage: https://github.com/expipiplus1/vulkan#readme @@ -15,7 +15,7 @@ maintainer: Joe Hermaszewski license: BSD3 license-file: LICENSE -build-type: Simple +build-type: Custom extra-source-files: readme.md changelog.md @@ -26,11 +26,18 @@ type: git location: https://github.com/expipiplus1/vulkan +custom-setup + setup-depends: + Cabal + , base + , cabal-doctest >=1 && <1.1 + library exposed-modules: Vulkan.Utils.Debug Vulkan.Utils.FromGL Vulkan.Utils.ShaderQQ + Vulkan.Utils.ShaderQQ.Interpolate other-modules: Paths_vulkan_utils hs-source-dirs: @@ -48,4 +55,18 @@ , temporary , typed-process , vulkan + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: Doctests.hs + other-modules: + + hs-source-dirs: + test/doctest + default-extensions: AllowAmbiguousTypes CPP DataKinds DefaultSignatures DeriveAnyClass DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MagicHash NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Strict TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns + build-depends: + base + , doctest + , vulkan-utils default-language: Haskell2010