[Git][ghc/ghc][wip/T22194-flags] Wibble

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22194-flags at Glasgow Haskell Compiler / GHC


Commits:
3948dc03 by Simon Peyton Jones at 2023-03-31T08:11:41+01:00
Wibble

- - - - -


3 changed files:

- compiler/GHC/Tc/Solver.hs
- + testsuite/tests/typecheck/should_compile/T22194.hs
- testsuite/tests/typecheck/should_compile/all.T


Changes:

=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1938,14 +1938,11 @@ pickQuantifiablePreds
 -- quantified over, given the type variables that are being quantified
 pickQuantifiablePreds qtvs theta
   = do { tc_lvl <- TcM.getTcLevel
-       ; flex_ctxt <- xoptM LangExt.FlexibleContexts
---        flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without
---                             -- -XFlexibleContexts: see #10608, #10351
        ; let is_nested = not (isTopTcLevel tc_lvl)
        ; return (mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]
-                 mapMaybe (pick_me is_nested flex_ctxt) theta) }
+                 mapMaybe (pick_me is_nested True) theta) }
   where
-    pick_me is_nested flex_ctxt pred
+    pick_me is_nested _flex_ctxt pred
       = case classifyPredType pred of
 
           ClassPred cls tys
@@ -1967,10 +1964,8 @@ pickQuantifiablePreds qtvs theta
             -> Just pred
 
             -- From here on, we are thinking about top-level defns only
-            | checkValidClsArgs flex_ctxt cls tys
-                 -- Only quantify over predicates that checkValidType
-                 -- will pass!  See #10351.
-            , no_fixed_dependencies cls tys
+            | no_fixed_dependencies cls tys
+              -- See Note [Do not quantify over constraints that determine a variable]
             -> Just pred
 
             | otherwise
@@ -2011,6 +2006,8 @@ pickQuantifiablePreds qtvs theta
                          -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs
           _ -> False
 
+--        flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without
+--                             -- -XFlexibleContexts: see #10608, #10351
 
 ------------------
 growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet


=====================================
testsuite/tests/typecheck/should_compile/T22194.hs
=====================================
@@ -0,0 +1,64 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonoLocalBinds #-}
+
+module Test where
+
+import Data.Kind
+import GHC.Exts
+
+--import Control.Monad.Primitive -- primitive-0.7.4.0
+--import Data.Primitive.MutVar -- primitive-0.7.4.0
+
+class Monad m => PrimMonad m where
+  type PrimState m
+  primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+
+data MutVar s a = MutVar (MutVar# s a)
+
+newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a)
+newMutVar = error "urk"
+
+writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m ()
+writeMutVar  = error "Urk"
+
+-----------
+
+class Monad m => New a m where
+  new :: m a
+
+class Monad m => Add a m e | a -> e where
+  add :: a -> e -> m ()
+
+data T (m :: Type -> Type) = T
+
+instance PrimMonad m => New (T m) m where
+  new = return T
+
+instance PrimMonad m => Add (T m) m Int where
+  add _ _ = return ()
+
+test1 :: forall m. PrimMonad m => m ()
+test1 = do
+  ref <- newMutVar (undefined :: T m)
+  let g () = do
+        t <- new
+        add t (0 :: Int)
+        writeMutVar ref t
+  g ()
+
+test2 :: forall m. PrimMonad m => m ()
+test2 = do
+  (ref :: MutVar (PrimState m) (T m)) <- newMutVar undefined
+  let g () = do
+        t <- new
+        add t (0 :: Int)
+        writeMutVar ref t
+  g ()


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -867,6 +867,7 @@ test('T23018', normal, compile, [''])
 test('T21909', normal, compile, [''])
 test('T21909b', normal, compile, [''])
 test('T21443', normal, compile, [''])
+test('T22194', normal, compile, [''])
 test('QualifiedRecordUpdate',
     [ extra_files(['QualifiedRecordUpdate_aux.hs']) ]
     , multimod_compile, ['QualifiedRecordUpdate', '-v0'])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3948dc03dc3955c1c10a26fdfd4b12bbff8ff43a
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/20230331/48497859/attachment-0001.html>