[Git][ghc/ghc][wip/soulomoon/25647-allow-newtype-instance-in-gadt-syntax] 11 commits: Allow multiline strings in JS FFI (#25633)
Patrick (@soulomoon)
gitlab at gitlab.haskell.org
Sat Jan 18 14:02:20 UTC 2025
Patrick pushed to branch wip/soulomoon/25647-allow-newtype-instance-in-gadt-syntax at Glasgow Haskell Compiler / GHC
Commits:
14f8a7ec by Mateusz Goślinowski at 2025-01-17T22:49:09+00:00
Allow multiline strings in JS FFI (#25633)
- - - - -
854c2f75 by Simon Peyton Jones at 2025-01-18T02:54:08-05:00
Fix a buglet in tcSplitForAllTyVarsReqTVBindersN
The problem was that an equation in `split` had two guards (one about
visiblity and one about `n_req`). So it fell thorugh if /either/
was False. But the next equation then assumed an invisible binder.
Simple bug, easily fixed. Fixes #25661.
- - - - -
08342aae by Patrick at 2025-01-18T14:02:07+00:00
update kcConDecl to also consider the result type
in newtype GADT instance
- - - - -
a055bc71 by Patrick at 2025-01-18T14:02:07+00:00
peek at the result kind
- - - - -
a5e7b190 by Patrick at 2025-01-18T14:02:07+00:00
test if gadt has UserSuppliedResultKind in lhs, we let tc_res_kind to unify with rhs result kind if not to gain more inference
- - - - -
8cc81070 by Patrick at 2025-01-18T14:02:07+00:00
format and remove getTyConResultKind
- - - - -
fd990943 by Patrick at 2025-01-18T14:02:07+00:00
format
- - - - -
de5db767 by Patrick at 2025-01-18T14:02:07+00:00
add comment
- - - - -
6fa933d6 by Patrick at 2025-01-18T14:02:07+00:00
cleanup
- - - - -
6db17a97 by Patrick at 2025-01-18T14:02:07+00:00
cleanup
- - - - -
6b7b1166 by Patrick at 2025-01-18T14:02:07+00:00
update T25611a
- - - - -
15 changed files:
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Parser.y
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Var.hs
- docs/users_guide/9.14.1-notes.rst
- testsuite/tests/indexed-types/should_compile/T25611a.hs
- + testsuite/tests/javascript/T25633.hs
- + testsuite/tests/javascript/T25633.stdout
- testsuite/tests/javascript/all.T
- + testsuite/tests/polykinds/T25661.hs
- + testsuite/tests/polykinds/T25661.stderr
- testsuite/tests/polykinds/all.T
Changes:
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -155,11 +155,13 @@ data Type
| ForAllTy -- See Note [ForAllTy]
{-# UNPACK #-} !ForAllTyBinder
- Type -- ^ A Π type.
- -- See Note [Why ForAllTy can quantify over a coercion variable]
- -- INVARIANT: If the binder is a coercion variable, it must
- -- be mentioned in the Type.
- -- See Note [Unused coercion variable in ForAllTy]
+ -- ForAllTyBinder: see GHC.Types.Var
+ -- Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]
+ Type
+ -- INVARIANT: If the binder is a coercion variable, it must
+ -- be mentioned in the Type.
+ -- See Note [Unused coercion variable in ForAllTy]
+ -- See Note [Why ForAllTy can quantify over a coercion variable]
| FunTy -- ^ FUN m t1 t2 Very common, so an important special case
-- See Note [Function types]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2148,6 +2148,9 @@ fspec :: { Located (TokDcolon
: STRING var '::' sigtype { sLL $1 $> (epUniTok $3
,(L (getLoc $1)
(getStringLiteral $1), $2, $4)) }
+ | STRING_MULTI var '::' sigtype { sLL $1 $> (epUniTok $3
+ ,(L (getLoc $1)
+ (getStringMultiLiteral $1), $2, $4)) }
| var '::' sigtype { sLL $1 $> (epUniTok $2
,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }
-- if the entity string is missing, it defaults to the empty string;
@@ -4247,6 +4250,7 @@ getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src
getCTYPEs (L _ (ITctype src)) = src
getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing
+getStringMultiLiteral l = StringLiteral (getSTRINGMULTIs l) (getSTRINGMULTI l) Nothing
isUnicode :: Located Token -> Bool
isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -120,13 +120,17 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty
-- Makes sure that if the binding is unrestricted, it counts as
-- consuming its rhs Many times.
- do { traceTc "tcFunBindMatches 2" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys
- , ppr pat_tys $$ ppr rhs_ty ])
+ do { traceTc "tcFunBindMatches 2" $
+ vcat [ text "ctxt:" <+> pprUserTypeCtxt ctxt
+ , text "arity:" <+> ppr arity
+ , text "invis_pat_tys:" <+> ppr invis_pat_tys
+ , text "pat_tys:" <+> ppr pat_tys
+ , text "rhs_ty:" <+> ppr rhs_ty ]
; tcMatches tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches }
; return (wrap_fun, r) }
where
- herald = ExpectedFunTyMatches (NameThing fun_name) matches
+ herald = ExpectedFunTyMatches (NameThing fun_name) matches
funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool
funBindPrecondition (MG { mg_alts = L _ alts })
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -14,8 +14,8 @@
-- | Typecheck type and class declarations
module GHC.Tc.TyCl (
+ LHSUserSuppliedResultKind(..),
tcTyAndClassDecls,
-
-- Functions used by GHC.Tc.TyCl.Instance to check
-- data/type family instance declarations
kcConDecls, tcConDecls, DataDeclInfo(..),
@@ -1765,7 +1765,7 @@ kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM ()
-- kind inference (see GHC.Tc.TyCl Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon])
kcTyClDecl (DataDecl { tcdLName = (L _ _name)
- , tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } })
+ , tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = kindSig } })
tycon
= tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $
-- NB: binding these tyvars isn't necessary for GADTs, but it does no
@@ -1774,7 +1774,9 @@ kcTyClDecl (DataDecl { tcdLName = (L _ _name)
-- (conceivably) shadowed.
do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon))
; _ <- tcHsContext ctxt
- ; kcConDecls (tyConResKind tycon) cons
+ ; kcConDecls (tyConResKind tycon) (if (isJust kindSig)
+ then LHSUserSuppliedResultKind
+ else NoLHSUserSuppliedResultKind) cons
}
kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon
@@ -1834,12 +1836,18 @@ kcConGADTArgs exp_kind con_args = case con_args of
RecConGADT _ (L _ flds) -> kcConArgTys exp_kind $
map (hsLinear . cd_fld_type . unLoc) flds
+-- Specifically for GADT style declarations
+-- do we have lhs user supplied kind signature?
+-- as in `data xxx :: UserSuppliedKind where ...`
+data LHSUserSuppliedResultKind = LHSUserSuppliedResultKind | NoLHSUserSuppliedResultKind deriving Eq
+
kcConDecls :: TcKind -- Result kind of tycon
-- Used only in H98 case
+ -> LHSUserSuppliedResultKind
-> DataDefnCons (LConDecl GhcRn) -> TcM ()
-- See Note [kcConDecls: kind-checking data type decls]
-kcConDecls tc_res_kind cons
- = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons
+kcConDecls tc_res_kind usrk cons
+ = traverse_ (wrapLocMA_ (kcConDecl new_or_data usrk tc_res_kind)) cons
where
new_or_data = dataDefnConsNewOrData cons
@@ -1848,8 +1856,8 @@ kcConDecls tc_res_kind cons
-- declared with data or newtype, and we need to know the result kind of
-- this type. See Note [Implementation of UnliftedNewtypes] for why
-- we need the first two arguments.
-kcConDecl :: NewOrData -> TcKind -> ConDecl GhcRn -> TcM ()
-kcConDecl new_or_data tc_res_kind
+kcConDecl :: NewOrData -> LHSUserSuppliedResultKind -> TcKind -> ConDecl GhcRn -> TcM ()
+kcConDecl new_or_data _usrk tc_res_kind
(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
, con_mb_cxt = ex_ctxt, con_args = args })
= addErrCtxt (DataConDefCtxt (NE.singleton name)) $
@@ -1865,7 +1873,7 @@ kcConDecl new_or_data tc_res_kind
-- because that's done in tcConDecl
}
-kcConDecl new_or_data _tc_res_kind
+kcConDecl new_or_data usrk tc_res_kind
-- NB: _tc_res_kind is unused. See (KCD3) in
-- Note [kcConDecls: kind-checking data type decls]
(ConDeclGADT { con_names = names, con_bndrs = L _ outer_bndrs
@@ -1877,10 +1885,11 @@ kcConDecl new_or_data _tc_res_kind
bindOuterSigTKBndrs_Tv outer_bndrs $
-- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs]
do { _ <- tcHsContext cxt
- ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty)
- ; con_res_kind <- newOpenTypeKind
- ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind)
-
+ ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty $$ ppr tc_res_kind)
+ ; con_res_kind <- if NewType == new_or_data && NoLHSUserSuppliedResultKind == usrk
+ then return tc_res_kind
+ else newOpenTypeKind
+ ; _ <- tcCheckLHsTypeInContext res_ty $ (TheKind con_res_kind)
; let arg_exp_kind = getArgExpKind new_or_data con_res_kind
-- getArgExpKind: for newtypes, check that the argument kind
-- is the same the kind of `res_ty`, the data con's return type
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -946,7 +946,11 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
-- Add constraints from the data constructors
-- Fix #25611
-- See DESIGN CHOICE in Note [Kind inference for data family instances]
- ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons
+ ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind (if (isJust m_ksig)
+ then LHSUserSuppliedResultKind
+ else NoLHSUserSuppliedResultKind)
+ hs_cons
+
-- Check that the result kind of the TyCon applied to its args
-- is compatible with the explicit signature (or Type, if there
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -1490,8 +1490,10 @@ tcSplitForAllTyVarsReqTVBindersN n_req ty
= split n_req ty ty []
where
split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs
- | isVisibleForAllTyFlag argf, n_req > 0 = split (n_req - 1) ty ty (b:bs)
- | otherwise = split n_req ty ty (b:bs)
+ | isVisibleForAllTyFlag argf, n_req > 0 -- Split off a visible forall
+ = split (n_req - 1) ty ty (b:bs)
+ | isInvisibleForAllTyFlag argf -- Split off an invisible forall,
+ = split n_req ty ty (b:bs) -- even if n_req=0, i.e. the trailing ones
split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs
split n_req orig_ty _ty bs = (n_req, reverse bs, orig_ty)
@@ -1975,7 +1977,7 @@ isSigmaTy :: TcType -> Bool
-- forall a. blah
-- Eq a => blah
-- ?x::Int => blah
--- But not
+-- But NOT
-- forall a -> blah
isSigmaTy (ForAllTy (Bndr _ af) _) = isInvisibleForAllTyFlag af
isSigmaTy (FunTy { ft_af = af }) = isInvisibleFunArg af
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -648,6 +648,7 @@ data VarBndr var argf = Bndr var argf
-- A 'ForAllTyBinder' is the binder of a ForAllTy
-- It's convenient to define this synonym here rather its natural
-- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot
+-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]
--
-- A 'TyVarBinder' is a binder with only TyVar
type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -38,6 +38,8 @@ Language
That will break the combination of :extension:`OverloadedRecordUpdate` with :extension:`RebindableSyntax`.
+* Multiline strings are now accepted in foreign imports. (#25157)
+
Compiler
~~~~~~~~
=====================================
testsuite/tests/indexed-types/should_compile/T25611a.hs
=====================================
@@ -12,6 +12,6 @@ data family Fix0 :: (k -> Type) -> k
newtype instance Fix0 f = In0 { out0 :: f (Fix0 f) }
-- This is the GADT newtype instance case
--- currently not enabled since !9116 (closed) impose `A newtype must not be a GADT`
--- data family Fix2 :: (k -> Type) -> k
--- newtype instance Fix2 f where In2 :: f (Fix2 f) -> Fix2 f
+-- enabled since !13809
+data family Fix2 :: (k -> Type) -> k
+newtype instance Fix2 f where In2 :: f (Fix2 f) -> Fix2 f
=====================================
testsuite/tests/javascript/T25633.hs
=====================================
@@ -0,0 +1,44 @@
+{-# LANGUAGE MultilineStrings #-}
+module Main where
+
+import GHC.Prim
+import GHC.JS.Prim
+import Foreign.C
+import System.IO
+
+foreign import javascript
+ """
+ ((x) => x)
+ """
+ toJSDouble :: Double -> JSVal
+
+foreign import javascript
+ """
+ (function (x) {
+ console.log(x);
+ })
+ """
+ multiLog :: JSVal -> IO ()
+
+foreign import javascript
+ """
+ ((x) =>
+ x + ""
+ )
+ """
+ jsToString :: JSVal -> JSVal
+
+foreign import ccall
+ """
+ cos
+ """ mycos :: CDouble -> CDouble
+
+main :: IO ()
+main = do
+ hSetBuffering stdout NoBuffering
+
+ multiLog $ toJSInt 5
+ multiLog $ toJSString "Hello"
+ putStrLn $ fromJSString $ jsToString $ toJSInt (- 5)
+ multiLog $ jsToString $ toJSDouble 3.0
+ print $ mycos 0 == 1
\ No newline at end of file
=====================================
testsuite/tests/javascript/T25633.stdout
=====================================
@@ -0,0 +1,5 @@
+5
+Hello
+-5
+3
+True
\ No newline at end of file
=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -25,3 +25,5 @@ test('T24495', normal, makefile_test, ['T24495'])
test('T23479', normal, makefile_test, ['T23479'])
test('T24744', normal, makefile_test, ['T24744'])
+
+test('T25633', normal, compile_and_run, [''])
=====================================
testsuite/tests/polykinds/T25661.hs
=====================================
@@ -0,0 +1,38 @@
+{-# Language TypeFamilyDependencies #-}
+{-# Language RequiredTypeArguments #-}
+module T25661 where
+
+import Data.Kind
+import Control.Category (Category(id, (.)))
+import Prelude hiding (id, (.))
+
+type Cat :: Type -> Type
+type Cat k = k -> k -> Type
+-- type Op :: (k -> j -> Type) -> (j -> k -> Type)
+-- newtype Op cat b a = Op (cat a b)
+
+-- instance Category cat => Category (Op @k @k cat) where
+-- id = Op id
+-- Op f . Op g = Op (g . f)
+
+type NaturalTransformation :: Cat s -> Cat t -> Cat (s -> t)
+data NaturalTransformation src tgt f g where
+ -- NaturalTransformationId :: NaturalTransformation src tgt f f
+ NaturalTransformation :: (FunctorOf src tgt f, FunctorOf src tgt g) => { getNaturalTransformation :: forall x. f x `tgt` g x } -> NaturalTransformation src tgt f g
+
+type
+ FunctorOf :: Cat s -> Cat t -> (s -> t) -> Constraint
+class (NewFunctor f, Source f ~ src, Target f ~ tgt) => FunctorOf src tgt f
+instance (NewFunctor f, Source f ~ src, Target f ~ tgt) => FunctorOf src tgt f
+
+type
+ NewFunctor :: (s -> t) -> Constraint
+class (Category (Source f), Category (Target f)) => NewFunctor (f :: s -> t) where
+ type Source (f :: s -> t) :: Cat s
+ type Target (f :: s -> t) :: Cat t
+ newmap :: Source f a a' -> Target f (f a) (f a')
+
+
+newmapVis :: NewFunctor f => forall source -> source ~ Source f
+ => forall target -> target ~ Target f => source a a' -> target (f a) (f a')
+newmapVis source = undefined
=====================================
testsuite/tests/polykinds/T25661.stderr
=====================================
@@ -0,0 +1,17 @@
+T25661.hs:38:20: error: [GHC-91028]
+ • Couldn't match expected type ‘forall (target :: Cat t) ->
+ (target ~ Target f) => source a a' -> target (f a) (f a')’
+ with actual type ‘a0’
+ Cannot instantiate unification variable ‘a0’
+ with a type involving polytypes:
+ forall (target :: Cat t) ->
+ (target ~ Target f) => source a a' -> target (f a) (f a')
+ • In the expression: undefined
+ In an equation for ‘newmapVis’: newmapVis source = undefined
+ • Relevant bindings include
+ newmapVis :: forall (source :: Cat s) ->
+ (source ~ Source f) =>
+ forall (target :: Cat t) ->
+ (target ~ Target f) => source a a' -> target (f a) (f a')
+ (bound at T25661.hs:38:1)
+
=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -247,3 +247,4 @@ test('T24083', normal, compile_fail, [''])
test('T24083a', normal, compile, [''])
test('T24686', normal, compile_fail, [''])
test('T24686a', normal, compile_fail, [''])
+test('T25661', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f82cd8a9b8fcb1fec11b10aaff4933dae3691e9d...6b7b1166491f48a5c8cdb12dc7e043189a07da0a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f82cd8a9b8fcb1fec11b10aaff4933dae3691e9d...6b7b1166491f48a5c8cdb12dc7e043189a07da0a
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/20250118/d1044d11/attachment-0001.html>
More information about the ghc-commits
mailing list