Removed redundant InOrder type

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"

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

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

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

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

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 $ "<https://www.khronos.org/registry/vulkan/specs/"
-        <> Feature.number (unInorder $ globFeature vkXml)
+        <> Feature.number (globFeature vkXml)
         <> "/man/html/" <> tname <> ".html "
         <> tname <> " registry at www.khronos.org>"

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

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