diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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` diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/src/Vulkan/Utils/Requirements/TH.hs b/src/Vulkan/Utils/Requirements/TH.hs --- a/src/Vulkan/Utils/Requirements/TH.hs +++ b/src/Vulkan/Utils/Requirements/TH.hs @@ -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" diff --git a/vulkan-utils.cabal b/vulkan-utils.cabal --- a/vulkan-utils.cabal +++ b/vulkan-utils.cabal @@ -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