Commit d6dff830 authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Marge Bot

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
parent 0e8b923d
......@@ -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
......
......@@ -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,
......
......@@ -85,7 +85,7 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsLinearArrow)
(HsUnrestrictedArrow)
({ T17544_kw.hs:19:18-19 }
(HsTupleTy
(NoExtField)
......
......@@ -370,7 +370,7 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsLinearArrow)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:19:10-34 }
(HsParTy
(NoExtField)
......
{-# LANGUAGE GADTs #-}
module T18791 where
data T where
MkT :: Int -> T
==================== 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
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment