[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: JS: factorize SaneDouble into its own module
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jun 16 16:57:49 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a5f0c00e by Sylvain Henry at 2023-06-16T12:25:40-04:00
JS: factorize SaneDouble into its own module
Follow-up of b159e0e9 whose ticket is #22736
- - - - -
0baf9e7c by Krzysztof Gogolewski at 2023-06-16T12:26:17-04:00
Add tests for #21973
- - - - -
9650e992 by Diego Diverio at 2023-06-16T12:57:36-04:00
Update documentation for `<**>`
- - - - -
c5a91ad4 by Diego Diverio at 2023-06-16T12:57:36-04:00
Update text
- - - - -
c7a95700 by Diego Diverio at 2023-06-16T12:57:36-04:00
Update examples
- - - - -
b14a557b by Diego Diverio at 2023-06-16T12:57:36-04:00
Update documentation to actually display code correctly
- - - - -
68bff0a9 by Andrei Borzenkov at 2023-06-16T12:57:37-04:00
Type/data instances: require that variables on the RHS are mentioned on the LHS (#23512)
GHC Proposal #425 "Invisible binders in type declarations" restricts the
scope of type and data family instances as follows:
In type family and data family instances, require that every variable
mentioned on the RHS must also occur on the LHS.
For example, here are three equivalent type instance definitions accepted before this patch:
type family F1 a :: k
type instance F1 Int = Any :: j -> j
type family F2 a :: k
type instance F2 @(j -> j) Int = Any :: j -> j
type family F3 a :: k
type instance forall j. F3 Int = Any :: j -> j
- In F1, j is implicitly quantified and it occurs only on the RHS;
- In F2, j is implicitly quantified and it occurs both on the LHS and the RHS;
- In F3, j is explicitly quantified.
Now F1 is rejected with an out-of-scope error, while F2 and F3 continue to be accepted.
- - - - -
27 changed files:
- compiler/GHC/JS/Syntax.hs
- compiler/GHC/JS/Unsat/Syntax.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Types.hs
- + compiler/GHC/Types/SaneDouble.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.8.1-notes.rst
- libraries/base/GHC/Base.hs
- testsuite/tests/indexed-types/should_compile/T14131.hs
- testsuite/tests/indexed-types/should_compile/T15852.hs
- testsuite/tests/indexed-types/should_compile/T15852.stderr
- testsuite/tests/indexed-types/should_fail/T14230.hs
- testsuite/tests/indexed-types/should_fail/T7938.hs
- testsuite/tests/indexed-types/should_fail/T7938.stderr
- + testsuite/tests/rename/should_compile/T23512b.hs
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/rename/should_fail/T23512a.hs
- + testsuite/tests/rename/should_fail/T23512a.stderr
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/typecheck/should_fail/T15797.hs
- + 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/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/Rename/HsType.hs
=====================================
@@ -1799,8 +1799,7 @@ one exists:
a free variable 'a', which we implicitly quantify over. That is why we can
also use it to the left of the double colon: 'Left a
-The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type
-synonyms and type family instances.
+The logic resides in extractHsTyRdrTyVarsKindVars.
This was a stopgap solution until we could explicitly bind invisible
type/kind variables:
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -634,14 +634,10 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
rnFamEqn :: HsDocContext
-> AssocTyFamInfo
- -> FreeKiTyVars
- -- ^ Additional kind variables to implicitly bind if there is no
- -- explicit forall. (See the comments on @all_imp_vars@ below for a
- -- more detailed explanation.)
-> FamEqn GhcPs rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-> RnM (FamEqn GhcRn rhs', FreeVars)
-rnFamEqn doc atfi extra_kvars
+rnFamEqn doc atfi
(FamEqn { feqn_tycon = tycon
, feqn_bndrs = outer_bndrs
, feqn_pats = pats
@@ -652,19 +648,8 @@ rnFamEqn doc atfi extra_kvars
-- all_imp_vars represent the implicitly bound type variables. This is
-- empty if we have an explicit `forall` (see
-- Note [forall-or-nothing rule] in GHC.Hs.Type), which means
- -- ignoring:
- --
- -- - pat_kity_vars, the free variables mentioned in the type patterns
- -- on the LHS of the equation, and
- -- - extra_kvars, which is one of the following:
- -- * For type family instances, extra_kvars are the free kind
- -- variables mentioned in an outermost kind signature on the RHS
- -- of the equation.
- -- (See Note [Implicit quantification in type synonyms] in
- -- GHC.Rename.HsType.)
- -- * For data family instances, extra_kvars are the free kind
- -- variables mentioned in the explicit return kind, if one is
- -- provided. (e.g., the `k` in `data instance T :: k -> Type`).
+ -- ignoring pat_kity_vars, the free variables mentioned in the type patterns
+ -- on the LHS of the equation
--
-- Some examples:
--
@@ -678,8 +663,6 @@ rnFamEqn doc atfi extra_kvars
-- type family G :: Maybe a
-- type instance forall a. G = (Nothing :: Maybe a)
-- -- all_imp_vars = []
- -- type instance G = (Nothing :: Maybe a)
- -- -- all_imp_vars = [a]
--
-- data family H :: k -> Type
-- data instance forall k. H :: k -> Type where ...
@@ -690,7 +673,7 @@ rnFamEqn doc atfi extra_kvars
--
-- For associated type family instances, exclude the type variables
-- bound by the instance head with filterInScopeM (#19649).
- ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars
+ ; all_imp_vars <- filterInScopeM $ pat_kity_vars
; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
@@ -727,21 +710,12 @@ rnFamEqn doc atfi extra_kvars
-- associated family instance but not bound on the LHS, then reject
-- that type variable as being out of scope.
-- See Note [Renaming associated types].
- -- Per that Note, the LHS type variables consist of:
- --
- -- - The variables mentioned in the instance's type patterns
- -- (pat_fvs), and
- --
- -- - The variables mentioned in an outermost kind signature on the
- -- RHS. This is a subset of `rhs_fvs`. To compute it, we look up
- -- each RdrName in `extra_kvars` to find its corresponding Name in
- -- the LocalRdrEnv.
- ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars
- ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms
- improperly_scoped cls_tkv =
+ -- Per that Note, the LHS type variables consist of the variables
+ -- mentioned in the instance's type patterns (pat_fvs)
+ ; let improperly_scoped cls_tkv =
cls_tkv `elemNameSet` rhs_fvs
-- Mentioned on the RHS...
- && not (cls_tkv `elemNameSet` lhs_bound_vars)
+ && not (cls_tkv `elemNameSet` pat_fvs)
-- ...but not bound on the LHS.
bad_tvs = filter improperly_scoped inst_head_tvs
; unless (null bad_tvs) (addErr (TcRnBadAssocRhs bad_tvs))
@@ -786,7 +760,7 @@ rnFamEqn doc atfi extra_kvars
--
-- type instance F a b c = Either a b
-- ^^^^^
- lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of
+ lhs_loc = case map lhsTypeArgSrcSpan pats of
[] -> panic "rnFamEqn.lhs_loc"
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
@@ -845,10 +819,9 @@ data ClosedTyFamInfo
rnTyFamInstEqn :: AssocTyFamInfo
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = rhs })
- = rnFamEqn (TySynCtx tycon) atfi extra_kvs eqn rnTySyn
- where
- extra_kvs = extractHsTyRdrTyVarsKindVars rhs
+rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon })
+ = rnFamEqn (TySynCtx tycon) atfi eqn rnTySyn
+
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
@@ -859,11 +832,9 @@ rnDataFamInstDecl :: AssocTyFamInfo
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn =
- eqn@(FamEqn { feqn_tycon = tycon
- , feqn_rhs = rhs })})
- = do { let extra_kvs = extractDataDefnKindVars rhs
- ; (eqn', fvs) <-
- rnFamEqn (TyDataCtx tycon) atfi extra_kvs eqn rnDataDefn
+ eqn@(FamEqn { feqn_tycon = tycon })})
+ = do { (eqn', fvs) <-
+ rnFamEqn (TyDataCtx tycon) atfi eqn rnDataDefn
; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
-- Renaming of the associated types in instances.
@@ -949,10 +920,7 @@ a class, we must check that all of the type variables mentioned on the RHS are
properly scoped. Specifically, the rule is this:
Every variable mentioned on the RHS of a type instance declaration
- (whether associated or not) must be either
- * Mentioned on the LHS, or
- * Mentioned in an outermost kind signature on the RHS
- (see Note [Implicit quantification in type synonyms])
+ (whether associated or not) must be mentioned on the LHS
Here is a simple example of something we should reject:
@@ -962,8 +930,7 @@ Here is a simple example of something we should reject:
type F Int x = z
Here, `z` is mentioned on the RHS of the associated instance without being
-mentioned on the LHS, nor is `z` mentioned in an outermost kind signature. The
-renamer will reject `z` as being out of scope without much fuss.
+mentioned on the LHS. The renamer will reject `z` as being out of scope without much fuss.
Things get slightly trickier when the instance header itself binds type
variables. Consider this example (adapted from #5515):
@@ -1055,10 +1022,8 @@ Some additional wrinkles:
Note that the `o` in the `Codomain 'KProxy` instance should be considered
improperly scoped. It does not meet the criteria for being explicitly
- quantified, as it is not mentioned by name on the LHS, nor does it meet the
- criteria for being implicitly quantified, as it is used in a RHS kind
- signature that is not outermost (see Note [Implicit quantification in type
- synonyms]). However, `o` /is/ bound by the instance header, so if this
+ quantified, as it is not mentioned by name on the LHS.
+ However, `o` /is/ bound by the instance header, so if this
program is not rejected by the renamer, the typechecker would treat it as
though you had written this:
@@ -1070,6 +1035,12 @@ Some additional wrinkles:
If the user really wants the latter, it is simple enough to communicate
their intent by mentioning `o` on the LHS by name.
+* Historical note: Previously we had to add type variables from the outermost
+ kind signature on the RHS to the scope of associated type family instance,
+ i.e. GHC did implicit quantification over them. But now that we implement
+ GHC Proposal #425 "Invisible binders in type declarations"
+ we don't need to do this anymore.
+
Note [Type family equations and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In most data/type family equations, the type family name used in the equation
=====================================
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/9.8.1-notes.rst
=====================================
@@ -19,6 +19,22 @@ Language
This feature is guarded behind :extension:`TypeAbstractions`.
+- In accordance with GHC proposal `#425
+ <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0425-decl-invis-binders.rst>`_
+ GHC no longer implicitly quantifies over type variables that appear only in the RHS of type and
+ data family instances. This code will no longer work: ::
+
+ type family F1 a :: k
+ type instance F1 Int = Any :: j -> j
+
+ Instead you should write::
+
+ type instance F1 @(j -> j) Int = Any :: j -> j
+
+ Or::
+
+ type instance forall j . F1 Int = Any :: j -> j
+
Compiler
~~~~~~~~
=====================================
libraries/base/GHC/Base.hs
=====================================
@@ -806,11 +806,21 @@ class Functor f => Applicative f where
(<*) :: f a -> f b -> f a
(<*) = liftA2 const
--- | A variant of '<*>' with the arguments reversed.
+-- | A variant of '<*>' with the types of the arguments reversed. It differs from
+-- @`flip` `(<*>)`@ in that the effects are resolved in the order the arguments are
+-- presented.
--
+-- ==== __Examples__
+-- >>> (<**>) (print 1) (id <$ print 2)
+-- 1
+-- 2
+--
+-- >>> flip (<*>) (print 1) (id <$ print 2)
+-- 2
+-- 1
+
(<**>) :: Applicative f => f a -> f (a -> b) -> f b
(<**>) = liftA2 (\a f -> f a)
--- Don't use $ here, see the note at the top of the page
-- | Lift a function to actions.
-- Equivalent to Functor's `fmap` but implemented using only `Applicative`'s methods:
=====================================
testsuite/tests/indexed-types/should_compile/T14131.hs
=====================================
@@ -9,21 +9,21 @@ import Data.Kind
import Data.Proxy
data family Nat :: k -> k -> Type
-newtype instance Nat :: (k -> Type) -> (k -> Type) -> Type where
+newtype instance Nat :: forall k . (k -> Type) -> (k -> Type) -> Type where
Nat :: (forall xx. f xx -> g xx) -> Nat f g
type family F :: Maybe a
-type instance F = (Nothing :: Maybe a)
+type instance F @a = (Nothing :: Maybe a)
class C k where
data CD :: k -> k -> Type
type CT :: k
instance C (Maybe a) where
- data CD :: Maybe a -> Maybe a -> Type where
+ data CD @(Maybe a) :: Maybe a -> Maybe a -> Type where
CD :: forall a (m :: Maybe a) (n :: Maybe a). Proxy m -> Proxy n -> CD m n
- type CT = (Nothing :: Maybe a)
+ type CT @(Maybe a) = (Nothing :: Maybe a)
class Z k where
type ZT :: Maybe k
- type ZT = (Nothing :: Maybe k)
+ type ZT @k = (Nothing :: Maybe k)
=====================================
testsuite/tests/indexed-types/should_compile/T15852.hs
=====================================
@@ -7,4 +7,4 @@ import Data.Kind
import Data.Proxy
data family DF a (b :: k)
-data instance DF (Proxy c) :: Proxy j -> Type
+data instance DF @(Proxy j) (Proxy c) :: Proxy j -> Type
=====================================
testsuite/tests/indexed-types/should_compile/T15852.stderr
=====================================
@@ -3,10 +3,10 @@ TYPE CONSTRUCTORS
roles nominal nominal nominal
COERCION AXIOMS
axiom T15852.D:R:DFProxyProxy0 ::
- forall k1 k2 (c :: k1) (j :: k2).
- DF (Proxy c) = T15852.R:DFProxyProxy k1 k2 c j
+ forall k1 k2 (j :: k1) (c :: k2).
+ DF (Proxy c) = T15852.R:DFProxyProxy k1 k2 j c
FAMILY INSTANCES
- data instance forall {k1} {k2} {c :: k1} {j :: k2}.
+ data instance forall {k1} {k2} {j :: k1} {c :: k2}.
DF (Proxy c) -- Defined at T15852.hs:10:15
Dependent modules: []
-Dependent packages: [base-4.17.0.0]
+Dependent packages: [base-4.18.0.0]
=====================================
testsuite/tests/indexed-types/should_fail/T14230.hs
=====================================
@@ -8,4 +8,4 @@ class C k where
data CD :: k -> k -> *
instance C (Maybe a) where
- data CD :: (k -> *) -> (k -> *) -> *
+ data forall k . CD :: (k -> *) -> (k -> *) -> *
=====================================
testsuite/tests/indexed-types/should_fail/T7938.hs
=====================================
@@ -9,4 +9,4 @@ class Foo (a :: k1) (b :: k2) where
type Bar a
instance Foo (a :: k1) (b :: k2) where
- type Bar a = (KP :: KProxy k2)
+ type forall k2 . Bar a = (KP :: KProxy k2)
=====================================
testsuite/tests/indexed-types/should_fail/T7938.stderr
=====================================
@@ -1,5 +1,5 @@
-T7938.hs:12:17: error: [GHC-83865]
+T7938.hs:12:29: error: [GHC-83865]
• Expected a type, but ‘KP :: KProxy k2’ has kind ‘KProxy k2’
• In the type ‘(KP :: KProxy k2)’
In the type instance declaration for ‘Bar’
=====================================
testsuite/tests/rename/should_compile/T23512b.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies, TypeAbstractions #-}
+module T23512b where
+import GHC.Types
+
+type family F2 a :: k
+type instance F2 @(j -> j) Int = Any :: j -> j
+
+type family F3 a :: k
+type instance forall j. F3 Int = Any :: j -> j
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -213,3 +213,4 @@ test('T23240', [req_th, extra_files(['T23240_aux.hs'])], multimod_compile, ['T23
test('T23318', normal, compile, ['-Wduplicate-exports'])
test('T23434', normal, compile, [''])
test('T23510b', normal, compile, [''])
+test('T23512b', normal, compile, [''])
=====================================
testsuite/tests/rename/should_fail/T23512a.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies #-}
+module T23512a where
+import GHC.Types
+
+type family F1 a :: k
+type instance F1 Int = Any :: j -> j
+
+data family D :: k -> Type
+data instance D :: k -> Type
=====================================
testsuite/tests/rename/should_fail/T23512a.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T23512a.hs:6:31: error: [GHC-76037] Not in scope: type variable ‘j’
+
+T23512a.hs:6:36: error: [GHC-76037] Not in scope: type variable ‘j’
+
+T23512a.hs:9:20: error: [GHC-76037] Not in scope: type variable ‘k’
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -203,3 +203,4 @@ test('T23510a', normal, compile_fail, [''])
test('T16635a', normal, compile_fail, [''])
test('T16635b', normal, compile_fail, [''])
test('T16635c', normal, compile_fail, [''])
+test('T23512a', normal, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_fail/T15797.hs
=====================================
@@ -13,7 +13,7 @@ import Data.Kind
class Ríki (obj :: Type) where
type Obj :: obj -> Constraint
- type Obj = Bæ @k :: k -> Constraint
+ type forall k . Obj = Bæ @k :: k -> Constraint
class Bæ (a :: k)
instance Bæ @k (a :: k)
=====================================
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/1a55d9087b8ca790f3da6f7be19b7023792377ed...68bff0a947e1133d359c0b7eded5970a75c20113
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a55d9087b8ca790f3da6f7be19b7023792377ed...68bff0a947e1133d359c0b7eded5970a75c20113
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/d9c8154c/attachment-0001.html>
More information about the ghc-commits
mailing list