vulkan-utils 0.5.9 → 0.5.10
raw patch · 4 files changed
+230/−129 lines, 4 files
Files
- changelog.md +6/−0
- package.yaml +1/−1
- src/Vulkan/Utils/Requirements/TH.hs +222/−127
- vulkan-utils.cabal +1/−1
changelog.md view
@@ -2,6 +2,12 @@ ## WIP +## [0.5.10] - 2022-09-27+- Improve error messages for requirements TH++## [0.5.9.1] - 2022-09-26+- Fix tests on ghc 9.2+ ## [0.5.9] - 2022-09-24 - Relax bounds on `vulkan`
package.yaml view
@@ -1,5 +1,5 @@ name: vulkan-utils-version: "0.5.9"+version: "0.5.10" synopsis: Utils for the vulkan package category: Graphics maintainer: Ellie Hermaszewska <live.long.and.prosper@monoid.al>
src/Vulkan/Utils/Requirements/TH.hs view
@@ -1,35 +1,37 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} module Vulkan.Utils.Requirements.TH ( req , reqs- ) where+ )+where -import Control.Applicative-import Control.Category ( (>>>) )-import Control.Monad-import Data.Char-import Data.Foldable-import Data.List ( intercalate- , isPrefixOf- )-import Data.List.Extra ( nubOrd )-import Data.Maybe-import Data.String-import Data.Traversable-import Data.Word-import Language.Haskell.TH-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Prelude hiding ( GT )-import Text.ParserCombinators.ReadP- hiding ( optional )-import Text.Read ( readMaybe )-import Vulkan.Requirement-import Vulkan.Utils.Internal-import Vulkan.Utils.Misc-import Vulkan.Version ( pattern MAKE_API_VERSION )+import Control.Applicative+import Control.Category ((>>>))+import Control.Monad+import Data.Char+import Data.Either (lefts)+import Data.Foldable+import Data.Functor ((<&>))+import Data.List ( intercalate, isPrefixOf, dropWhileEnd )+import Data.List.Extra (nubOrd)+import Data.Maybe+import Data.String+import Data.Traversable+import Data.Word+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Text.ParserCombinators.ReadP hiding+ ( optional+ )+import Text.Read (readMaybe)+import Vulkan.Requirement+import Vulkan.Utils.Internal+import Vulkan.Utils.Misc+import Vulkan.Version (pattern MAKE_API_VERSION)+import Prelude hiding (GT) -- $setup -- >>> import Vulkan.Core11.Promoted_From_VK_KHR_multiview@@ -49,7 +51,7 @@ -- 'DevicePropertyRequirement's are specified like feature requirements except -- with an additional description of the constraint. This may be any of ----- - @myFunctioName@: To check with an in-scope function taking the property+-- - @myFunctionName@: To check with an in-scope function taking the property -- type and returning 'Bool' -- - @> 123@: To indicate a minimum bound on a integral property -- - @>= 123@: To indicate an inclusive minimum bound on a integral property@@ -73,11 +75,26 @@ -- >>> featureName r -- "PhysicalDeviceVulkan11Features.multiview" ----- >>> let r = [req|PhysicalDeviceMultiviewFeatures.multiview|]--- >>> featureName r--- "PhysicalDeviceMultiviewFeatures.multiview"+-- >>> let r = [reqs| PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore |]+-- >>> featureName <$> r+-- ["PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore"]+--+-- >>> let r = [req|PhysicalDeviceMultiviewFeatures.doesn'tExist|]+-- ...+-- • Couldn't find member "doesn'tExist" in Vulkan.Core11.Promoted_From_VK_KHR_multiview.PhysicalDeviceMultiviewFeatures+-- ...+--+-- >>> let r = [req|Doesn'tExist.multiview|]+-- ...+-- • Couldn't find type name "Doesn'tExist"+-- ...+--+-- >>> let r = [req|Either.multiview|]+-- ...+-- • Data.Either.Either doesn't seem to be the type of a record constructor+-- ... req :: QuasiQuoter-req = (badQQ "req") { quoteExp = reqExp }+req = (badQQ "req"){quoteExp = reqExp} -- | Like 'reqs' except that this parses a list of newline separated -- requirements@@ -87,50 +104,53 @@ -- - Blank lines -- - Lines beginning with @--@ or @#@ reqs :: QuasiQuoter-reqs = (badQQ "req") { quoteExp = exps reqExp . filterComments }+reqs = (badQQ "req"){quoteExp = exps reqExp . filterComments} reqExp :: String -> Q Exp reqExp s = do case parse s of Nothing -> fail $ "Couldn't parse " <> show s- Just r -> do+ Just r -> do r' <- nameRequest r renderRequest s r' renderRequest :: String -> Request Name Name -> ExpQ renderRequest input = \case Feature s m ->- let t = conT s- check = [|$(varE m) :: $t -> Bool|]- enable = [|\str -> $(recUpdE [| str :: $t |] [fieldExp m [|True|]])|]- in [| let featureName = fromString $(lift input)- checkFeature = $(check)- enableFeature = $(enable)- in RequireDeviceFeature featureName checkFeature enableFeature- |]+ let check = explicitRecordGet s m (ConT ''Bool)+ enable = explicitRecordSet s m (ConT ''Bool) [|True|]+ in do+ [|+ let featureName = fromString $(lift input)+ checkFeature = $(check)+ enableFeature = $(enable)+ in RequireDeviceFeature featureName checkFeature enableFeature+ |] Property s m c -> let t = conT s getProp = [|\str -> $(varE m) (str :: $t)|] checker = case c of- GTE v -> [|(>= $(litE (IntegerL v)))|]- GT v -> [|(> $(litE (IntegerL v)))|]- AndBit b -> [|(.&&. $(conE b))|]- Fun f -> [|$(varE f)|]+ GTE v -> [|(>= $(litE (IntegerL v)))|]+ GT v -> [|(> $(litE (IntegerL v)))|]+ AndBit b -> [|(.&&. $(conE b))|]+ Fun f -> [|$(varE f)|] check = [|$checker . $getProp|]- in [| let propertyName = fromString $(lift input)+ in [|+ let propertyName = fromString $(lift input) checkProperty = $(check)- in RequireDeviceProperty propertyName checkProperty- |]+ in RequireDeviceProperty propertyName checkProperty+ |] Extension s v ->- [| let deviceExtensionLayerName = Nothing- deviceExtensionName = fromString $(lift s)- deviceExtensionMinVersion = $(lift (fromMaybe minBound v))- in RequireDeviceExtension- deviceExtensionLayerName- deviceExtensionName- deviceExtensionMinVersion- |]- Version v -> [| RequireDeviceVersion $(lift v) |]+ [|+ let deviceExtensionLayerName = Nothing+ deviceExtensionName = fromString $(lift s)+ deviceExtensionMinVersion = $(lift (fromMaybe minBound v))+ in RequireDeviceExtension+ deviceExtensionLayerName+ deviceExtensionName+ deviceExtensionMinVersion+ |]+ Version v -> [|RequireDeviceVersion $(lift v)|] nameRequest :: Request [String] String -> Q (Request Name Name) nameRequest = \case@@ -146,14 +166,14 @@ Extension s v -> pure $ Extension s v Version v -> pure $ Version v where- getQualTyName n = do- let q = intercalate "." n- maybe (fail $ "Couldn't find type name " <> show q) pure- =<< lookupTypeName q- getQualValueName n = do- let q = intercalate "." n- maybe (fail $ "Couldn't find value name " <> show q) pure- =<< lookupValueName q+ getQualTyName n = do+ let q = intercalate "." n+ maybe (fail $ "Couldn't find type name " <> show q) pure+ =<< lookupTypeName q+ getQualValueName n = do+ let q = intercalate "." n+ maybe (fail $ "Couldn't find value name " <> show q) pure+ =<< lookupValueName q data Request qual unqual = Version Word32@@ -201,74 +221,72 @@ -- Just (Property ["V","Foo"] "bar" (Fun ["Prelude","even"])) parse :: String -> Maybe (Request [String] String) parse =- let- varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_'))- var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars- con = (:) <$> satisfy isUpper <*> varRemChars- mod' = con- qual :: ReadP String -> ReadP [String]- qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x)- separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"]))+ let varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_'))+ var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars+ con = (:) <$> satisfy isUpper <*> varRemChars+ mod' = con+ qual :: ReadP String -> ReadP [String]+ qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x)+ separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"])) - digits = munch1 isDigit- integer = readS_to_P (reads @Integer)- word = do- Just w <- readMaybe <$> digits- pure w+ digits = munch1 isDigit+ integer = readS_to_P (reads @Integer)+ word = do+ Just w <- readMaybe <$> digits+ pure w - comp = do- c <- (GT <$ string ">") <|> (GTE <$ string ">=")- skipSpaces- w <- integer- pure $ c w- andBit = do- _ <- string "&"- skipSpaces- q <- qual con- pure $ AndBit q- fun = Fun <$> qual var- constraint = comp <|> andBit <|> fun+ comp = do+ c <- (GT <$ string ">") <|> (GTE <$ string ">=")+ skipSpaces+ w <- integer+ pure $ c w+ andBit = do+ _ <- string "&"+ skipSpaces+ q <- qual con+ pure $ AndBit q+ fun = Fun <$> qual var+ constraint = comp <|> andBit <|> fun - version = do- ma <- word- separator- mi <- word- pa <- fromMaybe 0 <$> (separator *> optional word)- pure $ Version (MAKE_API_VERSION ma mi pa)+ version = do+ ma <- word+ separator+ mi <- word+ pa <- fromMaybe 0 <$> (separator *> optional word)+ pure $ Version (MAKE_API_VERSION ma mi pa) - feature = do- s <- qual con- _ <- separator- m <- var- pure $ Feature s m+ feature = do+ s <- qual con+ _ <- separator+ m <- var+ pure $ Feature s m - property = do- s <- qual con- _ <- separator- m <- var- skipSpaces- c <- constraint- pure $ Property s m c+ property = do+ s <- qual con+ _ <- separator+ m <- var+ skipSpaces+ c <- constraint+ pure $ Property s m c - extension = do- let prefix = "VK_"- _ <- string prefix- e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_'))- skipSpaces- v <- optional word- pure $ Extension e v+ extension = do+ let prefix = "VK_"+ _ <- string prefix+ e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_'))+ skipSpaces+ v <- optional word+ pure $ Extension e v - request = do- skipSpaces- asum- [ p <* skipSpaces <* eof- | p <- [version, feature, property, extension]- ]- in- readP_to_S request >>> \case- -- xs -> pure $ Feature [] (show xs)- [(r, "")] -> pure r- _ -> Nothing+ request = do+ skipSpaces+ asum+ [ p <* skipSpaces <* eof+ | p <- [version, feature, property, extension]+ ]+ in readP_to_S request >>> \case+ -- xs -> pure $ Feature [] (show xs)+ [(r, "")] -> pure r+ _ -> Nothing {-# ANN parse ("HLint: ignore Use <$>" :: String) #-} ----------------------------------------------------------------@@ -279,11 +297,88 @@ filterComments :: String -> [String] filterComments = let bad = (("--" `isPrefixOf`) <||> ("#" `isPrefixOf`) <||> null)- in nubOrd . filter (not . bad) . fmap (dropWhile isSpace) . lines+ in nubOrd . filter (not . bad) . fmap strip . lines +strip :: String -> String+strip = dropWhile isSpace . dropWhileEnd isSpace+ exps :: (String -> ExpQ) -> [String] -> ExpQ exps f = listE . fmap f (<||>) :: Applicative f => f Bool -> f Bool -> f Bool (<||>) = liftA2 (||) +----------------------------------------------------------------+-- TH Utils+----------------------------------------------------------------++explicitRecordSet+ :: Name+ -- ^ Type name+ -> Name+ -- ^ member name+ -> Type+ -- ^ member type+ -> ExpQ+ -- ^ new value+ -> ExpQ+explicitRecordSet s m t x = do+ (con, ns) <- overRecord s m t+ ns' <- traverse (traverse newName) ns+ let pats = either (const wildP) varP <$> ns'+ let apps = either (const x) varE <$> ns'+ [|\ $(conP con pats) -> $(foldl appE (conE con) apps)|]++explicitRecordGet+ :: Name+ -- ^ Type name+ -> Name+ -- ^ member name+ -> Type+ -- ^ member type+ -> ExpQ+explicitRecordGet s m t = do+ (con, ns) <- overRecord s m t+ x <- newName "x"+ let pats = either (const (varP x)) (const wildP) <$> ns+ [|\ $(conP con pats) -> $(varE x)|]++overRecord+ :: Name+ -- ^ Type name+ -> Name+ -- ^ member name+ -> Type+ -- ^ member type+ -> Q (Name, [Either Type String])+ -- ^ (Constructor, [Left var name, Right selected member type])+overRecord s (nameBase -> m) t = do+ reify s >>= \case+ TyConI (DataD _ _ _ _ [c] _) | RecC con vs <- c ->+ let ns = vs <&> \case+ (nameBase -> n, _bang, t') | n == m -> Left t'+ | otherwise -> Right n+ in case lefts ns of+ [] -> fail $ "Couldn't find member " <> show m <> " in " <> show s+ [t']+ | t == t'+ -> pure (con, ns)+ | otherwise+ -> fail+ $ "Member "+ <> show m+ <> " of "+ <> show s+ <> " has type "+ <> show t'+ <> " but we expected "+ <> show t+ _ ->+ fail+ $ "Found multiple members called"+ <> show m+ <> " in "+ <> show s+ <> " ...what?"+ _ ->+ fail $ show s <> " doesn't seem to be the type of a record constructor"
vulkan-utils.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: vulkan-utils-version: 0.5.9+version: 0.5.10 synopsis: Utils for the vulkan package category: Graphics homepage: https://github.com/expipiplus1/vulkan#readme