diff --git a/genvulkan/src/VkXml/Sections.hs b/genvulkan/src/VkXml/Sections.hs index 4909fca2..4b5d6313 100644 --- a/genvulkan/src/VkXml/Sections.hs +++ b/genvulkan/src/VkXml/Sections.hs @@ -4,13 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE RecordWildCards #-} module VkXml.Sections ( parseVkXml - , VkXml (..), InOrder (..) + , VkXml (..) ) where import Control.Monad.State.Class @@ -21,9 +17,6 @@ import qualified Data.Map.Strict as Map import Data.Foldable (toList) import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq -import Data.Text (Text) -import Data.List (sort) -import Data.Semigroup import Data.XML.Types import Text.XML.Stream.Parse as Xml @@ -39,61 +32,49 @@ import VkXml.Sections.VendorIds -parseVkXml :: VkXmlParser m => Sink Event m (VkXml ()) +parseVkXml :: VkXmlParser m => Sink Event m VkXml parseVkXml = fmap fixVkXml . execStateC (VkXmlPartial mempty mempty mempty mempty - mempty mempty mempty mempty 0) + mempty mempty mempty) $ tagIgnoreAttrs "registry" parseAll where parseAll = do mr <- choose - [ tagIgnoreAttrs "comment" $ do - com <- content - modify' $ \v -> v - { gpComments = gpComments v |> inOrd (gpCurLength v) com - , gpCurLength = gpCurLength v + 1 - } + [ ignoreTreeContent "comment" , parseVendorIds >>= \case Nothing -> pure Nothing Just x -> fmap (const $ Just ()) . modify' $ \v -> v - { gpVendorIds = gpVendorIds v |> inOrd (gpCurLength v) x - , gpCurLength = gpCurLength v + 1 + { gpVendorIds = gpVendorIds v |> x } , parseTags >>= \case Nothing -> pure Nothing Just x -> fmap (const $ Just ()) . modify' $ \v -> v - { gpTags = gpTags v |> inOrd (gpCurLength v) x - , gpCurLength = gpCurLength v + 1 + { gpTags = gpTags v |> x } , parseTypes >>= \case Nothing -> pure Nothing Just x -> fmap (const $ Just ()) . modify' $ \v -> v - { gpTypes = gpTypes v |> inOrd (gpCurLength v) x - , gpCurLength = gpCurLength v + 1 + { gpTypes = gpTypes v |> x } , parseVkEnums >>= \case Nothing -> pure Nothing Just x -> fmap (const $ Just ()) . modify' $ \v -> v - { gpEnums = gpEnums v |> inOrd (gpCurLength v) x - , gpCurLength = gpCurLength v + 1 + { gpEnums = gpEnums v |> x } , parseCommands >>= \case Nothing -> pure Nothing Just x -> fmap (const $ Just ()) . modify' $ \v -> v - { gpCommands = gpCommands v |> inOrd (gpCurLength v) x - , gpCurLength = gpCurLength v + 1 + { gpCommands = gpCommands v |> x } , parseFeature >>= \case Nothing -> pure Nothing Just x -> fmap (const $ Just ()) . modify' $ \v -> v - { gpFeature = gpFeature v |> inOrd (gpCurLength v) x - , gpCurLength = gpCurLength v + 1 + { gpFeature = gpFeature v |> x } , parseExtensions >>= \case Nothing -> pure Nothing Just x -> fmap (const $ Just ()) . modify' $ \v -> v - { gpExtensions = gpExtensions v |> inOrd (gpCurLength v) x - , gpCurLength = gpCurLength v + 1 + { gpExtensions = gpExtensions v |> x } ] case mr of @@ -102,102 +83,53 @@ parseVkXml = fmap fixVkXml . execStateC -data InOrder a l = InOrder - { getOrder :: Int - , getMeta :: l - , unInorder :: a - } deriving (Eq, Show, Functor, Foldable, Traversable) - -inOrd :: Int -> a -> InOrder a () -inOrd i = InOrder i () - -ordAndMeta :: InOrder a l -> Arg Int l -ordAndMeta InOrder {..} = Arg getOrder getMeta - -fromArg :: Arg a b -> b -fromArg (Arg _ b) = b - -- | Contains all parsed content of vk.xml, -- hopefully, preserves ordering of original vk.xml. -- -- The data type is foldable and traversable functor -data VkXml l +data VkXml = VkXml - { globComments :: [InOrder Text l] - , globVendorIds :: InOrder VendorIds l - , globTags :: InOrder VkTags l - , globTypes :: InOrder VkTypes l - , globEnums :: Map (Maybe VkTypeName) (InOrder VkEnums l) - , globCommands :: InOrder VkCommands l - , globFeature :: InOrder VkFeature l - , globExtensions :: InOrder VkExtensions l - , globLength :: Int - } deriving (Show, Functor, Traversable) - -instance Foldable VkXml where - length = globLength - null = (0==) . globLength - toList VkXml {..} - = map fromArg - $ sort [ ordAndMeta globVendorIds - , ordAndMeta globTags - , ordAndMeta globTypes - , ordAndMeta globCommands - , ordAndMeta globFeature - , ordAndMeta globExtensions - ] - `mergeAsc` map ordAndMeta globComments - `mergeAsc` map ordAndMeta (toList globEnums) - foldr f i = foldr f i . toList - foldMap f = foldMap f . toList - - -mergeAsc :: [Arg Int a] -> [Arg Int a] -> [Arg Int a] -mergeAsc [] xs = xs -mergeAsc xs [] = xs -mergeAsc (x@(Arg i _):xs) (y@(Arg j _):ys) - | i <= j = x : mergeAsc xs (y:ys) - | otherwise = y : mergeAsc (x:xs) ys + { globVendorIds :: VendorIds + , globTags :: VkTags + , globTypes :: VkTypes + , globEnums :: Map (Maybe VkTypeName) VkEnums + , globCommands :: VkCommands + , globFeature :: VkFeature + , globExtensions :: VkExtensions + } deriving Show data VkXmlPartial = VkXmlPartial - { gpComments :: Seq (InOrder Text ()) - , gpVendorIds :: Seq (InOrder VendorIds ()) - , gpTags :: Seq (InOrder VkTags ()) - , gpTypes :: Seq (InOrder VkTypes ()) - , gpEnums :: Seq (InOrder VkEnums ()) - , gpCommands :: Seq (InOrder VkCommands ()) - , gpFeature :: Seq (InOrder VkFeature ()) - , gpExtensions :: Seq (InOrder VkExtensions ()) - , gpCurLength :: Int + { gpVendorIds :: Seq VendorIds + , gpTags :: Seq VkTags + , gpTypes :: Seq VkTypes + , gpEnums :: Seq VkEnums + , gpCommands :: Seq VkCommands + , gpFeature :: Seq VkFeature + , gpExtensions :: Seq VkExtensions } deriving Show fixVkXml :: VkXmlPartial - -> VkXml () + -> VkXml fixVkXml VkXmlPartial - { gpComments = pComments - , gpVendorIds = Seq.Empty Seq.:|> pVendorIds + { gpVendorIds = Seq.Empty Seq.:|> pVendorIds , gpTags = Seq.Empty Seq.:|> pTags , gpTypes = Seq.Empty Seq.:|> pTypes , gpEnums = pEnums , gpCommands = Seq.Empty Seq.:|> pCommands , gpFeature = Seq.Empty Seq.:|> pFeature , gpExtensions = Seq.Empty Seq.:|> pExtensions - , gpCurLength = curLength } = VkXml - { globComments = toList pComments - , globVendorIds = pVendorIds + { globVendorIds = pVendorIds , globTags = pTags , globTypes = pTypes , globEnums = Map.fromList - . map (\e -> ( _vkEnumsTypeName - $ unInorder e, e) + . map (\e -> ( _vkEnumsTypeName e, e) ) $ toList pEnums , globCommands = pCommands , globFeature = pFeature , globExtensions = pExtensions - , globLength = curLength } fixVkXml _ = error "Unexpected number of sections in vk.xml" diff --git a/genvulkan/src/Write.hs b/genvulkan/src/Write.hs index 69343f1a..8ca946cc 100644 --- a/genvulkan/src/Write.hs +++ b/genvulkan/src/Write.hs @@ -41,7 +41,7 @@ import Write.Types.Struct generateVkSource :: Path b Dir -> Path c File - -> VkXml () + -> VkXml -> IO () generateVkSource outputDir outCabalFile vkXml = do @@ -137,7 +137,7 @@ generateVkSource outputDir outCabalFile vkXml = do (_exportedNamesExts, classDeclsExts, eModules) <- aggregateExts exportedNamesCore ( L.sortOn (extNumber . attributes) - . extensions . unInorder . globExtensions $ vkXml) + . extensions . globExtensions $ vkXml) $ \gn ext -> do let eName = T.unpack . unVkExtensionName . extName $ attributes ext modName = "Graphics.Vulkan.Ext." <> eName diff --git a/genvulkan/src/Write/Commands.hs b/genvulkan/src/Write/Commands.hs index 95e60c04..7dc94194 100644 --- a/genvulkan/src/Write/Commands.hs +++ b/genvulkan/src/Write/Commands.hs @@ -31,13 +31,13 @@ genBaseCommands = do let featureComms = Set.fromList . join . map requireComms - . reqList . unInorder $ globFeature vkXml + . reqList $ globFeature vkXml extComms = Set.fromList - $ extensions (unInorder $ globExtensions vkXml) + $ extensions (globExtensions vkXml) >>= extRequires >>= requireComms excludedComms = Set.union featureComms extComms - forM_ (commands . unInorder $ globCommands vkXml) $ \c -> + forM_ (commands $ globCommands vkXml) $ \c -> if (name :: VkCommand -> VkCommandName) c `Set.member` excludedComms then pure () else genCommand c diff --git a/genvulkan/src/Write/Extension.hs b/genvulkan/src/Write/Extension.hs index 37216036..47d60f59 100644 --- a/genvulkan/src/Write/Extension.hs +++ b/genvulkan/src/Write/Extension.hs @@ -28,13 +28,13 @@ genExtension :: Monad m => VkExtension -> ModuleWriter m (ClassDeclarations, May genExtension (VkExtension VkExtAttrs{..} ereqs) = do curlvl <- getCurrentSecLvl vkXml <- ask - let VkFeature {..} = unInorder $ globFeature vkXml + let VkFeature {..} = globFeature vkXml tps = Map.fromList . map (\t -> ((Ts.name :: VkType -> VkTypeName) t, t)) - . items . types . unInorder $ globTypes vkXml + . items . types $ globTypes vkXml cmds = Map.fromList . map (\c -> ((Cs.name :: VkCommand -> VkCommandName) c, c)) - . commands . unInorder $ globCommands vkXml + . commands $ globCommands vkXml writeSection curlvl $ "Vulkan extension: @" <> unVkExtensionName extName <> "@" <:> ("supported: @" <> extSupported <> "@") <:> maybe mempty (\s -> "contact: @" <> s <> "@") extContact diff --git a/genvulkan/src/Write/Feature.hs b/genvulkan/src/Write/Feature.hs index b53fc7db..17d3a108 100644 --- a/genvulkan/src/Write/Feature.hs +++ b/genvulkan/src/Write/Feature.hs @@ -31,13 +31,13 @@ genFeature :: Monad m => ModuleWriter m ClassDeclarations genFeature = do curlvl <- getCurrentSecLvl vkXml <- ask - let VkFeature {..} = unInorder $ globFeature vkXml + let VkFeature {..} = globFeature vkXml tps = Map.fromList . map (\t -> ((Ts.name :: VkType -> VkTypeName) t, t)) - . items . types . unInorder $ globTypes vkXml + . items . types $ globTypes vkXml cmds = Map.fromList . map (\c -> ((Cs.name :: VkCommand -> VkCommandName) c, c)) - . commands . unInorder $ globCommands vkXml + . commands $ globCommands vkXml -- ens = Map.fromList -- . map (\e -> (_vkEnumName e, e)) -- $ Map.elems (globEnums vkXml) >>= items . _vkEnumsMembers . unInorder diff --git a/genvulkan/src/Write/ModuleWriter.hs b/genvulkan/src/Write/ModuleWriter.hs index 91646603..0c575083 100644 --- a/genvulkan/src/Write/ModuleWriter.hs +++ b/genvulkan/src/Write/ModuleWriter.hs @@ -202,14 +202,14 @@ data ModuleWriting newtype ModuleWriter m a = ModuleWriter - { unModuleWriter :: RWST (VkXml ()) () ModuleWriting m a + { unModuleWriter :: RWST VkXml () ModuleWriting m a } deriving (Functor, Applicative, Monad, MonadFix, MonadFail, MonadIO - , Alternative, MonadPlus, MonadReader (VkXml ()) + , Alternative, MonadPlus, MonadReader VkXml , MFunctor, MonadTrans) runModuleWriter :: Functor m - => VkXml () + => VkXml -> String -- ^ module name -> GlobalNames -> ModuleWriter m a -> m (a, ModuleWriting) @@ -592,6 +592,6 @@ vkRegistryLink :: Monad m vkRegistryLink tname = do vkXml <- ask pure $ " Feature.number (unInorder $ globFeature vkXml) + <> Feature.number (globFeature vkXml) <> "/man/html/" <> tname <> ".html " <> tname <> " registry at www.khronos.org>" diff --git a/genvulkan/src/Write/Types.hs b/genvulkan/src/Write/Types.hs index 0e39c4bc..aaa52a5f 100644 --- a/genvulkan/src/Write/Types.hs +++ b/genvulkan/src/Write/Types.hs @@ -45,7 +45,7 @@ genBaseTypes' = do writeSection glvl "Types and enumerations" pushSecLvl $ \curlvl -> foldSectionsWithComments (fItem curlvl) fLast - (types . unInorder $ globTypes vkXml) + (types $ globTypes vkXml) where fItem curlvl cs t = do oldcat <- lift State.get @@ -85,14 +85,14 @@ genBaseStructs = do let featureTypes = Set.fromList . join . map requireTypes - . reqList . unInorder $ globFeature vkXml + . reqList $ globFeature vkXml extTypes = Set.fromList - $ extensions (unInorder $ globExtensions vkXml) + $ extensions (globExtensions vkXml) >>= extRequires >>= requireTypes excludedTypes = Set.union featureTypes extTypes fmap mconcat - $ forM (items . types . unInorder $ globTypes vkXml) $ \t -> + $ forM (items . types $ globTypes vkXml) $ \t -> if (name :: VkType -> VkTypeName) t `Set.member` excludedTypes then pure mempty else case vkTypeCat t of diff --git a/genvulkan/src/Write/Types/Enum.hs b/genvulkan/src/Write/Types/Enum.hs index 7a957da7..396eee38 100644 --- a/genvulkan/src/Write/Types/Enum.hs +++ b/genvulkan/src/Write/Types/Enum.hs @@ -35,12 +35,12 @@ genApiConstants = do writeSection glvl "API Constants" vk <- ask pushSecLvl . const $ mapM_ genEnums - (unInorder <$> Map.lookup Nothing (globEnums vk)) + (Map.lookup Nothing (globEnums vk)) -- | Lookup an enum in vk.xml and generate code for it genEnum :: Monad m => VkType -> ModuleWriter m () -genEnum t = ask >>= \vk -> case unInorder <$> Map.lookup (Just tname) (globEnums vk) of +genEnum t = ask >>= \vk -> case Map.lookup (Just tname) (globEnums vk) of Nothing -> genAlias t Just e -> genEnums e where