Reduce possible overhead in Extends solver

generate-new/src/Render/Spec/Extends.hs

@@ -51,6 +51,7 @@ typeFamily
   -> Sem r ()
 typeFamily Spec {..} = do
   RenderParams {..} <- input
+  tellExport (EType (TyConName "ExtendsWith"))
   tellExport (EType (TyConName "Extends"))
   tellImport ''Relude.Type
   tellImport ''TypeError
@@ -68,15 +69,15 @@ typeFamily Spec {..} = do
           let pName = mkTyName parent
           tellSourceImport pName
           pTyDoc <- renderTypeHighPrecSource (ConT (typeName pName))
-          pure (parent, "Extends" <+> pTyDoc <+> cTyDoc <+> "= ()")
+          pure (parent, "ExtendsWith" <+> pTyDoc <+> cTyDoc <+> "= '()")
   tellDoc
-    $ "type family Extends (a :: [Type] -> Type) (b :: Type) :: Constraint where"
+    $ "type family ExtendsWith (a :: [Type] -> Type) (b :: Type) :: () where"
     <> line
     <> indent
          2
          (vsep
            (cases
-           <> [ "Extends a b = TypeError (ShowType a :<>: Text \" is not extended by \" :<>: ShowType b)"
+           <> [ "ExtendsWith a b = TypeError (ShowType a :<>: Text \" is not extended by \" :<>: ShowType b)"
               ]
            )
          )
@@ -102,6 +103,7 @@ classes Spec {..} = do
   tellExport (EClass (TyConName "Extensible"))
   tellExport (EPat (ConName "::&"))
   tellExport (EPat (ConName ":&"))
+  tellImport (TyConName "ExtendsWith")
   tellImport (TyConName "Extends")
   tellImportWithAll (TyConName "ToCStruct")
   tellImportWithAll (TyConName "FromCStruct")
@@ -186,10 +188,20 @@ classes Spec {..} = do
     tellDoc [qqi|
       class PeekChain (xs :: [Type])
       class PokeChain (xs :: [Type])
-      type family Extends (p :: [Type] -> Type) (x :: Type) :: Constraint where ..
+      type family ExtendsWith (p :: [Type] -> Type) (x :: Type) :: () where ..
+
+      -- | We don't really need constraint units produced by `ExtendsWith`, so this type
+      -- family will ensure that it would reduce and drop the result
+      --
+      -- That will result in less overhead because `Extendss` reduces into a single
+      -- contraint unit `()` instead of cons-list `((), ((), ()))` produced by `(,)`
+      type family ReportUnsolved (a :: ()) (b :: Constraint) :: Constraint where
+        ReportUnsolved '() b = b
+
       type family Extendss (p :: [Type] -> Type) (xs :: [Type]) :: Constraint where
         Extendss p '[]      = ()
-        Extendss p (x : xs) = (Extends p x, Extendss p xs)
+        Extendss p (x : xs) = ExtendsWith p x `ReportUnsolved` Extendss p xs
+      type Extends p a = ExtendsWith p a ~ '()
       type family Chain (xs :: [a]) = (r :: a) | r -> xs where
         Chain '[]    = ()
         Chain (x:xs) = (x, Chain xs)
@@ -362,9 +374,19 @@ classes Spec {..} = do
     infixr 7 :&
     \{-# complete (:&) #-}
 
+    -- | We don't really need constraint units produced by `ExtendsWith`, so this type
+    -- family will ensure that it would reduce and drop the result
+    --
+    -- That will result in less overhead because `Extendss` reduces into a single
+    -- contraint unit `()` instead of cons-list `((), ((), ()))` produced by `(,)`
+    type family ReportUnsolved (a :: ()) (b :: Constraint) :: Constraint where
+      ReportUnsolved '() b = b
+
     type family Extendss (p :: [Type] -> Type) (xs :: [Type]) :: Constraint where
       Extendss p '[]      = ()
-      Extendss p (x : xs) = (Extends p x, Extendss p xs)
+      Extendss p (x : xs) = ExtendsWith p x `ReportUnsolved` Extendss p xs
+
+    type Extends p a = ExtendsWith p a ~ '()
 
     class PokeChain es where
       withChain :: Chain es -> (Ptr (Chain es) -> IO a) -> IO a

openxr/openxr.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -186,6 +186,7 @@ library
       TypeSynonymInstances
       UndecidableInstances
       ViewPatterns
+      ConstraintKinds
   ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-missing-pattern-synonym-signatures -Wno-unused-imports -Wno-missing-signatures -Wno-partial-type-signatures
   extra-libraries:
       openxr_loader

openxr/package.yaml

@@ -105,3 +105,4 @@ default-extensions:
 - TypeSynonymInstances
 - UndecidableInstances
 - ViewPatterns
+- ConstraintKinds

openxr/src/OpenXR/CStruct/Extends.hs

@@ -2,6 +2,7 @@
 -- No documentation found for Chapter "Extends"
 module OpenXR.CStruct.Extends  ( BaseInStructure(..)
                                , BaseOutStructure(..)
+                               , ExtendsWith
                                , Extends
                                , PeekChain(..)
                                , PokeChain(..)
@@ -328,38 +329,38 @@ instance Zero BaseOutStructure where
            zero
 
 
-type family Extends (a :: [Type] -> Type) (b :: Type) :: Constraint where
-  Extends CompositionLayerBaseHeader CompositionLayerColorScaleBiasKHR = ()
-  Extends CompositionLayerProjectionView CompositionLayerDepthInfoKHR = ()
-  Extends FrameEndInfo SecondaryViewConfigurationFrameEndInfoMSFT = ()
-  Extends FrameState SecondaryViewConfigurationFrameStateMSFT = ()
-  Extends HandJointLocationsEXT HandJointVelocitiesEXT = ()
-  Extends HandTrackerCreateInfoEXT HandPoseTypeInfoMSFT = ()
-  Extends InstanceCreateInfo InstanceCreateInfoAndroidKHR = ()
-  Extends InstanceCreateInfo DebugUtilsMessengerCreateInfoEXT = ()
-  Extends InteractionProfileSuggestedBinding InteractionProfileAnalogThresholdVALVE = ()
-  Extends InteractionProfileSuggestedBinding BindingModificationsKHR = ()
-  Extends SessionBeginInfo SecondaryViewConfigurationSessionBeginInfoMSFT = ()
-  Extends SessionCreateInfo GraphicsBindingOpenGLWin32KHR = ()
-  Extends SessionCreateInfo GraphicsBindingOpenGLXlibKHR = ()
-  Extends SessionCreateInfo GraphicsBindingOpenGLXcbKHR = ()
-  Extends SessionCreateInfo GraphicsBindingOpenGLWaylandKHR = ()
-  Extends SessionCreateInfo GraphicsBindingD3D11KHR = ()
-  Extends SessionCreateInfo GraphicsBindingD3D12KHR = ()
-  Extends SessionCreateInfo GraphicsBindingOpenGLESAndroidKHR = ()
-  Extends SessionCreateInfo GraphicsBindingVulkanKHR = ()
-  Extends SessionCreateInfo SessionCreateInfoOverlayEXTX = ()
-  Extends SessionCreateInfo GraphicsBindingEGLMNDX = ()
-  Extends SessionCreateInfo HolographicWindowAttachmentMSFT = ()
-  Extends SpaceLocation SpaceVelocity = ()
-  Extends SpaceLocation EyeGazeSampleTimeEXT = ()
-  Extends SwapchainCreateInfo SecondaryViewConfigurationSwapchainCreateInfoMSFT = ()
-  Extends SystemProperties SystemEyeGazeInteractionPropertiesEXT = ()
-  Extends SystemProperties SystemHandTrackingPropertiesEXT = ()
-  Extends SystemProperties SystemHandTrackingMeshPropertiesMSFT = ()
-  Extends ViewConfigurationView ViewConfigurationDepthRangeEXT = ()
-  Extends ViewConfigurationView ViewConfigurationViewFovEPIC = ()
-  Extends a b = TypeError (ShowType a :<>: Text " is not extended by " :<>: ShowType b)
+type family ExtendsWith (a :: [Type] -> Type) (b :: Type) :: () where
+  ExtendsWith CompositionLayerBaseHeader CompositionLayerColorScaleBiasKHR = '()
+  ExtendsWith CompositionLayerProjectionView CompositionLayerDepthInfoKHR = '()
+  ExtendsWith FrameEndInfo SecondaryViewConfigurationFrameEndInfoMSFT = '()
+  ExtendsWith FrameState SecondaryViewConfigurationFrameStateMSFT = '()
+  ExtendsWith HandJointLocationsEXT HandJointVelocitiesEXT = '()
+  ExtendsWith HandTrackerCreateInfoEXT HandPoseTypeInfoMSFT = '()
+  ExtendsWith InstanceCreateInfo InstanceCreateInfoAndroidKHR = '()
+  ExtendsWith InstanceCreateInfo DebugUtilsMessengerCreateInfoEXT = '()
+  ExtendsWith InteractionProfileSuggestedBinding InteractionProfileAnalogThresholdVALVE = '()
+  ExtendsWith InteractionProfileSuggestedBinding BindingModificationsKHR = '()
+  ExtendsWith SessionBeginInfo SecondaryViewConfigurationSessionBeginInfoMSFT = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingOpenGLWin32KHR = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingOpenGLXlibKHR = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingOpenGLXcbKHR = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingOpenGLWaylandKHR = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingD3D11KHR = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingD3D12KHR = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingOpenGLESAndroidKHR = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingVulkanKHR = '()
+  ExtendsWith SessionCreateInfo SessionCreateInfoOverlayEXTX = '()
+  ExtendsWith SessionCreateInfo GraphicsBindingEGLMNDX = '()
+  ExtendsWith SessionCreateInfo HolographicWindowAttachmentMSFT = '()
+  ExtendsWith SpaceLocation SpaceVelocity = '()
+  ExtendsWith SpaceLocation EyeGazeSampleTimeEXT = '()
+  ExtendsWith SwapchainCreateInfo SecondaryViewConfigurationSwapchainCreateInfoMSFT = '()
+  ExtendsWith SystemProperties SystemEyeGazeInteractionPropertiesEXT = '()
+  ExtendsWith SystemProperties SystemHandTrackingPropertiesEXT = '()
+  ExtendsWith SystemProperties SystemHandTrackingMeshPropertiesMSFT = '()
+  ExtendsWith ViewConfigurationView ViewConfigurationDepthRangeEXT = '()
+  ExtendsWith ViewConfigurationView ViewConfigurationViewFovEPIC = '()
+  ExtendsWith a b = TypeError (ShowType a :<>: Text " is not extended by " :<>: ShowType b)
 
 data SomeStruct (a :: [Type] -> Type) where
   SomeStruct
@@ -583,9 +584,19 @@ pattern e :& es = (e, es)
 infixr 7 :&
 {-# complete (:&) #-}
 
+-- | We don't really need constraint units produced by `ExtendsWith`, so this type
+-- family will ensure that it would reduce and drop the result
+--
+-- That will result in less overhead because `Extendss` reduces into a single
+-- contraint unit `()` instead of cons-list `((), ((), ()))` produced by `(,)`
+type family ReportUnsolved (a :: ()) (b :: Constraint) :: Constraint where
+  ReportUnsolved '() b = b
+
 type family Extendss (p :: [Type] -> Type) (xs :: [Type]) :: Constraint where
   Extendss p '[]      = ()
-  Extendss p (x : xs) = (Extends p x, Extendss p xs)
+  Extendss p (x : xs) = ExtendsWith p x `ReportUnsolved` Extendss p xs
+
+type Extends p a = ExtendsWith p a ~ '()
 
 class PokeChain es where
   withChain :: Chain es -> (Ptr (Chain es) -> IO a) -> IO a

openxr/src/OpenXR/CStruct/Extends.hs-boot

@@ -31,10 +31,20 @@ instance FromCStruct BaseOutStructure
 
 class PeekChain (xs :: [Type])
 class PokeChain (xs :: [Type])
-type family Extends (p :: [Type] -> Type) (x :: Type) :: Constraint
+type family ExtendsWith (p :: [Type] -> Type) (x :: Type) :: () where ..
+
+-- | We don't really need constraint units produced by `ExtendsWith`, so this type
+-- family will ensure that it would reduce and drop the result
+--
+-- That will result in less overhead because `Extendss` reduces into a single
+-- contraint unit `()` instead of cons-list `((), ((), ()))` produced by `(,)`
+type family ReportUnsolved (a :: ()) (b :: Constraint) :: Constraint where
+  ReportUnsolved '() b = b
+
 type family Extendss (p :: [Type] -> Type) (xs :: [Type]) :: Constraint where
   Extendss p '[]      = ()
-  Extendss p (x : xs) = (Extends p x, Extendss p xs)
+  Extendss p (x : xs) = ExtendsWith p x `ReportUnsolved` Extendss p xs
+type Extends p a = ExtendsWith p a ~ '()
 type family Chain (xs :: [a]) = (r :: a) | r -> xs where
   Chain '[]    = ()
   Chain (x:xs) = (x, Chain xs)

package.yaml

@@ -125,3 +125,4 @@ default-extensions:
 - TypeSynonymInstances
 - UndecidableInstances
 - ViewPatterns
+- ConstraintKinds