[Git][ghc/ghc][wip/T25281] More record selector safety

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC


Commits:
bcf3053e by Simon Peyton Jones at 2024-10-03T12:10:17+01:00
More record selector safety

- - - - -


3 changed files:

- compiler/GHC/Iface/Load.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs


Changes:

=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -70,6 +70,7 @@ import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Logger
+import GHC.Utils.Fingerprint( Fingerprint )
 
 import GHC.Settings.Constants
 
@@ -1186,13 +1187,15 @@ pprExport avail@(AvailTC n _) =
     pp_export names = braces (hsep (map ppr names))
 
 pprUsage :: Usage -> SDoc
-pprUsage usage at UsagePackageModule{}
-  = pprUsageImport usage usg_mod
-pprUsage usage at UsageHomeModule{}
-  = pprUsageImport usage (\u -> mkModule (usg_unit_id u) (usg_mod_name u)) $$
+pprUsage UsagePackageModule{ usg_mod = mod, usg_mod_hash = hash, usg_safe = safe }
+  = pprUsageImport mod hash safe
+pprUsage UsageHomeModule{ usg_unit_id = unit_id, usg_mod_name = mod_name
+                              , usg_mod_hash = hash, usg_safe = safe
+                              , usg_exports = exports, usg_entities = entities }
+  = pprUsageImport (mkModule unit_id mod_name) hash safe $$
     nest 2 (
-        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
-        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
+        maybe Outputable.empty (\v -> text "exports: " <> ppr v) exports $$
+        vcat [ ppr n <+> ppr v | (n,v) <- entities ]
         )
 pprUsage usage at UsageFile{}
   = hsep [text "addDependentFile",
@@ -1205,13 +1208,13 @@ pprUsage usage at UsageHomeModuleInterface{}
                                , ppr (usg_unit_id usage)
                                , ppr (usg_iface_hash usage)]
 
-pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
-pprUsageImport usage usg_mod'
-  = hsep [text "import", safe, ppr (usg_mod' usage),
-                       ppr (usg_mod_hash usage)]
+pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc
+pprUsageImport mod hash safe
+  = hsep [ text "import", pp_safe, ppr mod
+         , ppr hash ]
     where
-        safe | usg_safe usage = text "safe"
-             | otherwise      = text " -/ "
+        pp_safe | safe      = text "safe"
+                | otherwise = text " -/ "
 
 pprFixities :: [(OccName, Fixity)] -> SDoc
 pprFixities []    = Outputable.empty


=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -316,17 +316,12 @@ lHsQTyVarsToTypes tvs =
 restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
 restrictTo names (L loc decl) = L loc $ case decl of
   TyClD x d
-    | isDataDecl d ->
-        TyClD x (d{tcdDataDefn = restrictDataDefn names (tcdDataDefn d)})
+    | DataDecl { tcdDataDefn = dd } <- d
+    -> TyClD x (d {tcdDataDefn = restrictDataDefn names dd})
   TyClD x d
-    | isClassDecl d ->
-        TyClD
-          x
-          ( d
-              { tcdSigs = restrictDecls names (tcdSigs d)
-              , tcdATs = restrictATs names (tcdATs d)
-              }
-          )
+    | ClassDecl { tcdSigs = sigs, tcdATs = ats } <- d
+    -> TyClD x (d { tcdSigs = restrictDecls names sigs
+                  , tcdATs = restrictATs names ats } )
   _ -> decl
 
 restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn
@@ -561,13 +556,12 @@ instance Parent (ConDecl GhcRn) where
 
 instance Parent (TyClDecl GhcRn) where
   children d
-    | isDataDecl d =
-        map unLoc $
-          concatMap (toList . getConNames . unLoc) $
-            (dd_cons . tcdDataDefn) d
-    | isClassDecl d =
-        map (unLoc . fdLName . unLoc) (tcdATs d)
-          ++ [unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns]
+    | DataDecl { tcdDataDefn = dd } <- d
+    = map unLoc $
+      concatMap (toList . getConNames . unLoc) (dd_cons dd)
+    | ClassDecl{ tcdSigs = sigs, tcdATs = ats } <- d
+    = map (unLoc . fdLName . unLoc) ats
+      ++ [unLoc n | L _ (TypeSig _ ns _) <- sigs, n <- ns]
     | otherwise = []
 
 -- | A parent and its children
@@ -581,9 +575,9 @@ familyConDecl d = zip (toList $ unLoc <$> getConNames d) (repeat $ children d)
 -- child to its grand-children, recursively.
 families :: TyClDecl GhcRn -> [(Name, [Name])]
 families d
-  | isDataDecl d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d))
-  | isClassDecl d = [family d]
-  | otherwise = []
+  | DataDecl {}  <- d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d))
+  | ClassDecl {} <- d = [family d]
+  | otherwise         = []
 
 -- | A mapping from child to parent
 parentMap :: TyClDecl GhcRn -> [(Name, Name)]


=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -945,6 +945,7 @@ type instance XXFamilyDecl DocNameI = DataConCantHappen
 type instance XXTyClDecl DocNameI = DataConCantHappen
 
 type instance XHsWC DocNameI _ = NoExtField
+type instance XXHsWildCardBndrs DocNameI _ = DataConCantHappen
 
 type instance XHsOuterExplicit DocNameI _ = NoExtField
 type instance XHsOuterImplicit DocNameI = NoExtField
@@ -954,6 +955,8 @@ type instance XHsSig DocNameI = NoExtField
 type instance XXHsSigType DocNameI = DataConCantHappen
 
 type instance XHsQTvs DocNameI = NoExtField
+type instance XXLHsQTyVars DocNameI = DataConCantHappen
+
 type instance XConDeclField DocNameI = NoExtField
 type instance XXConDeclField DocNameI = DataConCantHappen
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcf3053e9197451aae7d55f61cb0ad0931339017

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcf3053e9197451aae7d55f61cb0ad0931339017
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241003/583000be/attachment-0001.html>