[Git][ghc/ghc][wip/T18791] Preserve as-parsed arrow type for HsUnrestrictedArrow
Alan Zimmerman
gitlab at gitlab.haskell.org
Sun Oct 4 08:42:43 UTC 2020
Alan Zimmerman pushed to branch wip/T18791 at Glasgow Haskell Compiler / GHC
Commits:
1314c472 by Alan Zimmerman at 2020-10-04T09:42:12+01:00
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
- - - - -
7 changed files:
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/TyCl.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- + testsuite/tests/printer/T18791.hs
- + testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/all.T
Changes:
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -639,16 +639,12 @@ 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
=====================================
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 )
@@ -3411,10 +3411,23 @@ tcConArg exp_kind (HsScaled w bty)
= do { traceTc "tcConArg 1" (ppr bty)
; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind
; w' <- tcMult w
+ ; linearEnabled <- xoptM LangExt.LinearTypes
+ ; let interp_w -- See Note [Function arrows in GADT constructors]
+ | linearEnabled = w'
+ | otherwise = oneDataConTy
; traceTc "tcConArg 2" (ppr bty)
- ; return (Scaled w' arg_ty, getBangStrictness bty) }
+ ; return (Scaled interp_w arg_ty, getBangStrictness bty) }
{-
+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,
=====================================
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)
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -370,7 +370,7 @@
(Nothing)
(PrefixCon
[(HsScaled
- (HsLinearArrow)
+ (HsUnrestrictedArrow)
({ DumpRenamedAst.hs:19:10-34 }
(HsParTy
(NoExtField)
=====================================
testsuite/tests/printer/T18791.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE GADTs #-}
+module T18791 where
+
+data T where
+ MkT :: Int -> T
=====================================
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
=====================================
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 it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1314c472713fd94c818d26c495efd57eb416f1a5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1314c472713fd94c818d26c495efd57eb416f1a5
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/20201004/93c6c9a2/attachment-0001.html>
More information about the ghc-commits
mailing list