From 8c3bc4a94e8e00c9bd99a350cdb8069742d887d9 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 3 Oct 2020 19:49:50 +0100 Subject: Preserve as-parsed arrow type for HsUnrestrictedArrow When linear types are disabled, HsUnrestrictedArrow is treated as HslinearArrow. Move this adjustment into the type checking phase, so that the parsed source accurately represents the source as parsed. Closes #18791 --- compiler/GHC/Parser/PostProcess.hs | 10 +--- compiler/GHC/Tc/TyCl.hs | 20 ++++++- .../should_compile_flag_haddock/T17544_kw.stderr | 2 +- .../parser/should_compile/DumpRenamedAst.stderr | 2 +- testsuite/tests/printer/T18791.hs | 5 ++ testsuite/tests/printer/T18791.stderr | 63 ++++++++++++++++++++++ testsuite/tests/printer/all.T | 1 + 7 files changed, 90 insertions(+), 13 deletions(-) create mode 100644 testsuite/tests/printer/T18791.hs create mode 100644 testsuite/tests/printer/T18791.stderr diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 0a90fd8fd0..2fd38dbdba 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -631,24 +631,16 @@ mkConDeclH98 name mb_forall mb_cxt args -- provided), context (if provided), argument types, and result type, and -- records whether this is a prefix or record GADT constructor. See -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. --- --- * If -XLinearTypes is not enabled, the function arrows in a prefix GADT --- constructor are always interpreted as linear. If -XLinearTypes is enabled, --- we faithfully record whether -> or %1 -> was used. mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> P (ConDecl GhcPs) mkGadtDecl names ty = do - linearEnabled <- getBit LinearTypesBit - let (args, res_ty) | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty = (RecCon (L loc rf), res_ty) | otherwise = let (arg_types, res_type) = splitHsFunType body_ty - arg_types' | linearEnabled = arg_types - | otherwise = map (hsLinear . hsScaledThing) arg_types - in (PrefixCon arg_types', res_type) + in (PrefixCon arg_types, res_type) pure $ ConDeclGADT { con_g_ext = noExtField , con_names = names diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index d182ba5903..52872deeab 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -43,7 +43,7 @@ import GHC.Tc.Deriv (DerivInfo(..)) import GHC.Tc.Gen.HsType import GHC.Tc.Instance.Class( AssocInstInfo(..) ) import GHC.Tc.Utils.TcMType -import GHC.Builtin.Types ( unitTy, makeRecoveryTyCon ) +import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity import GHC.Rename.Env( lookupConstructorFields ) @@ -3410,11 +3410,27 @@ tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatype tcConArg exp_kind (HsScaled w bty) = do { traceTc "tcConArg 1" (ppr bty) ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind - ; w' <- tcMult w + ; w' <- tcDataConMult w ; traceTc "tcConArg 2" (ppr bty) ; return (Scaled w' arg_ty, getBangStrictness bty) } +tcDataConMult :: HsArrow GhcRn -> TcM Mult +tcDataConMult arr@HsUnrestrictedArrow = do + -- See Note [Function arrows in GADT constructors] + linearEnabled <- xoptM LangExt.LinearTypes + if linearEnabled then tcMult arr else return oneDataConTy +tcDataConMult arr = tcMult arr + {- +Note [Function arrows in GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the absence of -XLinearTypes, we always interpret function arrows +in GADT constructor types as linear, even if the user wrote an +unrestricted arrow. See the "Without -XLinearTypes" section of the +linear types GHC proposal (#111). We opt to do this in the +typechecker, and not in an earlier pass, to ensure that the AST +matches what the user wrote (#18791). + Note [Infix GADT constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not currently have syntax to declare an infix constructor in GADT syntax, diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index 146b686357..2681ca9fb9 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -85,7 +85,7 @@ (Nothing) (PrefixCon [(HsScaled - (HsLinearArrow) + (HsUnrestrictedArrow) ({ T17544_kw.hs:19:18-19 } (HsTupleTy (NoExtField) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 220a2ecd0b..4b5c58d43b 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -370,7 +370,7 @@ (Nothing) (PrefixCon [(HsScaled - (HsLinearArrow) + (HsUnrestrictedArrow) ({ DumpRenamedAst.hs:19:10-34 } (HsParTy (NoExtField) diff --git a/testsuite/tests/printer/T18791.hs b/testsuite/tests/printer/T18791.hs new file mode 100644 index 0000000000..c79204aa55 --- /dev/null +++ b/testsuite/tests/printer/T18791.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} +module T18791 where + +data T where + MkT :: Int -> T diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr new file mode 100644 index 0000000000..00f8efc801 --- /dev/null +++ b/testsuite/tests/printer/T18791.stderr @@ -0,0 +1,63 @@ + +==================== Parser AST ==================== + +({ T18791.hs:1:1 } + (HsModule + (VirtualBraces + (1)) + (Just + ({ T18791.hs:2:8-13 } + {ModuleName: T18791})) + (Nothing) + [] + [({ T18791.hs:(4,1)-(5,17) } + (TyClD + (NoExtField) + (DataDecl + (NoExtField) + ({ T18791.hs:4:6 } + (Unqual + {OccName: T})) + (HsQTvs + (NoExtField) + []) + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ } + []) + (Nothing) + (Nothing) + [({ T18791.hs:5:3-17 } + (ConDeclGADT + (NoExtField) + [({ T18791.hs:5:3-5 } + (Unqual + {OccName: MkT}))] + ({ T18791.hs:5:10-17 } + (False)) + [] + (Nothing) + (PrefixCon + [(HsScaled + (HsUnrestrictedArrow) + ({ T18791.hs:5:10-12 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T18791.hs:5:10-12 } + (Unqual + {OccName: Int})))))]) + ({ T18791.hs:5:17 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T18791.hs:5:17 } + (Unqual + {OccName: T})))) + (Nothing)))] + ({ } + [])))))] + (Nothing) + (Nothing))) \ No newline at end of file diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 9e62577855..2c605be5b8 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -58,3 +58,4 @@ test('T14343b', normal, compile_fail, ['']) test('T15761', normal, compile_fail, ['']) test('T18052a', normal, compile, ['-ddump-simpl -ddump-types -dno-typeable-binds -dsuppress-uniques']) +test('T18791', normal, compile, ['-ddump-parsed-ast']) -- cgit v1.2.1