Commit 2db18b81 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Visible type application

This re-working of the typechecker algorithm is based on
the paper "Visible type application", by Richard Eisenberg,
Stephanie Weirich, and Hamidhasan Ahmed, to be published at
ESOP'16.

This patch introduces -XTypeApplications, which allows users
to say, for example `id @Int`, which has type `Int -> Int`. See
the changes to the user manual for details.

This patch addresses tickets #10619, #5296, #10589.
parent 48db13d2
......@@ -768,7 +768,7 @@ mkDataCon name declared_infix prom_info
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
rep_arg_tys = dataConRepArgTys con
rep_ty = mkInvForAllTys univ_tvs $ mkInvForAllTys ex_tvs $
rep_ty = mkSpecForAllTys univ_tvs $ mkInvForAllTys ex_tvs $
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
......@@ -1024,8 +1024,8 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkInvForAllTys ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
ex_tvs) $
= mkSpecForAllTys ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
ex_tvs) $
mkFunTys theta $
mkFunTys arg_tys $
res_ty
......
......@@ -281,8 +281,8 @@ mkDictSelId name clas
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
sel_ty = mkInvForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars))
(getNth arg_tys val_index))
sel_ty = mkSpecForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars))
(getNth arg_tys val_index))
base_info = noCafIdInfo
`setArityInfo` 1
......@@ -930,7 +930,7 @@ mkPrimOpId prim_op
= id
where
(tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
ty = mkInvForAllTys tyvars (mkFunTys arg_tys res_ty)
ty = mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty)
name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
(mkPrimOpIdUnique (primOpTag prim_op))
(AnId id) UserSyntax
......@@ -1014,7 +1014,7 @@ mkDictFunId dfun_name tvs theta clas tys
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
mkDictFunTy tvs theta clas tys
= mkInvSigmaTy tvs theta (mkClassPred clas tys)
= mkSpecSigmaTy tvs theta (mkClassPred clas tys)
{-
************************************************************************
......@@ -1062,7 +1062,7 @@ dollarId = pcMiscPrelId dollarName ty
(noCafIdInfo `setUnfoldingInfo` unf)
where
fun_ty = mkFunTy alphaTy openBetaTy
ty = mkInvForAllTys [levity2TyVar, alphaTyVar, openBetaTyVar] $
ty = mkSpecForAllTys [levity2TyVar, alphaTyVar, openBetaTyVar] $
mkFunTy fun_ty fun_ty
unf = mkInlineUnfolding (Just 2) rhs
[f,x] = mkTemplateLocals [fun_ty, alphaTy]
......@@ -1076,7 +1076,7 @@ proxyHashId
= pcMiscPrelId proxyName ty
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings]
where
ty = mkInvForAllTys [kv, tv] (mkProxyPrimTy k t)
ty = mkSpecForAllTys [kv, tv] (mkProxyPrimTy k t)
kv = kKiVar
k = mkTyVarTy kv
[tv] = mkTemplateTyVars [k]
......@@ -1091,9 +1091,9 @@ unsafeCoerceId
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkInvForAllTys [ levity1TyVar, levity2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy openAlphaTy openBetaTy)
ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy openAlphaTy openBetaTy)
[x] = mkTemplateLocals [openAlphaTy]
rhs = mkLams [ levity1TyVar, levity2TyVar
......@@ -1125,8 +1125,8 @@ seqId = pcMiscPrelId seqName ty info
-- LHS of rules. That way we can have rules for 'seq';
-- see Note [seqId magic]
ty = mkInvForAllTys [alphaTyVar,betaTyVar]
(mkFunTy alphaTy (mkFunTy betaTy betaTy))
ty = mkSpecForAllTys [alphaTyVar,betaTyVar]
(mkFunTy alphaTy (mkFunTy betaTy betaTy))
[x,y] = mkTemplateLocals [alphaTy, betaTy]
rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
......@@ -1158,16 +1158,16 @@ lazyId :: Id -- See Note [lazyId magic]
lazyId = pcMiscPrelId lazyIdName ty info
where
info = noCafIdInfo
ty = mkInvForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
oneShotId :: Id -- See Note [The oneShot function]
oneShotId = pcMiscPrelId oneShotName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkInvForAllTys [ levity1TyVar, levity2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy fun_ty fun_ty)
ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy fun_ty fun_ty)
fun_ty = mkFunTy alphaTy betaTy
[body, x] = mkTemplateLocals [fun_ty, openAlphaTy]
x' = setOneShotLambda x
......@@ -1188,7 +1188,7 @@ runRWId = pcMiscPrelId runRWName ty info
arg_ty = stateRW `mkFunTy` ret_ty
-- (State# RealWorld -> (# State# RealWorld, o #))
-- -> (# State# RealWorld, o #)
ty = mkInvForAllTys [levity1TyVar, openAlphaTyVar] $
ty = mkSpecForAllTys [levity1TyVar, openAlphaTyVar] $
arg_ty `mkFunTy` ret_ty
--------------------------------------------------------------------------------
......@@ -1196,7 +1196,7 @@ magicDictId :: Id -- See Note [magicDictId magic]
magicDictId = pcMiscPrelId magicDictName ty info
where
info = noCafIdInfo `setInlinePragInfo` neverInlinePragma
ty = mkInvForAllTys [alphaTyVar] alphaTy
ty = mkSpecForAllTys [alphaTyVar] alphaTy
--------------------------------------------------------------------------------
......@@ -1210,7 +1210,7 @@ coerceId = pcMiscPrelId coerceName ty info
eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind
, liftedTypeKind
, alphaTy, betaTy ]
ty = mkInvForAllTys [alphaTyVar, betaTyVar] $
ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $
mkFunTys [eqRTy, alphaTy] betaTy
[eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy]
......
......@@ -25,7 +25,7 @@ module PatSyn (
#include "HsVersions.h"
import Type
import TcType( mkInvSigmaTy )
import TcType( mkSpecSigmaTy )
import Name
import Outputable
import Unique
......@@ -328,8 +328,8 @@ patSynType :: PatSyn -> Type
patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, psExTyVars = ex_tvs, psProvTheta = prov_theta
, psArgs = orig_args, psOrigResTy = orig_res_ty })
= mkInvSigmaTy univ_tvs req_theta $
mkInvSigmaTy ex_tvs prov_theta $
= mkSpecSigmaTy univ_tvs req_theta $ -- use mkSpecSigmaTy because it
mkSpecSigmaTy ex_tvs prov_theta $ -- prints better
mkFunTys orig_args orig_res_ty
-- | Should the 'PatSyn' be presented infix?
......
......@@ -62,7 +62,7 @@ import TysWiredIn
import PrelNames
import HsUtils ( mkChunkified, chunkify )
import TcType ( mkInvSigmaTy )
import TcType ( mkSpecSigmaTy )
import Type
import Coercion ( isCoVar )
import TysPrim
......@@ -684,8 +684,8 @@ mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
runtimeErrorTy :: Type
-- The runtime error Ids take a UTF8-encoded string as argument
runtimeErrorTy = mkInvSigmaTy [levity1TyVar, openAlphaTyVar] []
(mkFunTy addrPrimTy openAlphaTy)
runtimeErrorTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] []
(mkFunTy addrPrimTy openAlphaTy)
errorName :: Name
errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
......@@ -694,7 +694,7 @@ eRROR_ID :: Id
eRROR_ID = pc_bottoming_Id2 errorName errorTy
errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
errorTy = mkInvSigmaTy [levity1TyVar, openAlphaTyVar] []
errorTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] []
(mkFunTys [ mkClassPred
ipClass
[ mkStrLitTy (fsLit "callStack")
......@@ -709,7 +709,7 @@ uNDEFINED_ID :: Id
uNDEFINED_ID = pc_bottoming_Id1 undefinedName undefinedTy
undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
undefinedTy = mkInvSigmaTy [levity1TyVar, openAlphaTyVar] []
undefinedTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] []
(mkFunTy (mkClassPred
ipClass
[ mkStrLitTy (fsLit "callStack")
......@@ -727,7 +727,7 @@ Notice the levity polymophism. This ensures that
* unboxed as well as boxed types
* polymorphic types
This is OK because it never returns, so the return type is irrelevant.
See Note [Sort-polymorphic tyvars accept foralls] in TcUnify.
See Note [Sort-polymorphic tyvars accept foralls] in TcMType.
************************************************************************
......
......@@ -632,7 +632,7 @@ addTickHsExpr (ExprWithTySigOut e ty) =
(addTickLHsExprNever e) -- No need to tick the inner expression
(return ty) -- for expressions with signatures
addTickHsExpr e@(HsType _) = return e
addTickHsExpr e@(HsTypeOut _) = return e
-- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
......@@ -870,8 +870,8 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) =
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
addTickHsCmd (HsCmdCast co cmd)
= liftM2 HsCmdCast (return co) (addTickHsCmd cmd)
addTickHsCmd (HsCmdWrap w cmd)
= liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
......
......@@ -614,9 +614,9 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
return (mkApps (App core_op (Type env_ty)) core_args,
unionVarSets fv_sets)
dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do
dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
(core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
wrapped_cmd <- dsHsWrapper (mkWpCastN coercion) core_cmd
wrapped_cmd <- dsHsWrapper wrap core_cmd
return (wrapped_cmd, env_ids')
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
......
......@@ -160,20 +160,23 @@ dsHsBind dflags
(AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
| ABE { abe_wrap = wrap, abe_poly = global
| ABE { abe_inst_wrap = inst_wrap, abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
, not (xopt LangExt.Strict dflags) -- handle strict binds
, not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
= -- push type constraints deeper for pattern match check
-- See Note [AbsBinds wrappers] in HsBinds
addDictsDs (toTcTypeBag (listToBag dicts)) $
do { (_, bind_prs) <- ds_lhs_binds binds
; let core_bind = Rec bind_prs
; ds_binds <- dsTcEvBinds_s ev_binds
; inner_rhs <- dsHsWrapper inst_wrap $
Let core_bind $
Var local
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
Var local
inner_rhs
; (spec_binds, rules) <- dsSpecs rhs prags
......@@ -212,13 +215,17 @@ dsHsBind dflags
-- Note [Desugar Strict binds]
; (exported_force_vars, extra_exports) <- get_exports local_force_vars
; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
; let mk_bind (ABE { abe_inst_wrap = inst_wrap, abe_wrap = wrap
, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
-- See Note [AbsBinds wrappers] in HsBinds
= do { tup_id <- newSysLocalDs tup_ty
; inner_rhs <- dsHsWrapper inst_wrap $
mkTupleSelector all_locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
mkTupleSelector all_locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
mkLams tyvars $ mkLams dicts $
inner_rhs
; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = (global `setInlinePragma` defaultInlinePragma)
......@@ -277,6 +284,7 @@ dsHsBind dflags
return (ABE {abe_poly = global
,abe_mono = local
,abe_wrap = WpHole
,abe_inst_wrap = WpHole
,abe_prags = SpecPrags []})
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
......@@ -963,10 +971,10 @@ dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
; dsHsWrapper c1 e1 }
dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
; e1 <- dsHsWrapper c1 (Var x)
; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
; return (Lam x e2) }
dsHsWrapper (WpFun c1 c2 t1) e = do { x <- newSysLocalDs t1
; e1 <- dsHsWrapper c1 (Var x)
; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
; return (Lam x e2) }
dsHsWrapper (WpCast co) e = ASSERT(coercionRole co == Representational)
return $ mkCastDs e co
dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
......
......@@ -222,7 +222,10 @@ 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
-- 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
{-
......@@ -718,7 +721,8 @@ 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"
dsExpr (HsType {}) = panic "dsExpr:HsType" -- removed by typechecker
dsExpr (HsTypeOut {}) = panic "dsExpr:HsTypeOut" -- handled in HsApp case
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
......
......@@ -956,7 +956,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- equating different ways of writing a coercion)
wrap WpHole WpHole = True
wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
wrap (WpFun w1 w2 _) (WpFun w1' w2' _) = wrap w1 w1' && wrap w2 w2'
wrap (WpCast co) (WpCast co') = co `eqCoercion` co'
wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2
wrap (WpTyApp t) (WpTyApp t') = eqType t t'
......
......@@ -236,11 +236,13 @@ deriving instance (DataId idL, DataId idR)
-- See Note [AbsBinds]
data ABExport id
= ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id
, abe_mono :: id
, abe_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
= ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id
, abe_mono :: id
, abe_inst_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
-- ^ Shape: abe_mono ~ abe_insted
, abe_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_insted) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
} deriving (Data, Typeable)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
......@@ -375,6 +377,27 @@ The abe_wrap field deals with impedance-matching between
and the thing we really want, which may have fewer type
variables. The action happens in TcBinds.mkExport.
For abe_inst_wrap, consider this:
x = (*)
The abe_mono type will be forall a. Num a => a -> a -> a
because no instantiation happens during typechecking. Before inferring
a final type, we must instantiate this. See Note [Instantiate when inferring
a type] in TcBinds. The abe_inst_wrap takes the uninstantiated abe_mono type
to a proper instantiated type. In this case, the "abe_insted" is
(b -> b -> b). Note that the value of "abe_insted" isn't important; it's
just an intermediate form as we're going from abe_mono to abe_poly. See also
the desugaring code in DsBinds.
It's conceivable that we could combine the two wrappers, but note that there
is a gap: neither wrapper tacks on the tvs and dicts from the outer AbsBinds.
These bits are added manually in desugaring. (See DsBinds.dsHsBind.) A problem
that would arise in combining them is that zonking becomes more challenging:
we want to zonk the tvs and dicts in the AbsBinds, but then we end up re-zonking
when we zonk the ABExport. And -- worse -- the combined wrapper would have
the tvs and dicts in binding positions, so they would shadow the original
tvs and dicts. This is all resolvable with some plumbing, but it seems simpler
just to keep the two wrappers distinct.
Note [Bind free vars]
~~~~~~~~~~~~~~~~~~~~~
The bind_fvs field of FunBind and PatBind records the free variables
......@@ -548,10 +571,12 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
pprLHsBinds val_binds
instance (OutputableBndr id) => Outputable (ABExport id) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
ppr (ABE { abe_wrap = wrap, abe_inst_wrap = inst_wrap
, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (ppr wrap)]
, nest 2 (ppr wrap)
, nest 2 (ppr inst_wrap)]
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
......
......@@ -502,7 +502,14 @@ data HsExpr id
-- For details on above see note [Api annotations] in ApiAnnotation
| ELazyPat (LHsExpr id) -- ~ pattern
| HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y
-- | 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
......@@ -762,7 +769,10 @@ ppr_expr (HsSCC _ (StringLiteral _ lbl) expr)
pprParendExpr expr ]
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
ppr_expr (HsType id) = ppr id
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
......@@ -864,6 +874,8 @@ hsExprNeedsParens (HsTcBracketOut {}) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
hsExprNeedsParens (HsRecFld{}) = False
hsExprNeedsParens (HsType {}) = False
hsExprNeedsParens (HsTypeOut {}) = False
hsExprNeedsParens _ = True
......@@ -970,10 +982,10 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsCmdCast TcCoercionN -- A simpler version of HsWrap in HsExpr
| HsCmdWrap HsWrapper
(HsCmd id) -- If cmd :: arg1 --> res
-- co :: arg1 ~ arg2
-- Then (HsCmdCast co cmd) :: arg2 --> res
-- wrap :: arg1 "->" arg2
-- Then (HsCmdWrap wrap cmd) :: arg2 --> res
deriving (Typeable)
deriving instance (DataId id) => Data (HsCmd id)
......@@ -1054,9 +1066,9 @@ ppr_cmd (HsCmdLet (L _ binds) cmd)
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr cmd)]
ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts
ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
, ptext (sLit "|>") <+> ppr co ]
ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts
ppr_cmd (HsCmdWrap w cmd) = pprHsWrapper (ppr_cmd cmd) w
ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
......@@ -1186,6 +1198,13 @@ isInfixMatch match = case m_fixity match of
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
-- | Is there only one RHS in this group?
isSingletonMatchGroup :: MatchGroup id body -> Bool
isSingletonMatchGroup (MG { mg_alts = L _ [match] })
| L _ (Match { m_grhss = GRHSs { grhssGRHSs = [_] } }) <- match
= True
isSingletonMatchGroup _ = False
matchGroupArity :: MatchGroup id body -> Arity
-- Precondition: MatchGroup is non-empty
-- This is called before type checking, when mg_arg_tys is not set
......
......@@ -25,7 +25,7 @@ module HsUtils(
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar, mkHsCmdCast,
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
......@@ -445,6 +445,21 @@ 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.
......@@ -609,9 +624,12 @@ mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
mkHsCmdCast co cmd | isTcReflCo co = cmd
| otherwise = HsCmdCast co cmd
mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
| otherwise = HsCmdWrap w cmd
mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
......
......@@ -15,9 +15,9 @@ import RdrName
import Var
import Coercion
import {-# SOURCE #-} ConLike (ConLike)
import TcEvidence (HsWrapper)
import FieldLabel
import SrcLoc (Located)
import TcEvidence ( HsWrapper )
import Data.Data hiding ( Fixity )
import BasicTypes (Fixity)
......@@ -65,6 +65,9 @@ placeHolderNames = PlaceHolder
placeHolderNamesTc :: NameSet
placeHolderNamesTc = emptyNameSet
placeHolderHsWrapper :: PlaceHolder
placeHolderHsWrapper = PlaceHolder
{-
Note [Pass sensitive types]
......
......@@ -963,7 +963,7 @@ ppr_rough Nothing = dot
ppr_rough (Just tc) = ppr tc
tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
tv_to_forall_bndr tv = IfaceTv tv Invisible
tv_to_forall_bndr tv = IfaceTv tv Specified
{-
Note [Result type of a data family GADT]
......
......@@ -696,8 +696,9 @@ pprIfaceForAll bndrs@(IfaceTv _ vis : _)
(bndrs', doc) = ppr_itv_bndrs bndrs vis
add_separator stuff = case vis of
Invisible -> stuff <> dot
Visible -> stuff <+> arrow
_inv -> stuff <> dot
-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@.
-- Returns both the list of not-yet-rendered binders and the doc.
......@@ -705,9 +706,9 @@ pprIfaceForAll bndrs@(IfaceTv _ vis : _)
ppr_itv_bndrs :: [IfaceForAllBndr]
-> VisibilityFlag -- ^ visibility of the first binder in the list
-> ([IfaceForAllBndr], SDoc)
ppr_itv_bndrs all_bndrs@(IfaceTv tv vis : bndrs) vis1
| vis == vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
(bndrs', pprIfaceTvBndr tv <+> doc)
ppr_itv_bndrs all_bndrs@(bndr@(IfaceTv _ vis) : bndrs) vis1
| vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
(bndrs', pprIfaceForAllBndr bndr <+> doc)
| otherwise = (all_bndrs, empty)
ppr_itv_bndrs [] _ = ([], empty)
......@@ -719,7 +720,11 @@ pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs