Commit 972730cc authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Refactor visible type application.

This replaces the old HsType and HsTypeOut constructors
with HsAppType and HsAppTypeOut, leading to some simplification.
(This refactoring addresses #11329.)

This also fixes #11456, which stumbled over HsType (which is
not an expression).

test case: ghci/scripts/T11456

[skip ci]
parent 35d37ff8
......@@ -482,13 +482,15 @@ addTickLHsExprNever (L pos e0) = do
-- general heuristic: expressions which do not denote values are good
-- break points
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr _other = False
isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (HsAppTypeOut {}) = True
isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr _other = False
isCallSite :: HsExpr Id -> Bool
isCallSite HsApp{} = True
isCallSite OpApp{} = True
isCallSite HsApp{} = True
isCallSite HsAppTypeOut{} = True
isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
......@@ -518,13 +520,10 @@ addTickHsExpr e@(HsOverLabel _) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) e2'
-- This might be a type application. Then don't put a tick around e2,
-- or dsExpr won't recognize it as a type application any more (#11329).
-- It doesn't make sense to put a tick on a type anyways.
where e2'
| isLHsTypeExpr e2 = return e2
| otherwise = addTickLHsExpr e2
addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1)
(addTickLHsExpr e2)
addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
(return ty)
addTickHsExpr (OpApp e1 e2 fix e3) =
liftM4 OpApp
......
......@@ -234,10 +234,11 @@ dsExpr (HsLamCase arg matches)
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
dsExpr e@(HsApp fun arg)
= mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
dsExpr (HsAppTypeOut e _)
-- ignore type arguments here; they're in the wrappers instead at this point
| isLHsTypeExpr arg = dsLExpr fun
| otherwise = mkCoreAppDs (text "HsApp" <+> ppr e)
<$> dsLExpr fun <*> dsLExpr arg
= dsLExpr e
{-
......@@ -730,16 +731,10 @@ dsExpr (EWildPat {}) = panic "dsExpr:EWildPat"
dsExpr (EAsPat {}) = panic "dsExpr:EAsPat"
dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
dsExpr (HsType {}) = panic "dsExpr:HsType" -- removed by typechecker
dsExpr (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
-- Normally handled in HsApp case, but a GHC API user might try to desugar
-- an HsTypeOut, since it is an HsExpr in a typechecked module after all.
-- (Such as ghci itself, in #11456.) So improve the error message slightly.
dsExpr (HsTypeOut {})
= panic "dsExpr: tried to desugar a naked type application argument (HsTypeOut)"
------------------------------
dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExpr { syn_expr = expr
......
......@@ -309,8 +309,8 @@ repDataDefn tc bndrs opt_tys
}
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
-> LHsType Name
-> DsM (Core TH.DecQ)
-> LHsType Name
-> DsM (Core TH.DecQ)
repSynDecl tc bndrs ty
= do { ty1 <- repLTy ty
; repTySyn tc bndrs ty1 }
......
......@@ -9,6 +9,7 @@
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
-- | Abstract Haskell syntax for expressions.
module HsExpr where
......@@ -203,6 +204,16 @@ data HsExpr id
| HsApp (LHsExpr id) (LHsExpr id) -- ^ Application
| HsAppType (LHsExpr id) (LHsWcType id) -- ^ Visible type application
--
-- Explicit type argument; e.g f @Int x y
-- NB: Has wildcards, but no implicit quantification
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
| HsAppTypeOut (LHsExpr id) (LHsWcType Name) -- just for pretty-printing
-- | Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
......@@ -545,14 +556,6 @@ data HsExpr id
-- For details on above see note [Api annotations] in ApiAnnotation
| ELazyPat (LHsExpr id) -- ~ pattern
-- | Use for type application in expressions.
-- 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-- For details on above see note [Api annotations] in ApiAnnotation
| HsType (LHsWcType id) -- Explicit type argument; e.g f @Int x y
-- NB: Has wildcards, but no implicit quant.
| HsTypeOut (LHsWcType Name) -- just for pretty-printing
---------------------------------------
-- Finally, HsWrap appears only in typechecker output
......@@ -663,10 +666,12 @@ isQuietHsExpr :: HsExpr id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
isQuietHsExpr (HsPar _) = True
isQuietHsExpr (HsPar _) = True
-- applications don't display anything themselves
isQuietHsExpr (HsApp _ _) = True
isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr (HsApp _ _) = True
isQuietHsExpr (HsAppType _ _) = True
isQuietHsExpr (HsAppTypeOut _ _) = True
isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
......@@ -689,12 +694,9 @@ ppr_expr (HsPar e) = parens (ppr_lexpr e)
ppr_expr (HsCoreAnn _ (StringLiteral _ s) e)
= vcat [text "HsCoreAnn" <+> ftext s, ppr_lexpr e]
ppr_expr (HsApp e1 e2)
= let (fun, args) = collect_args e1 [e2] in
hang (ppr_lexpr fun) 2 (sep (map pprParendLExpr args))
where
collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
ppr_expr e@(HsApp {}) = ppr_apps e []
ppr_expr e@(HsAppType {}) = ppr_apps e []
ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
ppr_expr (OpApp e1 op _ e2)
= case unLoc op of
......@@ -815,11 +817,6 @@ ppr_expr (HsWrap co_fn e)
= pprHsWrapper co_fn (\parens -> if parens then pprParendExpr e
else pprExpr e)
ppr_expr (HsType (HsWC { hswc_body = ty }))
= char '@' <> pprParendHsType (unLoc ty)
ppr_expr (HsTypeOut (HsWC { hswc_body = ty }))
= char '@' <> pprParendHsType (unLoc ty)
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsRnBracketOut e []) = ppr e
......@@ -868,6 +865,26 @@ ppr_expr (HsArrForm op _ args)
4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
ppr_expr (HsRecFld f) = ppr f
-- We must tiresomely make the "id" parameter to the LHsWcType existential
-- because it's different in the HsAppType case and the HsAppTypeOut case
data LHsWcTypeX = forall id. OutputableBndr id => LHsWcTypeX (LHsWcType id)
ppr_apps :: OutputableBndr id
=> HsExpr id
-> [Either (LHsExpr id) LHsWcTypeX]
-> SDoc
ppr_apps (HsApp (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
ppr_apps (HsAppType (L _ fun) arg) args
= ppr_apps fun (Right (LHsWcTypeX arg) : args)
ppr_apps (HsAppTypeOut (L _ fun) arg) args
= ppr_apps fun (Right (LHsWcTypeX arg) : args)
ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
where
pp (Left arg) = pprParendLExpr arg
pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
= char '@' <> pprParendHsType arg
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
= ppr (src,(n1,n2),(n3,n4))
......@@ -923,8 +940,6 @@ hsExprNeedsParens (HsTcBracketOut {}) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
hsExprNeedsParens (HsRecFld{}) = False
hsExprNeedsParens (HsType {}) = False
hsExprNeedsParens (HsTypeOut {}) = False
hsExprNeedsParens _ = True
......
......@@ -20,13 +20,13 @@ which deal with the instantiated versions are located elsewhere:
module HsUtils(
-- Terms
mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkSimpleHsAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
nlHsIntLit, nlHsVarApps,
......@@ -169,6 +169,12 @@ mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id
mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
......@@ -458,21 +464,6 @@ nlHsFunTy a b = noLoc (HsFunTy a b)
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
-- | Extract a type argument from an HsExpr, with the list of wildcards in
-- the type
isLHsTypeExpr_maybe :: LHsExpr name -> Maybe (LHsWcType name)
isLHsTypeExpr_maybe (L _ (HsPar e)) = isLHsTypeExpr_maybe e
isLHsTypeExpr_maybe (L _ (HsType ty)) = Just ty
-- the HsTypeOut case is ill-typed. We never need it here anyway.
isLHsTypeExpr_maybe _ = Nothing
-- | Is an expression a visible type application?
isLHsTypeExpr :: LHsExpr name -> Bool
isLHsTypeExpr (L _ (HsPar e)) = isLHsTypeExpr e
isLHsTypeExpr (L _ (HsType _)) = True
isLHsTypeExpr (L _ (HsTypeOut _)) = True
isLHsTypeExpr _ = False
{-
Tuples. All these functions are *pre-typechecker* because they lack
types on the tuple.
......@@ -1132,4 +1123,3 @@ lPatImplicits = hs_lpat
(unLoc fld)
pat_explicit = maybe True (i<) (rec_dotdot fs)]
details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2
......@@ -2241,10 +2241,12 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
}
fexp :: { LHsExpr RdrName }
: fexp aexp { sLL $1 $> $ HsApp $1 $2 }
| 'static' aexp {% ams (sLL $1 $> $ HsStatic $2)
[mj AnnStatic $1] }
| aexp { $1 }
: fexp aexp { sLL $1 $> $ HsApp $1 $2 }
| fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
[mj AnnAt $2] }
| 'static' aexp {% ams (sLL $1 $> $ HsStatic $2)
[mj AnnStatic $1] }
| aexp { $1 }
aexp :: { LHsExpr RdrName }
: qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }
......@@ -2252,7 +2254,6 @@ aexp :: { LHsExpr RdrName }
-- Note [Lexing type applications] in Lexer.x
| '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
| TYPEAPP atype {% ams (sLL $1 $> $ HsType (mkHsWildCardBndrs $2)) [mj AnnAt $1] }
| aexp1 { $1 }
aexp1 :: { LHsExpr RdrName }
......
......@@ -146,6 +146,11 @@ rnExpr (HsApp fun arg)
; (arg',fvArg) <- rnLExpr arg
; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
rnExpr (HsAppType fun arg)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }
rnExpr (OpApp e1 op _ e2)
= do { (e1', fv_e1) <- rnLExpr e1
; (e2', fv_e2) <- rnLExpr e2
......@@ -303,10 +308,6 @@ rnExpr (HsMultiIf _ty alts)
-- ; return (HsMultiIf ty alts', fvs) }
; return (HsMultiIf placeHolderType alts', fvs) }
rnExpr (HsType ty)
= do { (ty', fvT) <- rnHsWcType HsTypeCtx ty
; return (HsType ty', fvT) }
rnExpr (ArithSeq _ _ seq)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (new_seq, fvs) <- rnArithSeq seq
......@@ -1754,6 +1755,7 @@ isReturnApp (L _ (HsApp f arg))
| otherwise = Nothing
where
is_return (L _ (HsPar e)) = is_return e
is_return (L _ (HsAppType e _)) = is_return e
is_return (L _ (HsVar (L _ r))) = r == returnMName || r == pureAName
-- TODO: I don't know how to get this right for rebindable syntax
is_return _ = False
......
......@@ -1024,6 +1024,7 @@ validRuleLhs foralls lhs
check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
check (HsAppType e _) = checkl e
check (HsVar (L _ v)) | v `notElem` foralls = Nothing
check other = Just other -- Failure
......
This diff is collapsed.
......@@ -609,6 +609,11 @@ zonkExpr env (HsApp e1 e2)
new_e2 <- zonkLExpr env e2
return (HsApp new_e1 new_e2)
zonkExpr env (HsAppTypeOut e t)
= do new_e <- zonkLExpr env e
return (HsAppTypeOut new_e t)
-- NB: the type is an HsType; can't zonk that!
zonkExpr _ e@(HsRnBracketOut _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
......@@ -772,9 +777,6 @@ zonkExpr env (HsWrap co_fn expr)
zonkExpr _ (HsUnboundVar v)
= return (HsUnboundVar v)
-- nothing to do here. The payload is an LHsType, not a Type.
zonkExpr _ e@(HsTypeOut {}) = return e
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
-------------------------------------------------------------------------
......
......@@ -2816,6 +2816,8 @@ exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
exprCtOrigin (HsLam matches) = matchesCtOrigin matches
exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms
exprCtOrigin (HsApp (L _ e1) _) = exprCtOrigin e1
exprCtOrigin (HsAppType (L _ e1) _) = exprCtOrigin e1
exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut"
exprCtOrigin (OpApp _ (L _ op) _ _) = exprCtOrigin op
exprCtOrigin (NegApp (L _ e) _) = exprCtOrigin e
exprCtOrigin (HsPar (L _ e)) = exprCtOrigin e
......@@ -2853,8 +2855,6 @@ exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat"
exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat"
exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat"
exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat"
exprCtOrigin (HsType {}) = Shouldn'tHappenOrigin "type application"
exprCtOrigin (HsTypeOut {}) = panic "exprCtOrigin HsTypeOut"
exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap"
-- | Extract a suitable CtOrigin from a MatchGroup
......
{-# LANGUAGE TypeApplications #-}
module T11456 where
a = show @Int
Collecting type info for 1 module(s) ...
......@@ -245,3 +245,4 @@ test('T11266', check_stdout(lambda *args: 1), ghci_script, ['T11266.script'])
test('T11389', req_interp, run_command, ['$MAKE -s --no-print-directory T11389'])
test('T11524a', normal, ghci_script, ['T11524a.script'])
test('T11456', normal, ghci_script, ['T11456.script'])
T9605.hs:7:6:
Couldn't match type ‘Bool’ with ‘m Bool’
Expected type: t0 -> m Bool
Actual type: t0 -> Bool
The function ‘f1’ is applied to one argument,
its type is ‘m0 Bool’,
it is specialized to ‘t0 -> Bool’
In the expression: f1 undefined
In an equation for ‘f2’: f2 = f1 undefined
Relevant bindings include f2 :: m Bool (bound at T9605.hs:7:1)
T9605.hs:7:6: error:
Couldn't match type ‘Bool’ with ‘m Bool’
Expected type: t1 -> m Bool
Actual type: t1 -> Bool
The function ‘f1’ is applied to one argument,
its type is ‘m0 Bool’,
it is specialized to ‘t1 -> Bool’
In the expression: f1 undefined
In an equation for ‘f2’: f2 = f1 undefined
Relevant bindings include f2 :: m Bool (bound at T9605.hs:7:1)
......@@ -13,7 +13,7 @@ VtaFail.hs:12:26: error:
answer_constraint_fail = addOne @Bool 5
VtaFail.hs:14:17: error:
• Cannot apply expression of type ‘t0 -> t0
• Cannot apply expression of type ‘t1 -> t1
to a visible type argument ‘Int’
• In the expression: (\ x -> x) @Int 12
In an equation for ‘answer_lambda’:
......
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