spirv-headers (empty) → 0.1.0.0

raw patch · 8 files changed

+430/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, directory, filepath, optparse-applicative, shower, spirv-headers, text

Files

• CHANGELOG.md +11/−0
• LICENSE +26/−0
• README.md +1/−0
• Setup.hs +2/−0
• app/gen-spirv-enum/Main.hs +219/−0
• spirv-headers.cabal +85/−0
• src/Data/SpirV/Headers/Enum.hs +78/−0
• test/Spec.hs +8/−0

@@ -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

@@ -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.

@@ -0,0 +1,1 @@+# spirv-headers

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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

@@ -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

@@ -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+  }

@@ -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