summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Parser/PostProcess.hs10
-rw-r--r--compiler/GHC/Tc/TyCl.hs20
-rw-r--r--testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr2
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr2
-rw-r--r--testsuite/tests/printer/T18791.hs5
-rw-r--r--testsuite/tests/printer/T18791.stderr63
-rw-r--r--testsuite/tests/printer/all.T1
7 files changed, 90 insertions, 13 deletions
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)
+ ({ <no location info> }
+ [])
+ (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)))]
+ ({ <no location info> }
+ [])))))]
+ (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'])
View Lorry Controller Status