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
......
......@@ -73,6 +73,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Data.Function
import Data.List
import Data.Either
import qualified Data.Set as Set
{-
......@@ -163,9 +164,8 @@ tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty
tcExpr (HsApp e1 e2) res_ty
= do { (wrap, fun, args) <- tcApp Nothing e1 [e2] res_ty
; return (mkHsWrap wrap $ unLoc $ foldl mkHsApp fun args) }
tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; tcWrapResult e (HsLit lit) lit_ty res_ty }
......@@ -257,11 +257,6 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty
; let expr'' = ExprWithTySigOut expr' sig_ty
; tcWrapResult e expr'' poly_ty res_ty }
tcExpr (HsType ty) _
= failWithTc (sep [ text "Type argument used outside of a function argument:"
, ppr ty ])
{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -404,9 +399,9 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
| otherwise
= do { traceTc "Non Application rule" (ppr op)
; (wrap, op', [arg1', arg2'])
; (wrap, op', [Left arg1', Left arg2'])
<- tcApp (Just $ mk_op_msg op)
op [arg1, arg2] res_ty
op [Left arg1, Left arg2] res_ty
; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
-- Right sections, equivalent to \ x -> x `op` expr, or
......@@ -1059,10 +1054,22 @@ arithSeqEltType (Just fl) res_ty
************************************************************************
-}
type LHsExprArgIn = Either (LHsExpr Name) (LHsWcType Name)
type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name)
tcApp1 :: HsExpr Name -- either HsApp or HsAppType
-> ExpRhoType -> TcM (HsExpr TcId)
tcApp1 e res_ty
= do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) }
where
mk_hs_app f (Left a) = mkHsApp f a
mk_hs_app f (Right a) = mkHsAppTypeOut f a
tcApp :: Maybe SDoc -- like "The function `f' is applied to"
-- or leave out to get exactly that message
-> LHsExpr Name -> [LHsExpr Name] -- Function and args
-> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
-> LHsExpr Name -> [LHsExprArgIn] -- Function and args
-> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
-- (wrap, fun, args). For an ordinary function application,
-- these should be assembled as (wrap (fun args)).
-- But OpApp is slightly different, so that's why the caller
......@@ -1071,21 +1078,24 @@ tcApp :: Maybe SDoc -- like "The function `f' is applied to"
tcApp m_herald orig_fun orig_args res_ty
= go orig_fun orig_args
where
go (L _ (HsPar e)) args = go e args
go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
go :: LHsExpr Name -> [LHsExprArgIn]
-> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
go (L _ (HsPar e)) args = go e args
go (L _ (HsApp e1 e2)) args = go e1 (Left e2:args)
go (L _ (HsAppType e t)) args = go e (Right t:args)
go (L loc (HsVar (L _ fun))) args
| fun `hasKey` tagToEnumKey
, count (not . isLHsTypeExpr) args == 1
, count isLeft args == 1
= do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
; return (wrap, expr, args) }
| fun `hasKey` seqIdKey
, count (not . isLHsTypeExpr) args == 2
, count isLeft args == 2
= do { (wrap, expr, args) <- tcSeq loc fun args res_ty
; return (wrap, expr, args) }
go (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg : _)
go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)
| Just sig_ty <- obviousSig arg
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
......@@ -1104,11 +1114,14 @@ tcApp m_herald orig_fun orig_args res_ty
-- up to call that function
; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
tcSubTypeDS_NC_O orig GenSigCtxt
(Just $ foldl mkHsApp fun args)
(Just $ foldl mk_hs_app fun args)
actual_res_ty res_ty
; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
mk_hs_app f (Left a) = mkHsApp f a
mk_hs_app f (Right a) = mkHsAppType f a
mk_app_msg :: LHsExpr Name -> SDoc
mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun)
, text "is applied to"]
......@@ -1145,9 +1158,9 @@ tcInferFun fun
tcArgs :: LHsExpr Name -- ^ The function itself (for err msgs only)
-> TcSigmaType -- ^ the (uninstantiated) type of the function
-> CtOrigin -- ^ the origin for the function's type
-> [LHsExpr Name] -- ^ the args
-> [LHsExprArgIn] -- ^ the args
-> SDoc -- ^ the herald for matchActualFunTys
-> TcM (HsWrapper, [LHsExpr TcId], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
-- ^ (a wrapper for the function, the tc'd args, result type)
tcArgs fun orig_fun_ty fun_orig orig_args herald
= go [] 1 orig_fun_ty orig_args
......@@ -1156,8 +1169,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
go acc_args n fun_ty (arg:args)
| Just hs_ty_arg <- isLHsTypeExpr_maybe arg
go acc_args n fun_ty (Right hs_ty_arg:args)
= do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
-- wrap1 :: fun_ty "->" upsilon_ty
; case tcSplitForAllTy_maybe upsilon_ty of
......@@ -1172,11 +1184,11 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
-- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
; let inst_wrap = mkWpTyApps [ty_arg]
; return ( inner_wrap <.> inst_wrap <.> wrap1
, L (getLoc arg) (HsTypeOut hs_ty_arg) : args'
, Right hs_ty_arg : args'
, res_ty ) }
_ -> ty_app_err upsilon_ty hs_ty_arg }
| otherwise -- not a type application.
go acc_args n fun_ty (Left arg : args)
= do { (wrap, [arg_ty], res_ty)
<- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
acc_args orig_arity
......@@ -1186,7 +1198,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
<- go (arg_ty : acc_args) (n+1) res_ty args
-- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap
, arg' : args'
, Left arg' : args'
, inner_res_ty ) }
ty_app_err ty arg
......@@ -1650,16 +1662,15 @@ the users that complain.
-}
tcSeq :: SrcSpan -> Name -> [LHsExpr Name]
-> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]
-> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
-- (seq e1 e2) :: res_ty
-- We need a special typing rule because res_ty can be unboxed
-- See Note [Typing rule for seq]
tcSeq loc fun_name args res_ty
= do { fun <- tcLookupId fun_name
; (arg1_ty, args1) <- case args of
(ty_arg_expr1 : args1)
| Just hs_ty_arg1 <- isLHsTypeExpr_maybe ty_arg_expr1
(Right hs_ty_arg1 : args1)
-> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind
; return (ty_arg1, args1) }
......@@ -1667,47 +1678,41 @@ tcSeq loc fun_name args res_ty
; return (arg_ty1, args) }
; (arg1, arg2, arg2_exp_ty) <- case args1 of
[ty_arg_expr2, term_arg1, term_arg2]
| Just hs_ty_arg2 <- isLHsTypeExpr_maybe ty_arg_expr2
[Right hs_ty_arg2, Left term_arg1, Left term_arg2]
-> do { rr_ty <- newFlexiTyVarTy runtimeRepTy
; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE rr_ty)
-- see Note [Typing rule for seq]
; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty
; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
[term_arg1, term_arg2] -> return (term_arg1, term_arg2, res_ty)
_ -> too_many_args
[Left term_arg1, Left term_arg2]
-> return (term_arg1, term_arg2, res_ty)
_ -> too_many_args "seq" args
; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
; arg2' <- tcMonoExpr arg2 arg2_exp_ty
; res_ty <- readExpType res_ty -- by now, it's surely filled in
; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun)))
ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
; return (idHsWrapper, fun', [arg1', arg2']) }
where
too_many_args :: TcM a
too_many_args
= failWith $
hang (text "Too many type arguments to seq:")
2 (sep (map pprParendLExpr args))
tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> ExpRhoType
-> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
-> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
-- tagToEnum# :: forall a. Int# -> a
-- See Note [tagToEnum#] Urgh!
tcTagToEnum loc fun_name args res_ty
= do { fun <- tcLookupId fun_name
; arg <- case args of
[ty_arg_expr, term_arg]
| Just hs_ty_arg <- isLHsTypeExpr_maybe ty_arg_expr
[Right hs_ty_arg, Left term_arg]
-> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg res_ty
-- other than influencing res_ty, we just
-- don't care about a type arg passed in.
-- So drop the evidence.
; return term_arg }
[term_arg] -> do { _ <- expTypeToType res_ty
; return term_arg }
_ -> too_many_args
[Left term_arg] -> do { _ <- expTypeToType res_ty
; return term_arg }
_ -> too_many_args "tagToEnum#" args
; res_ty <- readExpType res_ty
; ty' <- zonkTcType res_ty
......@@ -1731,7 +1736,7 @@ tcTagToEnum loc fun_name args res_ty
; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
rep_ty = mkTyConApp rep_tc rep_args
; return (mkWpCastR (mkTcSymCo coi), fun', [arg']) }
; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
-- coi is a Representational coercion
where
doc1 = vcat [ text "Specify the type by giving a type signature"
......@@ -1744,11 +1749,15 @@ tcTagToEnum loc fun_name args res_ty
<+> text "at type" <+> ppr ty)
2 what
too_many_args :: TcM a
too_many_args
= failWith $
hang (text "Too many type arguments to tagToEnum#:")
2 (sep (map pprParendLExpr args))
too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args fun args
= failWith $
hang (text "Too many type arguments to" <+> text fun <> colon)
2 (sep (map pp args))
where
pp (Left e) = pprParendLExpr e
pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
{-
************************************************************************
......
......@@ -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"