diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `spirv-headers` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2024 IC Rainbow + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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 @@ +# spirv-headers 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/app/gen-spirv-enum/Main.hs b/app/gen-spirv-enum/Main.hs new file mode 100644 --- /dev/null +++ b/app/gen-spirv-enum/Main.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import Options.Applicative + +import Data.Char (toUpper) +import Data.Bifunctor (first) +import Data.Bits (bit) +import Data.ByteString.Builder (Builder) +import Data.ByteString.Builder qualified as Builder +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.SpirV.Headers.Enum qualified as Enum +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8Builder) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (joinPath, (), (<.>)) + +main :: IO () +main = execParser (info optionsP idm) >>= run + +run :: Options -> IO () +run Options{..} = do + Enum.Spv{meta=_, enum} <- Enum.decode input >>= either fail pure + genIndexModule output modulePrefix $ List.sortOn Enum.name enum + mapM_ (genEnumModule output modulePrefix) enum + +genIndexModule :: FilePath -> [Text] -> [Enum.Enum] -> IO () +genIndexModule base path enums = do + createDirectoryIfMissing True dirPath + putStrLn filePath + Builder.writeFile filePath body + where + filePath = dirPath <.> "hs" + dirPath = base joinPath (map Text.unpack path) + modulePath = encodeUtf8Builder $ Text.intercalate "." path + body :: Builder + body = mconcat $ List.intersperse "\n" $ concat + [ [ "module " <> modulePath + ] + , reexports + , [ " ) where" + , "" + ] + , imports + ] + reexports = do + (Enum.Enum{name}, prefix) <- zip enums (" (" : repeat " ,") + pure $ prefix <> " module " <> qualified name + imports = do + Enum.Enum{name, type_} <- enums + let + tn = encodeUtf8Builder name + imported = case type_ of + Enum.Value -> tn <> "(..)" + Enum.Bit -> tn <> ", " <> tn <> "Bits(..)" + pure $ "import " <> qualified name <> " (" <> imported <> ")" + qualified :: Text -> Builder + qualified = + if null path then + encodeUtf8Builder + else + \name -> modulePath <> "." <> encodeUtf8Builder name + +genEnumModule :: FilePath -> [Text] -> Enum.Enum -> IO () +genEnumModule base path Enum.Enum{name, type_, values} = do + createDirectoryIfMissing True dirPath + putStrLn filePath + Builder.writeFile filePath body + where + filePath = dirPath Text.unpack name <.> "hs" + dirPath = base joinPath (map Text.unpack path) + modulePath = Text.intercalate "." $ path <> [name] + items = map (first pascalCase) . List.sortOn snd $ Map.assocs values + where + pascalCase t = case Text.uncons t of + Just (c, t') | c /= c' -> Builder.char7 c' <> encodeUtf8Builder t' + where + c' = toUpper c + _ -> encodeUtf8Builder t + + body :: Builder + body = mconcat $ List.intersperse "\n" $ concat + [ prologue + , imports + , [""] + , typeDecl + ] + prologue :: [Builder] + prologue = + [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" + , "{-# LANGUAGE DerivingStrategies #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "{-# LANGUAGE TypeSynonymInstances #-}" + , "" + , "module " <> encodeUtf8Builder modulePath <> " where" + , "" + ] + imports :: [Builder] + imports = case type_ of + Enum.Value -> + [ "import Data.Int (Int32)" + , "import Foreign.Storable (Storable)" + ] + Enum.Bit -> + [ "import Data.Bits (Bits, FiniteBits, (.|.))" + , "import Data.Word (Word32)" + , "import Foreign.Storable (Storable)" + ] + typeDecl :: [Builder] + typeDecl = case type_ of + Enum.Value -> + [ "newtype " <> valueName <> " = " <> valueName <> " Int32" + , " deriving newtype (Eq, Ord, Storable)" + ] <> instanceShow <> patterns + where + valueName = encodeUtf8Builder name + instanceShow = + [ "" + , "instance Show " <> valueName <> " where" + , " showsPrec p (" <> valueName <> " v) = case v of" + ] <> showCase <> showUnknown + showCase = do + (k, v) <- List.nubBy (\(_, a) (_, b) -> a == b) items + pure $ " " <> Builder.integerDec v <> " -> showString \"" <> k <> "\"" + showUnknown = + [ " x -> showParen (p > 10) $ showString \"" <> valueName <> " \" . showsPrec (p + 1) x" + ] + patterns :: [Builder] + patterns = do + (k, v) <- items + [ "" + , "pattern " <> k <> " :: " <> valueName + , "pattern " <> k <> " = " <> valueName <> " " <> Builder.integerDec v + ] + Enum.Bit -> + [ "type " <> flagName <> " = " <> bitsName + , "" + , "newtype " <> bitsName <> " = " <> bitsName <> " Word32" + , " deriving newtype (Eq, Ord, Storable, Bits, FiniteBits)" + ] <> instanceShow <> instanceSemigroup <> instanceMonoid <> patterns + where + flagName = encodeUtf8Builder name + bitsName = encodeUtf8Builder name <> "Bits" + instanceShow = + [] + instanceSemigroup = + [ "" + , "instance Semigroup " <> flagName <> " where" + , " (" <> bitsName <> " a) <> (" <> bitsName <> " b) = " <> bitsName <> " (a .|. b)" + ] + instanceMonoid = + [ "" + , "instance Monoid " <> flagName <> " where" + , " mempty = " <> bitsName <> " 0" + ] + patterns :: [Builder] + patterns = do + (k, v) <- items + [ "" + , "pattern " <> k <> " :: " <> bitsName + , "pattern " <> k <> " = " <> bitsName <> " 0x" <> Builder.word32HexFixed (bit $ fromIntegral v) + ] + +data Options = Options + { input :: FilePath + , output :: FilePath + , modulePrefix :: [Text] + } + +defaultOptions :: Options +defaultOptions = Options + { input = "SPIRV-Headers/include/spirv/unified1/spirv.json" + , output = "spirv-enum/src" + , modulePrefix = ["Data", "SpirV", "Enum"] + } + +optionsP :: Parser Options +optionsP = do + input <- strOption $ mconcat + [ long "input" + , short 'i' + , metavar "FILE" + , help "Path to spirv.json file." + , value $ input defaultOptions + , showDefault + ] + output <- strOption $ mconcat + [ long "output" + , short 'o' + , metavar "DIR" + , help "Root path for generated modules." + , value $ output defaultOptions + , showDefault + ] + modulePrefix <- option (eitherReader $ modulePrefixP . Text.pack) $ mconcat + [ long "module-prefix" + , short 'm' + , metavar "HASKELL.MODULE.PATH" + , help "Name and directory prefix for generated modules." + , value $ modulePrefix defaultOptions + , showDefaultWith (Text.unpack . Text.intercalate ".") + ] + pure Options{..} + +modulePrefixP :: Text -> Either String [Text] +modulePrefixP = \case + "" -> Left "Empty path" + s | ".." `Text.isInfixOf` s -> Left "Empty module segment" + s | ('/' `Text.elem` s) || ('\\' `Text.elem` s) -> Left "Module paths are dotted, not slashed." + s | not $ null (drop 1 $ Text.words s) -> Left "Module paths can't contain spaces." + s -> Right $ Text.split (== '.') s diff --git a/spirv-headers.cabal b/spirv-headers.cabal new file mode 100644 --- /dev/null +++ b/spirv-headers.cabal @@ -0,0 +1,85 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: spirv-headers +version: 0.1.0.0 +synopsis: Types and generator for SPIR-V JSON spec. +category: Graphics +author: IC Rainbow +maintainer: aenor.realm@gmail.com +copyright: 2024 IC Rainbow +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://gitlab.com/dpwiz/spirv-headers + +flag lib-only + manual: True + default: True + +library + exposed-modules: + Data.SpirV.Headers.Enum + other-modules: + Paths_spirv_headers + autogen-modules: + Paths_spirv_headers + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson + , base >=4.7 && <5 + , containers + , text + default-language: Haskell2010 + +executable gen-spirv-enum + main-is: Main.hs + other-modules: + Paths_spirv_headers + autogen-modules: + Paths_spirv_headers + hs-source-dirs: + app/gen-spirv-enum + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , directory + , filepath + , optparse-applicative + , spirv-headers + , text + default-language: Haskell2010 + if flag(lib-only) + buildable: False + +test-suite spirv-headers-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_spirv_headers + autogen-modules: + Paths_spirv_headers + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , shower + , spirv-headers + default-language: Haskell2010 + if flag(lib-only) + buildable: False diff --git a/src/Data/SpirV/Headers/Enum.hs b/src/Data/SpirV/Headers/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Data/SpirV/Headers/Enum.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StrictData #-} + +module Data.SpirV.Headers.Enum + ( decode + , SpirvJson(..) + , Spv(..) + , Meta(..) + , Enum(..) + , Type(..) + ) where + +import Prelude hiding (Enum) + +import Data.Aeson (eitherDecodeFileStrict) +import Data.Aeson.Types (FromJSON(..), Options(..), defaultOptions, genericParseJSON) +import Data.Char (toUpper) +import Data.Map.Strict (Map) +import Data.Text (Text) +import Data.Word (Word32) +import GHC.Generics (Generic) + +decode :: FilePath -> IO (Either String Spv) +decode fp = fmap spv <$> eitherDecodeFileStrict fp + +newtype SpirvJson = SpirvJson + { spv :: Spv + } + deriving (Eq, Show, Generic) + +instance FromJSON SpirvJson + +data Spv = Spv + { meta :: Meta + , enum :: [Enum] + } + deriving (Eq, Show, Generic) + +instance FromJSON Spv + +data Meta = Meta + { comment :: [[Text]] + , magicNumber :: Int + , version :: Int + , revision :: Int + , opCodeMask :: Word32 + , wordCountShift :: Int + } + deriving (Eq, Show, Generic) + +instance FromJSON Meta where + parseJSON = genericParseJSON pascalCase + +data Enum = Enum + { name :: Text + , type_ :: Type + , values :: Map Text Integer + } + deriving (Eq, Show, Generic) + +instance FromJSON Enum where + parseJSON = genericParseJSON pascalCase + +data Type + = Value + | Bit + deriving (Eq, Show, Generic) + +instance FromJSON Type + +pascalCase :: Options +pascalCase = defaultOptions + { fieldLabelModifier = \case + [] -> [] + "type_" -> "Type" + x : xs -> toUpper x : xs + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +import Data.SpirV.Headers.Enum qualified as Enum + +import Shower (printer) + +main :: IO () +main = Enum.decode "SPIRV-Headers/include/spirv/unified1/spirv.json" >>= either fail printer