[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