[commit: ghc] master: Preserve parenthesis in function application in typechecker (cd95c2f)
git at git.haskell.org
git at git.haskell.org
Sat Jun 16 17:28:10 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/cd95c2ffdc5143acd3ae341ff6a19fc603b98db3/ghc
>---------------------------------------------------------------
commit cd95c2ffdc5143acd3ae341ff6a19fc603b98db3
Author: Zubin Duggal <zubin.duggal at gmail.com>
Date: Sat Jun 16 12:19:43 2018 -0400
Preserve parenthesis in function application in typechecker
Preserve HsPars while typechecking
Test Plan: T15242
Reviewers: bgamari, alanz, simonpj
Reviewed By: alanz, simonpj
Subscribers: simonpj, AndreasK, rwbarton, thomie, carter
GHC Trac Issues: #15242
Differential Revision: https://phabricator.haskell.org/D4822
>---------------------------------------------------------------
cd95c2ffdc5143acd3ae341ff6a19fc603b98db3
compiler/typecheck/TcExpr.hs | 55 +++++++++++++++++++---
testsuite/tests/typecheck/should_compile/T15242.hs | 6 +++
.../tests/typecheck/should_compile/T15242.stderr | 34 +++++++++++++
testsuite/tests/typecheck/should_compile/all.T | 16 +++++++
4 files changed, 105 insertions(+), 6 deletions(-)
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 9d75b5a..5d08389 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1098,6 +1098,21 @@ arithSeqEltType (Just fl) res_ty
data HsArg tm ty
= HsValArg tm -- Argument is an ordinary expression (f arg)
| HsTypeArg ty -- Argument is a visible type application (f @ty)
+ | HsArgPar SrcSpan -- See Note [HsArgPar]
+
+{-
+Note [HsArgPar]
+A HsArgPar indicates that everything to the left of this in the argument list is
+enclosed in parenthesis together with the function itself. It is necessary so
+that we can recreate the parenthesis structure in the original source after
+typechecking the arguments.
+
+The SrcSpan is the span of the original HsPar
+
+((f arg1) arg2 arg3) results in an input argument list of
+[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2]
+
+-}
wrapHsArgs :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
=> LHsExpr (GhcPass id)
@@ -1106,14 +1121,26 @@ wrapHsArgs :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
wrapHsArgs f [] = f
wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args
wrapHsArgs f (HsTypeArg t : args) = wrapHsArgs (mkHsAppType f t) args
+wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExt f) args
instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
ppr (HsValArg tm) = text "HsValArg" <> ppr tm
ppr (HsTypeArg ty) = text "HsTypeArg" <> ppr ty
+ ppr (HsArgPar sp) = text "HsArgPar" <> ppr sp
isHsValArg :: HsArg tm ty -> Bool
-isHsValArg (HsValArg {}) = True
+isHsValArg (HsValArg {}) = True
isHsValArg (HsTypeArg {}) = False
+isHsValArg (HsArgPar {}) = False
+
+isArgPar :: HsArg tm ty -> Bool
+isArgPar (HsArgPar {}) = True
+isArgPar (HsValArg {}) = False
+isArgPar (HsTypeArg {}) = False
+
+isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
+isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp
+isArgPar_maybe _ = Nothing
type LHsExprArgIn = HsArg (LHsExpr GhcRn) (LHsWcType GhcRn)
type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn)
@@ -1133,8 +1160,8 @@ tcApp :: Maybe SDoc -- like "The function `f' is applied to"
-- But OpApp is slightly different, so that's why the caller
-- must assemble
-tcApp m_herald (L _ (HsPar _ fun)) args res_ty
- = tcApp m_herald fun args res_ty
+tcApp m_herald (L sp (HsPar _ fun)) args res_ty
+ = tcApp m_herald fun (HsArgPar sp : args) res_ty
tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty
= tcApp m_herald fun (HsValArg arg1 : args) res_ty
@@ -1144,7 +1171,7 @@ tcApp m_herald (L _ (HsAppType ty1 fun)) args res_ty
tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty
| Ambiguous _ lbl <- fld_lbl -- Still ambiguous
- , HsValArg (L _ arg) : _ <- args -- A value arg is first
+ , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first
, Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
@@ -1294,6 +1321,11 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
+ go acc_args n fun_ty (HsArgPar sp : args)
+ = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args
+ ; return (inner_wrap, HsArgPar sp : args', res_ty)
+ }
+
go acc_args n fun_ty (HsTypeArg hs_ty_arg : args)
= do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
-- wrap1 :: fun_ty "->" upsilon_ty
@@ -1881,7 +1913,12 @@ tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
tcTagToEnum loc fun_name args res_ty
= do { fun <- tcLookupId fun_name
- ; arg <- case args of
+ ; let pars1 = mapMaybe isArgPar_maybe before
+ pars2 = mapMaybe isArgPar_maybe after
+ -- args contains exactly one HsValArg
+ (before, _:after) = break isHsValArg args
+
+ ; arg <- case filterOut isArgPar args of
[HsTypeArg hs_ty_arg, HsValArg term_arg]
-> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty
@@ -1914,8 +1951,13 @@ tcTagToEnum loc fun_name args res_ty
; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))
rep_ty = mkTyConApp rep_tc rep_args
+ out_args = concat
+ [ pars1
+ , [HsValArg arg']
+ , pars2
+ ]
- ; return (mkWpCastR (mkTcSymCo coi), fun', [HsValArg arg']) }
+ ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) }
-- coi is a Representational coercion
where
doc1 = vcat [ text "Specify the type by giving a type signature"
@@ -1937,6 +1979,7 @@ too_many_args fun args
pp (HsValArg e) = ppr e
pp (HsTypeArg (HsWC { hswc_body = L _ t })) = pprHsType t
pp (HsTypeArg (XHsWildCardBndrs _)) = panic "too_many_args"
+ pp (HsArgPar _) = empty
{-
diff --git a/testsuite/tests/typecheck/should_compile/T15242.hs b/testsuite/tests/typecheck/should_compile/T15242.hs
new file mode 100644
index 0000000..aa95139
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T15242.hs
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -ddump-tc-ast #-}
+
+module T15242 where
+
+f = (((const) 3)) ((((seq) 'a')) 'b')
+g = ((((((((((id id)) id) id) id))) id))) id
diff --git a/testsuite/tests/typecheck/should_compile/T15242.stderr b/testsuite/tests/typecheck/should_compile/T15242.stderr
new file mode 100644
index 0000000..0435a64
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T15242.stderr
@@ -0,0 +1,34 @@
+({ T15242.hs:6:5-41 }
+(HsPar
+({ T15242.hs:6:6-40 }
+(HsPar
+({ T15242.hs:6:7-39 }
+(HsPar
+({ T15242.hs:6:8-35 }
+(HsPar
+({ T15242.hs:6:9-34 }
+(HsPar
+({ T15242.hs:6:10-33 }
+(HsPar
+({ T15242.hs:6:11-29 }
+(HsPar
+({ T15242.hs:6:12-25 }
+(HsPar
+({ T15242.hs:6:13-21 }
+(HsPar
+({ T15242.hs:6:14-20 }
+(HsPar
+({ T15242.hs:5:5-17 }
+(HsPar
+({ T15242.hs:5:6-16 }
+(HsPar
+({ T15242.hs:5:7-13 }
+(HsPar
+({ T15242.hs:5:19-37 }
+(HsPar
+({ T15242.hs:5:20-32 }
+(HsPar
+({ T15242.hs:5:21-31 }
+(HsPar
+({ T15242.hs:5:22-26 }
+(HsPar
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index beaea5d..d14e416 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -624,3 +624,19 @@ test('T14735', normal, compile, [''])
test('T15180', normal, compile, [''])
test('T15232', normal, compile, [''])
test('T13833', normal, compile, [''])
+
+def onlyHsParLocs(x):
+ """
+ We only want to check that all the parenthesis are present with the correct location,
+ not compare the entire typechecked AST.
+ Located (HsPar GhcTc) are pretty printed with the form
+ ({ <location info>
+ (HsPar
+ This function tries to extract all such location infos from the typechecked AST.
+ """
+ ls = x.split("\n")
+ filteredLines = (loc.strip() for (loc,hspar) in zip(ls,ls[1:])
+ if hspar.strip().startswith("(HsPar")
+ and not "<no location info>" in loc)
+ return '\n'.join(filteredLines)
+test('T15242', normalise_errmsg_fun(onlyHsParLocs), compile, [''])
More information about the ghc-commits
mailing list