Generate pedantically

generate-new/khronos-spec/Khronos/AssignModules.hs

@@ -70,11 +70,11 @@ assignModules spec rs = do
   --
   -- Check that everything is exported
   --
-  unexportedNames <- unexportedNames spec
+  unexported <- unexportedNames spec
   forV_ indexed $ \(i, re) -> case IntMap.lookup i exports of
     Nothing -> do
       let exportedNames = exportName <$> toList (reExports re)
-      forV_ (List.nubOrd exportedNames List.\\ unexportedNames)
+      forV_ (List.nubOrd exportedNames List.\\ unexported)
         $ \n -> throw $ show n <> " is not exported from any module"
     Just _ -> pure ()
 
@@ -120,9 +120,9 @@ assignModules spec rs = do
     declaringRenderElements   <- traverseV lookupRe (fromList (Set.toList is))
     reexportingRenderElements <- case Map.lookup modname reexportingMap of
       Nothing -> pure mempty
-      Just is -> do
+      Just found -> do
         res <-
-          filter (getAll . reReexportable) <$> forV (Set.toList is) lookupRe
+          filter (getAll . reReexportable) <$> forV (Set.toList found) lookupRe
         pure
           $   reexportingRenderElement
           .   Data.Set.fromList
@@ -355,7 +355,7 @@ assign getExporter rel closedRel Spec {..} rs@RenderedSpec {..} = do
   -- belong to that later extension. This prevents cycles like:
   --   VK_EXT_shader_object (483) claiming vkCmdSetDepthClampRangeEXT
   --   before VK_EXT_depth_clamp_control (583) can.
-  forFeaturesAndExtensions $ \_ modname mExtNum ReqDeps {..} Require{rDepends, rTypeNames, rCommandNames, rEnumValueNames} ->
+  forFeaturesAndExtensions $ \_ modname mExtNum ReqDeps {..} Require{rDepends, rTypeNames} ->
     case mExtNum of
       Nothing -> -- Feature: export everything
         forV_ directExporters $ export modname

generate-new/khronos-spec/Khronos/SPIRVElements.hs

@@ -272,21 +272,21 @@ minVersionAndExtensionsReqs rs = do
       v
       [ "RequireInstanceExtension" <> braceAssignmentList
           [ ("instanceExtensionLayerName" , "Nothing")
-          , ("instanceExtensionName"      , e)
-          , ("instanceExtensionMinVersion", v)
+          , ("instanceExtensionName"      , en)
+          , ("instanceExtensionMinVersion", ver)
           ]
-      | (e, v) <- instanceExtensions
+      | (en, ver) <- instanceExtensions
       ]
     , maybe
       id
       ((:) . snd)
       v
       [ "RequireDeviceExtension" <> braceAssignmentList
           [ ("deviceExtensionLayerName" , "Nothing")
-          , ("deviceExtensionName"      , e)
-          , ("deviceExtensionMinVersion", v)
+          , ("deviceExtensionName"      , en)
+          , ("deviceExtensionMinVersion", ver)
           ]
-      | (e, v) <- deviceExtensions
+      | (en, ver) <- deviceExtensions
       ]
     )
 

generate-new/khronos-spec/Khronos/Versions/OpenXR.hs

@@ -38,14 +38,14 @@ currentVersion (XrVersion ma mi pa) = genRe "current version" $ do
   RenderParams {..} <- input
   tellExplicitModule =<< mkModuleName ["Version"]
   let pat         = mkPatternName "XR_CURRENT_API_VERSION"
-      makeVersion = mkPatternName "XR_MAKE_VERSION"
+      makeVersionN = mkPatternName "XR_MAKE_VERSION"
       ver         = mkTyName "XrVersion"
-  tellImport makeVersion
+  tellImport makeVersionN
   tellImport ver
   tellExport (EPat pat)
   tellDoc [qqi|
     pattern {pat} :: {ver}
-    pattern {pat} = {makeVersion} {ma} {mi} {pa}
+    pattern {pat} = {makeVersionN} {ma} {mi} {pa}
   |]
 
 

generate-new/src/Bespoke.hs

@@ -124,12 +124,12 @@ assignBespokeModules
   => t RenderElement
   -> Sem r (t RenderElement)
 assignBespokeModules es = do
-  bespokeModules <- bespokeModules
+  mods <- bespokeModules
   forV es $ \case
     r@RenderElement {..}
       | exports <- fmap exportName . toList $ reExports
       , bespokeMods <-
-        List.nubOrd . mapMaybe (`List.lookup` bespokeModules) $ exports
+        List.nubOrd . mapMaybe (`List.lookup` mods) $ exports
       -> case bespokeMods of
         []  -> pure r
         [x] -> case reExplicitModule of
@@ -401,7 +401,7 @@ difficultLengths =
               addrRef
               (Ptr Const (Ptr Const (TypeName "VkSampleMask")))
             vecPeek <- renderSubStmtsIO $ do
-              addrRef          <- pureStmt (AddrDoc ptr)
+              addrRef'          <- pureStmt (AddrDoc ptr)
               ValueDoc samples <- useViaName "rasterizationSamples"
               let sampleTy = mkTyName "VkSampleCountFlagBits"
                   sampleCon =
@@ -422,7 +422,7 @@ difficultLengths =
               -- TODO: pass Nullable here and don't reimplement that logic
               vectorPeekWithLenRef @a "sampleMask"
                                       (Normal (TypeName "VkSampleMask"))
-                                      addrRef
+                                      addrRef'
                                       (TypeName "VkSampleMask")
                                       mempty
                                       len
@@ -525,10 +525,9 @@ difficultLengths =
             tellImport 'castPtr
             tellImport ''Word32
             tellImport ''CChar
-            let castPtr = "castPtr @Word32 @CChar" <+> ptr
             tellImport 'BS.packCStringLen
             pure . IOAction . ValueDoc $ "packCStringLen" <+> align (tupled
-              [castPtr, bytes])
+              ["castPtr @Word32 @CChar" <+> ptr, bytes])
         }
       _ -> Nothing
     _ -> const Nothing
@@ -600,10 +599,9 @@ difficultLengths =
                 tellImport 'castPtr
                 tellImport ''Word8
                 tellImport ''CChar
-                let castPtr = "castPtr @Word8 @CChar" <+> ptr
                 tellImport 'BS.packCStringLen
                 pure . IOAction . ValueDoc $ "packCStringLen" <+> align (tupled
-                  [castPtr, bytes])
+                  ["castPtr @Word8 @CChar" <+> ptr, bytes])
             }
         _ -> Nothing
     _ -> const Nothing
@@ -635,39 +633,38 @@ bitfields = BespokeScheme $ \case
     -> Int
     -> Ref s AddrDoc
     -> Stmt s r (Ref s ValueDoc)
-  peekBitfield name ty bitSize bitShift addr = do
+  peekBitfield cName ty szBits bitShift addr = do
     tyH     <- cToHsType DoNotPreserve ty
-    base    <- storablePeek name addr (Ptr Const ty)
+    base    <- storablePeek cName addr (Ptr Const ty)
     shifted <- if bitShift == 0
       then pure base
       else stmt Nothing Nothing $ do
-        ValueDoc base <- use base
+        ValueDoc base' <- use base
         tellImport (mkName "Data.Bits.shiftR")
         pure . Pure InlineOnce . ValueDoc $ parens
-          (base <+> "`shiftR`" <+> viaShow bitShift)
-    masked <- if bitSize == 32
+          (base' <+> "`shiftR`" <+> viaShow bitShift)
+    masked <- if szBits == 32
       then pure shifted
       else stmt Nothing Nothing $ do
-        ValueDoc shifted <- use shifted
+        ValueDoc shifted' <- use shifted
         tellImport (mkNameG_v "base" "Data.Bits" ".&.")
         tellImport 'coerce
         let mask = "coerce @Word32 0x"
-              <> pretty (showHex ((1 `shiftL` bitSize :: Int) - 1) "")
-        pure . Pure InlineOnce . ValueDoc $ parens (shifted <+> ".&." <+> mask)
-    stmt (Just tyH) (Just (unCName name)) $ do
-      masked <- use masked
-      pure . Pure NeverInline $ masked
+              <> pretty (showHex ((1 `shiftL` szBits :: Int) - 1) "")
+        pure . Pure InlineOnce . ValueDoc $ parens (shifted' <+> ".&." <+> mask)
+    stmt (Just tyH) (Just (unCName cName)) $
+      Pure NeverInline <$> use masked
 
   bitfieldSlave :: Marshalable a => Int -> a -> MarshalScheme a
   bitfieldSlave bitShift = \case
     p
-      | Bitfield ty bitSize <- type' p -> Custom CustomScheme
+      | Bitfield ty szBits <- type' p -> Custom CustomScheme
         { csName       = "bitfield slave " <> unCName (name p)
         , csZero       = Just "zero"
         , csZeroIsZero = True
         , csType       = cToHsType DoNotPreserve ty
         , csDirectPoke = NoPoke
-        , csPeek       = peekBitfield (name p) ty bitSize bitShift
+        , csPeek       = peekBitfield (name p) ty szBits bitShift
         }
       | otherwise -> error "bitfield slave type isn't a bitfield "
 
@@ -1210,19 +1207,6 @@ directfb = [voidData "IDirectFB", voidData "IDirectFBSurface"]
 screen :: HasRenderParams r => [Sem r RenderElement]
 screen = [voidData "_screen_window", voidData "_screen_context", voidData "_screen_buffer"]
 
-nvscisyncUnsized :: HasRenderParams r => [Sem r RenderElement]
-nvscisyncUnsized = [voidData "NvSciSyncFence"]
-
-nvscisync :: HasRenderParams r => [BespokeAlias r]
-nvscisync = [ alias (APtr ''()) "NvSciSyncAttrList"
-            , alias (APtr ''()) "NvSciSyncObj"
-            ]
-
-nvscibuf :: HasRenderParams r => [BespokeAlias r]
-nvscibuf = [ alias (APtr ''()) "NvSciBufAttrList"
-           , alias (APtr ''()) "NvSciBufObj"
-           ]
-
 ----------------------------------------------------------------
 -- OpenXR platform stuff
 ----------------------------------------------------------------

generate-new/src/Bespoke/MarshalParams.hs

@@ -18,7 +18,7 @@ import           Spec.Parse
 
 marshalParams :: KnownSpecFlavor t => Spec t -> Sem r MarshalParams
 marshalParams spec@Spec {..} = do
-  bespokeSchemes <- bespokeSchemes spec
+  schemas <- bespokeSchemes spec
   let
     aliasMap :: Map.HashMap CName CName
     aliasMap = fromList [ (aName, aTarget) | Alias {..} <- toList specAliases ]
@@ -73,7 +73,7 @@ marshalParams spec@Spec {..} = do
     , isPassAsPointerType = isPassAsPointerType'
     , isForeignStruct     = isForeignStruct'
     , getBespokeScheme    = \p a ->
-      asum . fmap (\(BespokeScheme f) -> f p a) $ bespokeSchemes
+      asum $ fmap (\(BespokeScheme f) -> f p a) schemas
     }
 
 ----------------------------------------------------------------

generate-new/src/Bespoke/Utils.hs

@@ -19,7 +19,6 @@ import qualified Data.Vector.Generic           as VG
 import           Foreign.Marshal.Array
 import           Foreign.Marshal.Utils
 import           Foreign.Storable
-import           GHC.TypeNats
 
 import           Error
 import           Foreign.Marshal.Alloc          ( callocBytes )
@@ -176,4 +175,3 @@ marshalUtils = genRe "marshal utils" $ do
     advancePtrBytes :: Ptr a -> Int -> Ptr a
     advancePtrBytes = plusPtr
   |]
-

generate-new/src/Documentation.hs

@@ -52,10 +52,10 @@ docBookToDocumentation
   -> Text
   -- ^ The documentee name
   -> Either Text [Documentation]
-docBookToDocumentation specFlavor db name = do
+docBookToDocumentation sf db name = do
   let readerOptions = def
   pandoc <- first show $ runPure (readDocBook readerOptions db)
-  let prefix = case specFlavor of
+  let prefix = case sf of
         SpecVk -> "VK_"
         SpecXr -> "XR_"
 

generate-new/src/Documentation/All.hs

@@ -36,7 +36,7 @@ loadAllDocumentation
   -- ^ Directory where the documentation ".txt" or ".adoc" (asciidoc) files are
   -- located
   -> IO (Documentee -> Maybe Documentation)
-loadAllDocumentation specFlavor extensions vkDocs manDir = do
+loadAllDocumentation sf extensions vkDocs manDir = do
   let notDocs = ["apispec.txt", "copyright-ccby.txt", "footer.txt"]
   allDocs <-
     filter ((`notElem` notDocs) . takeFileName)
@@ -53,7 +53,7 @@ loadAllDocumentation specFlavor extensions vkDocs manDir = do
     partitionEithers
       <$> withProgress
             numDocumentationThreads
-            (runExceptT . loadDocumentation specFlavor extensions vkDocs)
+            (runExceptT . loadDocumentation sf extensions vkDocs)
             allDocs
   unless (null errors) $ do
     sayErr "Errors while loading documentation:"
@@ -71,13 +71,13 @@ loadDocumentation
   -> FilePath
   -- ^ The asciidoc .txt file to load
   -> ExceptT Text IO [Documentation]
-loadDocumentation specFlavor extensions vkDocs doc = do
-  docbook <- ExceptT $ manTxtToDocbook specFlavor extensions vkDocs doc
+loadDocumentation sf extensions vkDocs doc = do
+  docbook <- ExceptT $ manTxtToDocbook sf extensions vkDocs doc
   let name = takeBaseName doc
   withExceptT (("Error while parsing documentation for" <+> show doc) <+>)
     . ExceptT
     . pure
-    $ docBookToDocumentation specFlavor docbook (T.pack name)
+    $ docBookToDocumentation sf docbook (T.pack name)
 
 ----------------------------------------------------------------
 -- Utils

generate-new/src/Documentation/RunAsciiDoctor.hs

@@ -34,9 +34,9 @@ manTxtToDocbook
   -- ^ The path to the man page to translate
   -> IO (Either Text Text)
   -- ^ Either an error if something went wrong, or the docbook xml
-manTxtToDocbook specFlavor extensions vkPath manTxt =
+manTxtToDocbook sf extensions vkPath manTxt =
   fmap (T.toStrict . asciidoctor4076 . asciidoctor4075 . fixupDocbookOutput)
-    <$> asciidoctor specFlavor extensions vkPath manTxt
+    <$> asciidoctor sf extensions vkPath manTxt
 
 asciidoctor
   :: SpecFlavor
@@ -47,7 +47,7 @@ asciidoctor
   -> FilePath
   -- ^ The path to the man page to translate
   -> IO (Either Text TL.Text)
-asciidoctor specFlavor extensions vkPathRelative manTxt = do
+asciidoctor sf extensions vkPathRelative manTxt = do
   vkPath <- makeAbsolute vkPathRelative
   let
     asciidoctorPath = "asciidoctor"
@@ -76,7 +76,7 @@ asciidoctor specFlavor extensions vkPathRelative manTxt = do
       ]
 
     noteOpts = []
-    adocExts = case specFlavor of
+    adocExts = case sf of
       SpecVk ->
         [ "-I"
         , vkPath </> "gen"

generate-new/src/Marshal/Scheme.hs

@@ -1,3 +1,5 @@
+{-# language NamedFieldPuns #-}
+
 module Marshal.Scheme where
 
 import Data.Vector.Extra
@@ -189,17 +191,17 @@ instance Ord (CustomSchemeElided a) where
   compare = compare `on` cseName
 
 instance P.Show (CustomScheme a) where
-  showsPrec d (CustomScheme name _ _ _ _ _) =
+  showsPrec d CustomScheme{csName} =
     P.showParen (d > 10) $
       P.showString "CustomScheme "
-        . P.showsPrec 11 name
+        . P.showsPrec 11 csName
         . P.showString " _ _ _ _"
 
 instance P.Show (CustomSchemeElided a) where
-  showsPrec d (CustomSchemeElided name _ _) =
+  showsPrec d CustomSchemeElided{cseName} =
     P.showParen (d > 10) $
       P.showString "CustomSchemeElided "
-        . P.showsPrec 11 name
+        . P.showsPrec 11 cseName
         . P.showString " _ _"
 
 type ND r a =
@@ -543,10 +545,10 @@ dropPtrToStruct :: (HasMarshalParams r, HasSpecInfo r) => CType -> Sem r CType
 dropPtrToStruct t = do
   MarshalParams{..} <- input
   let stripConstPtr = \case
-        Ptr Const t -> stripConstPtr t
-        t -> t
+        Ptr Const t' -> stripConstPtr t'
+        t' -> t'
   case stripConstPtr t of
-    t | isForeignStruct t -> pure t
+    t' | isForeignStruct t' -> pure t'
     TypeName n ->
       (isJust <$> getStruct n) <||> (isJust <$> getUnion n) <&> \case
         True -> TypeName n

generate-new/src/Render/Aggregate.hs

@@ -21,7 +21,7 @@ mergeElements
   => [(ModName, Vector RenderElement)]
   -> Sem r [Segment ModName RenderElement]
 mergeElements ss = do
-  noAggregateModules <- noAggregateModules
+  mods <- noAggregateModules
   let unpackedSegments = [ (m, rs) | (m, rs) <- ss, not (V.null rs) ] -- Don't write empty segments
       initialModNames  = nubOrd . fmap fst $ unpackedSegments
       allModNames      = nubOrd
@@ -37,7 +37,7 @@ mergeElements ss = do
           $ m
         ]
 
-      allReexportedModNames = allModNames \\ noAggregateModules
+      allReexportedModNames = allModNames \\ mods
       aggregates            = makeAggregateRenderElements allReexportedModNames
 
       -- Merge segments with the same module