[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Lint: more details on "Occurrence is GlobalId, but binding is LocalId"
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jun 16 10:25:28 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
62c56416 by Ben Price at 2023-06-16T05:52:39-04:00
Lint: more details on "Occurrence is GlobalId, but binding is LocalId"
This is helpful when debugging a pass which accidentally shadowed a
binder.
- - - - -
d4c10238 by Ryan Hendrickson at 2023-06-16T05:53:22-04:00
Clean a stray bit of text in user guide
- - - - -
93647b5c by Vladislav Zavialov at 2023-06-16T05:54:02-04:00
testsuite: Add forall visibility test cases
The added tests ensure that the type checker does not confuse
visible and invisible foralls.
VisFlag1: kind-checking type applications and inferred type variable instantiations
VisFlag1_ql: kind-checking Quick Look instantiations
VisFlag2: kind-checking type family instances
VisFlag3: checking kind annotations on type parameters of associated type families
VisFlag4: checking kind annotations on type parameters in type declarations with SAKS
VisFlag5: checking the result kind annotation of data family instances
- - - - -
7bdbfb92 by Sylvain Henry at 2023-06-16T06:25:17-04:00
JS: factorize SaneDouble into its own module
Follow-up of b159e0e9 whose ticket is #22736
- - - - -
1a55d908 by Krzysztof Gogolewski at 2023-06-16T06:25:17-04:00
Add tests for #21973
- - - - -
26 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/JS/Syntax.hs
- compiler/GHC/JS/Unsat/Syntax.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Types.hs
- + compiler/GHC/Types/SaneDouble.hs
- compiler/ghc.cabal.in
- docs/users_guide/exts/infix_tycons.rst
- + testsuite/tests/typecheck/should_fail/VisFlag1.hs
- + testsuite/tests/typecheck/should_fail/VisFlag1.stderr
- + testsuite/tests/typecheck/should_fail/VisFlag1_ql.hs
- + testsuite/tests/typecheck/should_fail/VisFlag1_ql.stderr
- + testsuite/tests/typecheck/should_fail/VisFlag2.hs
- + testsuite/tests/typecheck/should_fail/VisFlag2.stderr
- + testsuite/tests/typecheck/should_fail/VisFlag3.hs
- + testsuite/tests/typecheck/should_fail/VisFlag3.stderr
- + testsuite/tests/typecheck/should_fail/VisFlag4.hs
- + testsuite/tests/typecheck/should_fail/VisFlag4.stderr
- + testsuite/tests/typecheck/should_fail/VisFlag5.hs
- + testsuite/tests/typecheck/should_fail/VisFlag5.stderr
- testsuite/tests/typecheck/should_fail/all.T
- + testsuite/tests/typecheck/should_run/T21973a.hs
- + testsuite/tests/typecheck/should_run/T21973a.stderr
- + testsuite/tests/typecheck/should_run/T21973b.hs
- + testsuite/tests/typecheck/should_run/T21973b.stdout
- testsuite/tests/typecheck/should_run/all.T
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -3243,7 +3243,7 @@ lookupIdInScope id_occ
= do { in_scope_ids <- getInScopeIds
; case lookupVarEnv in_scope_ids id_occ of
Just (id_bndr, linted_ty)
- -> do { checkL (not (bad_global id_bndr)) global_in_scope
+ -> do { checkL (not (bad_global id_bndr)) $ global_in_scope id_bndr
; return (id_bndr, linted_ty) }
Nothing -> do { checkL (not is_local) local_out_of_scope
; return (id_occ, idType id_occ) } }
@@ -3252,8 +3252,10 @@ lookupIdInScope id_occ
where
is_local = mustHaveLocalBinding id_occ
local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ
- global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId")
- 2 (pprBndr LetBind id_occ)
+ global_in_scope id_bndr = hang (text "Occurrence is GlobalId, but binding is LocalId")
+ 2 $ vcat [hang (text "occurrence:") 2 $ pprBndr LetBind id_occ
+ ,hang (text "binder :") 2 $ pprBndr LetBind id_bndr
+ ]
bad_global id_bnd = isGlobalId id_occ
&& isLocalId id_bnd
&& not (isWiredIn id_occ)
=====================================
compiler/GHC/JS/Syntax.hs
=====================================
@@ -94,6 +94,7 @@ import GHC.Prelude
import GHC.JS.Unsat.Syntax (Ident(..))
import GHC.Data.FastString
import GHC.Types.Unique.Map
+import GHC.Types.SaneDouble
import GHC.Utils.Misc
import Control.DeepSeq
@@ -333,25 +334,6 @@ data AOp
instance NFData AOp
--- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
--- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on
--- Sane-ness
-newtype SaneDouble = SaneDouble
- { unSaneDouble :: Double
- }
- deriving (Data, Typeable, Fractional, Num, Generic, NFData)
-
-instance Eq SaneDouble where
- (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)
-
-instance Ord SaneDouble where
- compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)
- where fromNaN z | isNaN z = Nothing
- | otherwise = Just z
-
-instance Show SaneDouble where
- show (SaneDouble x) = show x
-
--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------
=====================================
compiler/GHC/JS/Unsat/Syntax.hs
=====================================
@@ -103,6 +103,7 @@ import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
import GHC.Types.Unique
import GHC.Types.Unique.Map
+import GHC.Types.SaneDouble
-- | A supply of identifiers, possibly empty
newtype IdentSupply a
@@ -359,26 +360,6 @@ data JUOp
instance NFData JUOp
--- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
--- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on
--- Sane-ness
-newtype SaneDouble = SaneDouble
- { unSaneDouble :: Double
- }
- deriving (Data, Typeable, Fractional, Num, Generic, NFData)
-
-instance Eq SaneDouble where
- (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)
-
-instance Ord SaneDouble where
- compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)
- where fromNaN z | isNaN z = Nothing
- | otherwise = Just z
-
-instance Show SaneDouble where
- show (SaneDouble x) = show x
-
-
--------------------------------------------------------------------------------
-- Identifiers
--------------------------------------------------------------------------------
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -86,7 +86,6 @@ import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Types.Unique.Map
-import GHC.Float (castDoubleToWord64, castWord64ToDouble)
import GHC.Utils.Binary hiding (SymbolTable)
import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep)
@@ -483,39 +482,6 @@ instance Binary Ident where
put_ bh (TxtI xs) = put_ bh xs
get bh = TxtI <$> get bh
--- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this
-instance Binary Sat.SaneDouble where
- put_ bh (Sat.SaneDouble d)
- | isNaN d = putByte bh 1
- | isInfinite d && d > 0 = putByte bh 2
- | isInfinite d && d < 0 = putByte bh 3
- | isNegativeZero d = putByte bh 4
- | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
- get bh = getByte bh >>= \case
- 1 -> pure $ Sat.SaneDouble (0 / 0)
- 2 -> pure $ Sat.SaneDouble (1 / 0)
- 3 -> pure $ Sat.SaneDouble ((-1) / 0)
- 4 -> pure $ Sat.SaneDouble (-0)
- 5 -> Sat.SaneDouble . castWord64ToDouble <$> get bh
- n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)
-
--- FIXME: remove after Unsat replaces JStat
--- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this
-instance Binary SaneDouble where
- put_ bh (SaneDouble d)
- | isNaN d = putByte bh 1
- | isInfinite d && d > 0 = putByte bh 2
- | isInfinite d && d < 0 = putByte bh 3
- | isNegativeZero d = putByte bh 4
- | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
- get bh = getByte bh >>= \case
- 1 -> pure $ SaneDouble (0 / 0)
- 2 -> pure $ SaneDouble (1 / 0)
- 3 -> pure $ SaneDouble ((-1) / 0)
- 4 -> pure $ SaneDouble (-0)
- 5 -> SaneDouble . castWord64ToDouble <$> get bh
- n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)
-
instance Binary ClosureInfo where
put_ bh (ClosureInfo v regs name layo typ static) = do
put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
@@ -48,9 +47,6 @@ import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.ByteString as BS
import Data.Monoid
-import Data.Typeable (Typeable)
-import GHC.Generics (Generic)
-import Control.DeepSeq
-- | A State monad over IO holding the generator state.
type G = StateT GenState IO
@@ -107,7 +103,7 @@ data ClosureInfo = ClosureInfo
, ciType :: CIType -- ^ type of the object, with extra info where required
, ciStatic :: CIStatic -- ^ static references of this object
}
- deriving stock (Eq, Show, Generic)
+ deriving stock (Eq, Show)
-- | Closure information, 'ClosureInfo', registers
data CIRegs
@@ -115,9 +111,7 @@ data CIRegs
| CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start
, ciRegsTypes :: [VarType] -- ^ args
}
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CIRegs
+ deriving stock (Eq, Ord, Show)
-- | Closure Information, 'ClosureInfo', layout
data CILayout
@@ -129,9 +123,7 @@ data CILayout
{ layoutSize :: !Int -- ^ closure size in array positions, including entry
, layout :: [VarType] -- ^ The set of sized Types to layout
}
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CILayout
+ deriving stock (Eq, Ord, Show)
-- | The type of 'ClosureInfo'
data CIType
@@ -143,13 +135,11 @@ data CIType
| CIPap -- ^ The closure is a Partial Application
| CIBlackhole -- ^ The closure is a black hole
| CIStackFrame -- ^ The closure is a stack frame
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CIType
+ deriving stock (Eq, Ord, Show)
-- | Static references that must be kept alive
newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] }
- deriving stock (Eq, Generic)
+ deriving stock (Eq)
deriving newtype (Semigroup, Monoid, Show)
-- | static refs: array = references, null = nothing to report
@@ -169,9 +159,7 @@ data VarType
| RtsObjV -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#)
| ObjV -- ^ some JS object, user supplied, be careful around these, can be anything
| ArrV -- ^ boxed array
- deriving stock (Eq, Ord, Enum, Bounded, Show, Generic)
-
-instance NFData VarType
+ deriving stock (Eq, Ord, Enum, Bounded, Show)
instance ToJExpr VarType where
toJExpr = toJExpr . fromEnum
@@ -231,7 +219,7 @@ data StaticInfo = StaticInfo
{ siVar :: !FastString -- ^ global object
, siVal :: !StaticVal -- ^ static initialization
, siCC :: !(Maybe Ident) -- ^ optional CCS name
- } deriving stock (Eq, Show, Typeable, Generic)
+ } deriving stock (Eq, Show)
data StaticVal
= StaticFun !FastString [StaticArg]
@@ -245,7 +233,7 @@ data StaticVal
-- ^ regular datacon app
| StaticList [StaticArg] (Maybe FastString)
-- ^ list initializer (with optional tail)
- deriving stock (Eq, Show, Generic)
+ deriving stock (Eq, Show)
data StaticUnboxed
= StaticUnboxedBool !Bool
@@ -253,9 +241,7 @@ data StaticUnboxed
| StaticUnboxedDouble !SaneDouble
| StaticUnboxedString !BS.ByteString
| StaticUnboxedStringOffset !BS.ByteString
- deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData StaticUnboxed
+ deriving stock (Eq, Ord, Show)
-- | Static Arguments. Static Arguments are things that are statically
-- allocated, i.e., they exist at program startup. These are static heap objects
@@ -264,7 +250,7 @@ data StaticArg
= StaticObjArg !FastString -- ^ reference to a heap object
| StaticLitArg !StaticLit -- ^ literal
| StaticConArg !FastString [StaticArg] -- ^ unfloated constructor
- deriving stock (Eq, Show, Generic)
+ deriving stock (Eq, Show)
instance Outputable StaticArg where
ppr x = text (show x)
@@ -278,7 +264,7 @@ data StaticLit
| StringLit !FastString
| BinLit !BS.ByteString
| LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init)
- deriving (Eq, Show, Generic)
+ deriving (Eq, Show)
instance Outputable StaticLit where
ppr x = text (show x)
@@ -300,7 +286,7 @@ data ForeignJSRef = ForeignJSRef
, foreignRefCConv :: !CCallConv
, foreignRefArgs :: ![FastString]
, foreignRefResult :: !FastString
- } deriving stock (Generic)
+ }
-- | data used to generate one ObjUnit in our object file
data LinkableUnit = LinkableUnit
=====================================
compiler/GHC/Types/SaneDouble.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | Double datatype with saner instances
+module GHC.Types.SaneDouble
+ ( SaneDouble (..)
+ )
+where
+
+import GHC.Prelude
+import GHC.Utils.Binary
+import GHC.Float (castDoubleToWord64, castWord64ToDouble)
+
+-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
+-- that becomes a 'NaN', see instances for details on sanity.
+newtype SaneDouble = SaneDouble
+ { unSaneDouble :: Double
+ }
+ deriving (Fractional, Num)
+
+instance Eq SaneDouble where
+ (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)
+
+instance Ord SaneDouble where
+ compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)
+ where fromNaN z | isNaN z = Nothing
+ | otherwise = Just z
+
+instance Show SaneDouble where
+ show (SaneDouble x) = show x
+
+-- we need to preserve NaN and infinities, unfortunately the Binary instance for
+-- Double does not do this
+instance Binary SaneDouble where
+ put_ bh (SaneDouble d)
+ | isNaN d = putByte bh 1
+ | isInfinite d && d > 0 = putByte bh 2
+ | isInfinite d && d < 0 = putByte bh 3
+ | isNegativeZero d = putByte bh 4
+ | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
+ get bh = getByte bh >>= \case
+ 1 -> pure $ SaneDouble (0 / 0)
+ 2 -> pure $ SaneDouble (1 / 0)
+ 3 -> pure $ SaneDouble ((-1) / 0)
+ 4 -> pure $ SaneDouble (-0)
+ 5 -> SaneDouble . castWord64ToDouble <$> get bh
+ n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)
+
=====================================
compiler/ghc.cabal.in
=====================================
@@ -811,6 +811,7 @@ Library
GHC.Types.ProfAuto
GHC.Types.RepType
GHC.Types.SafeHaskell
+ GHC.Types.SaneDouble
GHC.Types.SourceError
GHC.Types.SourceFile
GHC.Types.SourceText
=====================================
docs/users_guide/exts/infix_tycons.rst
=====================================
@@ -41,7 +41,7 @@ specifically:
infixl 7 T, :*:
sets the fixity for both type constructor ``T`` and data constructor
- ``T``, and similarly for ``:*:``. ``Int `a` Bool``.
+ ``T``, and similarly for ``:*:``.
- The function arrow ``->`` is ``infixr`` with fixity -1.
=====================================
testsuite/tests/typecheck/should_fail/VisFlag1.hs
=====================================
@@ -0,0 +1,18 @@
+module VisFlag1 where
+
+import Data.Kind (Type)
+
+type V :: forall k -> k -> Type
+data V k (a :: k) = MkV
+
+f :: forall {k} {a :: k} (hk :: forall j. j -> Type). hk a -> ()
+f _ = ()
+
+bad_tyapp :: ()
+bad_tyapp = f @V MkV
+
+bad_wild :: ()
+bad_wild = f @_ MkV
+
+bad_infer :: ()
+bad_infer = f MkV
=====================================
testsuite/tests/typecheck/should_fail/VisFlag1.stderr
=====================================
@@ -0,0 +1,27 @@
+
+VisFlag1.hs:12:16: error: [GHC-83865]
+ • Expecting one more argument to ‘V’
+ Expected kind ‘forall j. j -> *’,
+ but ‘V’ has kind ‘forall k -> k -> *’
+ • In the type ‘V’
+ In the expression: f @V MkV
+ In an equation for ‘bad_tyapp’: bad_tyapp = f @V MkV
+
+VisFlag1.hs:15:15: error: [GHC-91028]
+ • Expected kind ‘forall j. j -> *’, but ‘_’ has kind ‘k0’
+ Cannot instantiate unification variable ‘k0’
+ with a kind involving polytypes: forall j. j -> *
+ • In the expression: f @_ MkV
+ In an equation for ‘bad_wild’: bad_wild = f @_ MkV
+
+VisFlag1.hs:18:15: error: [GHC-18872]
+ • Couldn't match kind: forall k -> k -> *
+ with: forall j. j -> *
+ When matching types
+ hk0 :: forall j. j -> *
+ V :: forall k -> k -> *
+ Expected: hk0 a0
+ Actual: V k1 a0
+ • In the first argument of ‘f’, namely ‘MkV’
+ In the expression: f MkV
+ In an equation for ‘bad_infer’: bad_infer = f MkV
=====================================
testsuite/tests/typecheck/should_fail/VisFlag1_ql.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE ImpredicativeTypes #-}
+
+module VisFlag1_ql where
+
+import Data.Kind (Type)
+
+type V :: forall k -> k -> Type
+data V k (a :: k) = MkV
+
+f :: forall {k} {a :: k} (hk :: forall j. j -> Type). hk a -> ()
+f _ = ()
+
+bad_tyapp :: ()
+bad_tyapp = f @V MkV
+
+bad_wild :: ()
+bad_wild = f @_ MkV
+
+bad_infer :: ()
+bad_infer = f MkV
=====================================
testsuite/tests/typecheck/should_fail/VisFlag1_ql.stderr
=====================================
@@ -0,0 +1,23 @@
+
+VisFlag1_ql.hs:14:16: error: [GHC-83865]
+ • Expecting one more argument to ‘V’
+ Expected kind ‘forall j. j -> *’,
+ but ‘V’ has kind ‘forall k -> k -> *’
+ • In the type ‘V’
+ In the expression: f @V MkV
+ In an equation for ‘bad_tyapp’: bad_tyapp = f @V MkV
+
+VisFlag1_ql.hs:17:15: error: [GHC-91028]
+ • Expected kind ‘forall j. j -> *’, but ‘_’ has kind ‘k0’
+ Cannot instantiate unification variable ‘k0’
+ with a kind involving polytypes: forall j. j -> *
+ • In the expression: f @_ MkV
+ In an equation for ‘bad_wild’: bad_wild = f @_ MkV
+
+VisFlag1_ql.hs:20:15: error: [GHC-83865]
+ • Expecting one more argument to ‘V’
+ Expected kind ‘forall j. j -> *’,
+ but ‘V’ has kind ‘forall k -> k -> *’
+ • In the first argument of ‘f’, namely ‘MkV’
+ In the expression: f MkV
+ In an equation for ‘bad_infer’: bad_infer = f MkV
=====================================
testsuite/tests/typecheck/should_fail/VisFlag2.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module VisFlag2 where
+
+import Data.Kind (Type)
+
+-- the (Type ->) parameter is to prevent instantiation of invisible variables
+
+type family Invis :: Type -> forall a. a
+type family Vis :: Type -> forall a -> a
+
+type instance Vis = Invis -- Bad
+type instance Invis = Vis -- Bad
=====================================
testsuite/tests/typecheck/should_fail/VisFlag2.stderr
=====================================
@@ -0,0 +1,15 @@
+
+VisFlag2.hs:13:21: error: [GHC-83865]
+ • Couldn't match kind: forall a. a
+ with: forall a -> a
+ Expected kind ‘* -> forall a -> a’,
+ but ‘Invis’ has kind ‘* -> forall a. a’
+ • In the type ‘Invis’
+ In the type instance declaration for ‘Vis’
+
+VisFlag2.hs:14:23: error: [GHC-83865]
+ • Expecting one more argument to ‘Vis’
+ Expected kind ‘* -> forall a. a’,
+ but ‘Vis’ has kind ‘* -> forall a -> a’
+ • In the type ‘Vis’
+ In the type instance declaration for ‘Invis’
=====================================
testsuite/tests/typecheck/should_fail/VisFlag3.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module VisFlag3 where
+
+class C (hk :: forall k. k -> k) where
+ type F (hk :: forall k -> k -> k)
=====================================
testsuite/tests/typecheck/should_fail/VisFlag3.stderr
=====================================
@@ -0,0 +1,6 @@
+
+VisFlag3.hs:6:3: error: [GHC-83865]
+ • Expecting one more argument to ‘hk’
+ Expected kind ‘forall k. k -> k’,
+ but ‘hk’ has kind ‘forall k -> k -> k’
+ • In the associated type family declaration for ‘F’
=====================================
testsuite/tests/typecheck/should_fail/VisFlag4.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module VisFlag4 where
+
+import Data.Kind
+
+type C :: (forall k -> k -> k) -> Constraint
+class C (hk :: forall k. k -> k) where
=====================================
testsuite/tests/typecheck/should_fail/VisFlag4.stderr
=====================================
@@ -0,0 +1,5 @@
+
+VisFlag4.hs:8:1: error: [GHC-83865]
+ • Expected kind ‘forall k -> k -> k’,
+ but ‘hk’ has kind ‘forall k. k -> k’
+ • In the class declaration for ‘C’
=====================================
testsuite/tests/typecheck/should_fail/VisFlag5.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module VisFlag5 where
+
+import Data.Kind
+
+data family D a :: (forall i -> i -> i) -> Type
+data instance D Int :: (forall i. i -> i) -> Type
=====================================
testsuite/tests/typecheck/should_fail/VisFlag5.stderr
=====================================
@@ -0,0 +1,7 @@
+
+VisFlag5.hs:8:1: error: [GHC-83865]
+ • Couldn't match kind: forall i -> i -> i
+ with: forall i. i -> i
+ Expected kind ‘(forall i. i -> i) -> *’,
+ but ‘D Int’ has kind ‘(forall i -> i -> i) -> *’
+ • In the data instance declaration for ‘D’
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -690,3 +690,9 @@ test('T22560_fail_b', normal, compile_fail, [''])
test('T22560_fail_c', normal, compile_fail, [''])
test('T22560_fail_d', normal, compile_fail, [''])
test('T22560_fail_ext', normal, compile_fail, [''])
+test('VisFlag1', normal, compile_fail, [''])
+test('VisFlag1_ql', normal, compile_fail, [''])
+test('VisFlag2', normal, compile_fail, [''])
+test('VisFlag3', normal, compile_fail, [''])
+test('VisFlag4', normal, compile_fail, [''])
+test('VisFlag5', normal, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_run/T21973a.hs
=====================================
@@ -0,0 +1,45 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+
+module Main (main) where
+
+import Data.Kind
+import GHC.Exts
+
+class (Monoid (Share a), Eq (Share a)) => ClassDecode a where
+ type Share a :: Type
+ decoderWithShare :: Share a -> Decoder a
+
+class (Eq (Currency e), ClassDecode (Tx e)) => ClassLedger e where
+ type Currency e :: Type
+ type Tx e :: Type
+
+newtype Decoder a = Decoder (String -> a)
+
+{-# NOINLINE decode #-}
+decode :: ClassDecode a => String -> a
+decode str =
+ case decoderWithShare mempty of
+ Decoder f -> f str
+
+data MyLedger c
+
+newtype MyTx c = MyTx
+ { currency :: c
+ } deriving (Show, Read)
+
+instance (Eq c) => ClassLedger (MyLedger c) where
+ type Currency (MyLedger c) = c
+ type Tx (MyLedger c) = MyTx c
+
+instance (Eq [c], ClassLedger (MyLedger c)) => ClassDecode (MyTx c) where
+ type Share (MyTx c) = [c]
+ {-# NOINLINE decoderWithShare #-}
+ decoderWithShare :: [c] -> Decoder (MyTx c)
+ decoderWithShare (s :: [c]) =
+ Decoder $ \str -> error $ show (s == s)
+
+main :: IO ()
+main = print (noinline decode (noinline show (currency (MyTx "USD"))) :: MyTx String)
=====================================
testsuite/tests/typecheck/should_run/T21973a.stderr
=====================================
@@ -0,0 +1,3 @@
+T21973a: True
+CallStack (from HasCallStack):
+ error, called at T21973a.hs:42:23 in main:Main
=====================================
testsuite/tests/typecheck/should_run/T21973b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+
+module Main (main) where
+
+import Data.Kind
+import GHC.Exts
+
+
+data D a = MkD
+ deriving Eq
+
+class Def a where
+ def :: a
+instance Def (D a) where
+ def = MkD
+
+type family Share a where
+ Share Char = Char
+
+
+class ( Share a ~ a, Def a ) => ClassDecode a where
+instance ClassLedger c => ClassDecode (D c) where
+
+class (Eq e, ClassDecode (D e)) => ClassLedger e where
+instance Eq c => ClassLedger c where
+
+
+decoderWithShare2 :: ClassLedger a => a -> Bool
+decoderWithShare2 d = d == d
+
+
+decode :: forall a. (ClassLedger a, ClassDecode a) => Bool
+decode = decoderWithShare2 @a (def @(Share a))
+
+main :: IO ()
+main = print (decode @(D Char))
=====================================
testsuite/tests/typecheck/should_run/T21973b.stdout
=====================================
@@ -0,0 +1 @@
+True
=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -167,3 +167,5 @@ test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
test('T19667', normal, compile_and_run, ['-fhpc'])
test('T20768', normal, compile_and_run, [''])
test('T22510', normal, compile_and_run, [''])
+test('T21973a', [exit_code(1)], compile_and_run, [''])
+test('T21973b', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/047b8d26e5b9039042ecc8fb0a21ea828a9cedc1...1a55d9087b8ca790f3da6f7be19b7023792377ed
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/047b8d26e5b9039042ecc8fb0a21ea828a9cedc1...1a55d9087b8ca790f3da6f7be19b7023792377ed
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/20230616/3ba94668/attachment-0001.html>
More information about the ghc-commits
mailing list