[Git][ghc/ghc][wip/torsten.schmits/16468] Relax defaulting of RuntimeRep/Levity when printing

Torsten Schmits (@torsten.schmits) gitlab at gitlab.haskell.org
Thu Jun 22 13:30:34 UTC 2023 


Torsten Schmits pushed to branch wip/torsten.schmits/16468 at Glasgow Haskell Compiler / GHC


Commits:
8df99f79 by Torsten Schmits at 2023-06-22T15:30:21+02:00
Relax defaulting of RuntimeRep/Levity when printing

Fixes #16468

MR: !10702

Only default RuntimeRep to LiftedRep when variables are bound by the toplevel forall

- - - - -


5 changed files:

- compiler/GHC/Iface/Type.hs
- compiler/GHC/Types/Unique/DFM.hs
- + testsuite/tests/ghci/scripts/T16468.script
- + testsuite/tests/ghci/scripts/T16468.stdout
- testsuite/tests/ghci/scripts/all.T


Changes:

=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -987,7 +987,7 @@ ppr_ty ctxt_prec ty@(IfaceFunTy af w ty1 ty2)  -- Should be a visible argument
       | isVisibleFunArg af
       = (pprTypeArrow af wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2
     ppr_fun_tail wthis other_ty
-      = [pprTypeArrow af wthis <+> pprIfaceType other_ty]
+      = [pprTypeArrow af wthis <+> ppr_ty topPrec other_ty]
 
 ppr_ty ctxt_prec (IfaceAppTy t ts)
   = if_print_coercions
@@ -1097,28 +1097,29 @@ as they appear during kind-checking of "newtype T :: TYPE r where..."
 defaultIfaceTyVarsOfKind :: Bool -- ^ default 'RuntimeRep'/'Levity' variables?
                          -> Bool -- ^ default 'Multiplicity' variables?
                          -> IfaceType -> IfaceType
-defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty
+defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
   where
     go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables
+       -> Bool
        -> IfaceType
        -> IfaceType
-    go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)
+    go subs rank1 (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)
      | isInvisibleForAllTyFlag argf  -- Don't default *visible* quantification
                                 -- or we get the mess in #13963
-     , Just substituted_ty <- check_substitution var_kind
+     , Just substituted_ty <- check_substitution rank1 var_kind
       = let subs' = extendFsEnv subs var substituted_ty
             -- Record that we should replace it with LiftedRep/Lifted/Many,
             -- and recurse, discarding the forall
-        in go subs' ty
+        in go subs' rank1 ty
 
-    go subs (IfaceForAllTy bndr ty)
-      = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty)
+    go subs rank1 (IfaceForAllTy bndr ty)
+      = IfaceForAllTy (go_ifacebndr subs rank1 bndr) (go subs rank1 ty)
 
-    go subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of
+    go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of
       Just s -> s
       Nothing -> ty
 
-    go _ ty@(IfaceFreeTyVar tv)
+    go _ _ ty@(IfaceFreeTyVar tv)
       -- See Note [Defaulting RuntimeRep variables], about free vars
       | def_rep
       , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)
@@ -1138,47 +1139,49 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty
       | otherwise
       = ty
 
-    go subs (IfaceTyConApp tc tc_args)
-      = IfaceTyConApp tc (go_args subs tc_args)
+    go subs rank1 (IfaceTyConApp tc tc_args)
+      = IfaceTyConApp tc (go_args subs rank1 tc_args)
 
-    go subs (IfaceTupleTy sort is_prom tc_args)
-      = IfaceTupleTy sort is_prom (go_args subs tc_args)
+    go subs rank1 (IfaceTupleTy sort is_prom tc_args)
+      = IfaceTupleTy sort is_prom (go_args subs rank1 tc_args)
 
-    go subs (IfaceFunTy af w arg res)
-      = IfaceFunTy af (go subs w) (go subs arg) (go subs res)
+    go subs rank1 (IfaceFunTy af w arg res)
+      = IfaceFunTy af (go subs rank1 w) (go subs False arg) (go subs False res)
 
-    go subs (IfaceAppTy t ts)
-      = IfaceAppTy (go subs t) (go_args subs ts)
+    go subs rank1 (IfaceAppTy t ts)
+      = IfaceAppTy (go subs rank1 t) (go_args subs rank1 ts)
 
-    go subs (IfaceCastTy x co)
-      = IfaceCastTy (go subs x) co
+    go subs rank1 (IfaceCastTy x co)
+      = IfaceCastTy (go subs rank1 x) co
 
-    go _ ty@(IfaceLitTy {}) = ty
-    go _ ty@(IfaceCoercionTy {}) = ty
+    go _ _ ty@(IfaceLitTy {}) = ty
+    go _ _ ty@(IfaceCoercionTy {}) = ty
 
-    go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr
-    go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf)
-      = Bndr (IfaceIdBndr (w, n, go subs t)) argf
-    go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf)
-      = Bndr (IfaceTvBndr (n, go subs t)) argf
+    go_ifacebndr :: FastStringEnv IfaceType -> Bool -> IfaceForAllBndr -> IfaceForAllBndr
+    go_ifacebndr subs rank1 (Bndr (IfaceIdBndr (w, n, t)) argf)
+      = Bndr (IfaceIdBndr (w, n, go subs rank1 t)) argf
+    go_ifacebndr subs rank1 (Bndr (IfaceTvBndr (n, t)) argf)
+      = Bndr (IfaceTvBndr (n, go subs rank1 t)) argf
 
-    go_args :: FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs
-    go_args _ IA_Nil = IA_Nil
-    go_args subs (IA_Arg ty argf args)
-      = IA_Arg (go subs ty) argf (go_args subs args)
+    go_args :: FastStringEnv IfaceType -> Bool -> IfaceAppArgs -> IfaceAppArgs
+    go_args _ _ IA_Nil = IA_Nil
+    go_args subs rank1 (IA_Arg ty argf args)
+      = IA_Arg (go subs rank1 ty) argf (go_args subs rank1 args)
 
-    check_substitution :: IfaceType -> Maybe IfaceType
-    check_substitution (IfaceTyConApp tc _)
+    check_substitution :: Bool -> IfaceType -> Maybe IfaceType
+    check_substitution rank1 (IfaceTyConApp tc _)
         | def_rep
         , tc `ifaceTyConHasKey` runtimeRepTyConKey
+        , rank1
         = Just liftedRep_ty
         | def_rep
         , tc `ifaceTyConHasKey` levityTyConKey
+        , rank1
         = Just lifted_ty
         | def_mult
         , tc `ifaceTyConHasKey` multiplicityTyConKey
         = Just many_ty
-    check_substitution _ = Nothing
+    check_substitution _ _ = Nothing
 
 -- | The type ('BoxedRep 'Lifted), also known as LiftedRep.
 liftedRep_ty :: IfaceType
@@ -1367,7 +1370,7 @@ ppr_sigma show_forall ctxt_prec iface_ty
           -- Then it could handle both invisible and required binders, and
           -- splitIfaceReqForallTy wouldn't be necessary here.
     in ppr_iface_forall_part show_forall invis_tvs theta $
-       sep [pprIfaceForAll req_tvs, ppr tau']
+       sep [pprIfaceForAll req_tvs, ppr_ty topPrec tau']
 
 pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
 pprUserIfaceForAll tvs


=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -94,7 +94,7 @@ import qualified Data.IntSet as I
 -- order then `udfmToList` returns them in deterministic order.
 --
 -- There is an implementation cost: each element is given a serial number
--- as it is added, and `udfmToList` sorts it's result by this serial
+-- as it is added, and `udfmToList` sorts its result by this serial
 -- number. So you should only use `UniqDFM` if you need the deterministic
 -- property.
 --


=====================================
testsuite/tests/ghci/scripts/T16468.script
=====================================
@@ -0,0 +1,13 @@
+:set -XLinearTypes -XImpredicativeTypes
+import GHC.Types (RuntimeRep (..), Levity (..), TYPE, Type)
+import Data.Proxy
+f :: forall p. (forall (r :: RuntimeRep). Int -> p r) %1 -> p ('BoxedRep 'Lifted); f x = x 5
+:type f
+g :: forall p. Int -> forall (r :: RuntimeRep). p r; g _ = undefined
+:type g
+g' :: Int -> forall p (r :: RuntimeRep). p r; g' _ = undefined
+:type g'
+h :: Int -> forall (r :: RuntimeRep). TYPE r; h _ = undefined
+:type h
+i :: forall (r :: RuntimeRep). Int -> TYPE r; i _ = undefined
+:type i


=====================================
testsuite/tests/ghci/scripts/T16468.stdout
=====================================
@@ -0,0 +1,6 @@
+f :: (forall (r :: RuntimeRep). Int -> p r)
+     %1 -> p GHC.Types.LiftedRep
+g :: Int -> forall (r :: RuntimeRep). p r
+g' :: Int -> forall (p :: RuntimeRep -> *) (r :: RuntimeRep). p r
+h :: Int -> forall (r :: RuntimeRep). TYPE r
+i :: Int -> *


=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -375,3 +375,4 @@ test('T22695', normal, ghci_script, ['T22695.script'])
 test('T22817', normal, ghci_script, ['T22817.script'])
 test('T22908', normal, ghci_script, ['T22908.script'])
 test('T23062', normal, ghci_script, ['T23062.script'])
+test('T16468', normal, ghci_script, ['T16468.script'])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8df99f7928e81007645a54a638f9833cd35e2de9
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/20230622/51aca02e/attachment-0001.html>

More information about the ghc-commits mailing list