[Git][ghc/ghc][wip/soulomoon/suggest-UnliftedNewtypes-unlifted-data-family-25593] tidy up

[Patrick (@soulomoon)]

Patrick pushed to branch wip/soulomoon/suggest-UnliftedNewtypes-unlifted-data-family-25593 at Glasgow Haskell Compiler / GHC


Commits:
06dcb99b by Patrick at 2025-01-08T11:34:17+08:00
tidy up

- - - - -


1 changed file:

- compiler/GHC/Tc/TyCl/Instance.hs


Changes:

=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -715,10 +715,9 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
           -- Do /not/ check that the number of patterns = tyConArity fam_tc
           -- See [Arity of data families] in GHC.Core.FamInstEnv
        ; skol_info <- mkSkolemInfo FamInstSkol
-       ; let new_or_data = dataDefnConsNewOrData hs_cons
        ; (qtvs, non_user_tvs, pats, tc_res_kind, stupid_theta)
              <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity
-                                    hs_ctxt hs_pats m_ksig hs_cons new_or_data
+                                    hs_ctxt hs_pats m_ksig hs_cons
 
        -- Eta-reduce the axiom if possible
        -- Quite tricky: see Note [Implementing eta reduction for data families]
@@ -743,7 +742,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env
        --     we did it before the "extra" tvs from etaExpandAlgTyCon
        --     would always be eta-reduced
        --
-       ; let flav = newOrDataToFlavour new_or_data
+       ; let flav = newOrDataToFlavour $ dataDefnConsNewOrData hs_cons
        ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind
 
        -- Check the result kind; it may come from a user-written signature.
@@ -919,7 +918,6 @@ tcDataFamInstHeader
     :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn
     -> LexicalFixity -> Maybe (LHsContext GhcRn)
     -> HsFamEqnPats GhcRn -> Maybe (LHsKind GhcRn) -> DataDefnCons (LConDecl GhcRn)
-    -> NewOrData
     -> TcM ([TcTyVar], TyVarSet, [TcType], TcKind, TcThetaType)
          -- All skolem TcTyVars, all zonked so it's clear what the free vars are
 -- The "header" of a data family instance is the part other than
@@ -927,7 +925,7 @@ tcDataFamInstHeader
 --    e.g.  data instance D [a] :: * -> * where ...
 -- Here the "header" is the bit before the "where"
 tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
-                    hs_ctxt hs_pats m_ksig hs_cons new_or_data
+                    hs_ctxt hs_pats m_ksig hs_cons
   = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)
        ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))
             <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $
@@ -943,18 +941,18 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
                   -- with its parent class
                   ; addConsistencyConstraints mb_clsinfo lhs_ty
 
-                  -- Add constraints from the result signature
-                  ; res_kind <- tc_kind_sig m_ksig
 
                   -- Add constraints from the data constructors
                   -- Fix #25611
                   -- See Note [Kind inference for data family instances]
-                  ; when isH98orNewType $ kcConDecls new_or_data res_kind hs_cons
+                  ; when isH98orNewType $ kcConDecls lhs_applied_kind hs_cons
 
                   -- Check that the result kind of the TyCon applied to its args
                   -- is compatible with the explicit signature (or Type, if there
                   -- is none)
                   ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats
+                  -- Add constraints from the result signature
+                  ; res_kind <- tc_kind_sig m_ksig
                   ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind
 
                   ; traceTc "tcDataFamInstHeader" $
@@ -1006,12 +1004,13 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
   where
     fam_name  = tyConName fam_tc
     data_ctxt = DataKindCtxt fam_name
+    new_or_data = dataDefnConsNewOrData hs_cons
     isH98orNewType = case hs_cons of
       NewTypeCon{} -> True
-      DataTypeCons _ cons -> isH98 cons
-    isH98 cons = flip any (unLoc <$> cons) $ \case
-      ConDeclH98{} -> True
-      _ -> False
+      DataTypeCons _ cons -> all isH98 cons
+    isH98 (L _ (ConDeclH98 {})) = True
+    isH98 _ = False
+
 
     -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, families (2),
     -- and Note [Implementation of UnliftedDatatypes].



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06dcb99b6ec47f78ef9b3b2cdf309050d8639c0c
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/20250107/090b0380/attachment-0001.html>