Commit 6cce36f8 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Add AnonArgFlag to FunTy

The big payload of this patch is:

  Add an AnonArgFlag to the FunTy constructor
  of Type, so that
    (FunTy VisArg   t1 t2) means (t1 -> t2)
    (FunTy InvisArg t1 t2) means (t1 => t2)

The big payoff is that we have a simple, local test to make
when decomposing a type, leading to many fewer calls to
isPredTy. To me the code seems a lot tidier, and probably
more efficient (isPredTy has to take the kind of the type).

See Note [Function types] in TyCoRep.

There are lots of consequences

* I made FunTy into a record, so that it'll be easier
  when we add a linearity field, something that is coming
  down the road.

* Lots of code gets touched in a routine way, simply because it
  pattern matches on FunTy.

* I wanted to make a pattern synonym for (FunTy2 arg res), which
  picks out just the argument and result type from the record. But
  alas the pattern-match overlap checker has a heart attack, and
  either reports false positives, or takes too long.  In the end
  I gave up on pattern synonyms.

  There's some commented-out code in TyCoRep that shows what I
  wanted to do.

* Much more clarity about predicate types, constraint types
  and (in particular) equality constraints in kinds.  See TyCoRep
  Note [Types for coercions, predicates, and evidence]
  and Note [Constraints in kinds].

  This made me realise that we need an AnonArgFlag on
  AnonTCB in a TyConBinder, something that was really plain
  wrong before. See TyCon Note [AnonTCB InivsArg]

* When building function types we must know whether we
  need VisArg (mkVisFunTy) or InvisArg (mkInvisFunTy).
  This turned out to be pretty easy in practice.

* Pretty-printing of types, esp in IfaceType, gets
  tidier, because we were already recording the (->)
  vs (=>) distinction in an ad-hoc way.  Death to
  IfaceFunTy.

* mkLamType needs to keep track of whether it is building
  (t1 -> t2) or (t1 => t2).  See Type
  Note [mkLamType: dictionary arguments]

Other minor stuff

* Some tidy-up in validity checking involving constraints;
  Trac #16263
parent ac34e784
Pipeline #2680 failed with stages
in 920 minutes and 55 seconds
......@@ -721,10 +721,8 @@ rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n)
rnIfaceType (IfaceAppTy t1 t2)
= IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l)
rnIfaceType (IfaceFunTy t1 t2)
= IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceDFunTy t1 t2)
= IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceFunTy af t1 t2)
= IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceTupleTy s i tks)
= IfaceTupleTy s i <$> rnIfaceAppArgs tks
rnIfaceType (IfaceTyConApp tc tks)
......
......@@ -959,36 +959,33 @@ mkDataCon name declared_infix prom_info
-- If the DataCon has a wrapper, then the worker's type is never seen
-- by the user. The visibilities we pick do not matter here.
DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $
mkFunTys rep_arg_tys $
mkVisFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
-- See Note [Promoted data constructors] in TyCon
prom_tv_bndrs = [ mkNamedTyConBinder vis tv
| Bndr tv vis <- user_tvbs ]
prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys)
prom_res_kind = orig_res_ty
promoted = mkPromotedDataCon con name prom_info
(prom_tv_bndrs ++ prom_arg_bndrs)
prom_res_kind roles rep_info
fresh_names = freshNames (map getName user_tvbs)
-- fresh_names: make sure that the "anonymous" tyvars don't
-- clash in name or unique with the universal/existential ones.
-- Tiresome! And unnecessary because these tyvars are never looked at
prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t)
{- Invisible -} | (n,t) <- fresh_names `zip` theta ]
prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t)
{- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ]
prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs
prom_res_kind = orig_res_ty
promoted = mkPromotedDataCon con name prom_info prom_bndrs
prom_res_kind roles rep_info
roles = map (\tv -> if isTyVar tv then Nominal else Phantom)
(univ_tvs ++ ex_tvs)
++ map (const Representational) orig_arg_tys
mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder]
-- Make sure that the "anonymous" tyvars don't clash in
-- name or unique with the universal/existential ones.
-- Tiresome! And unnecessary because these tyvars are never looked at
mkCleanAnonTyConBinders tc_bndrs tys
= [ mkAnonTyConBinder (mkTyVar name ty)
| (name, ty) <- fresh_names `zip` tys ]
where
fresh_names = freshNames (map getName (binderVars tc_bndrs))
++ map (const Representational) (theta ++ orig_arg_tys)
freshNames :: [Name] -> [Name]
-- Make names whose Uniques and OccNames differ from
-- those in the 'avoid' list
-- Make an infinite list of Names whose Uniques and OccNames
-- differ from those in the 'avoid' list
freshNames avoids
= [ mkSystemName uniq occ
| n <- [0..]
......@@ -1299,8 +1296,8 @@ dataConUserType (MkData { dcUserTyVarBinders = user_tvbs,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys user_tvbs $
mkFunTys theta $
mkFunTys arg_tys $
mkInvisFunTys theta $
mkVisFunTys arg_tys $
res_ty
-- | Finds the instantiated types of the arguments required to construct a
......
......@@ -337,7 +337,7 @@ mkDictSelId name clas
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
sel_ty = mkForAllTys tyvars $
mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
getNth arg_tys val_index
base_info = noCafIdInfo
......@@ -1137,7 +1137,7 @@ mkPrimOpId prim_op
= id
where
(tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
ty = mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty)
ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty)
name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
(mkPrimOpIdUnique (primOpTag prim_op))
(AnId id) UserSyntax
......@@ -1297,7 +1297,7 @@ unsafeCoerceId
[_, _, a, b] = mkTyVarTys bndrs
ty = mkSpecForAllTys bndrs (mkFunTy a b)
ty = mkSpecForAllTys bndrs (mkVisFunTy a b)
[x] = mkTemplateLocals [a]
rhs = mkLams (bndrs ++ [x]) $
......@@ -1331,7 +1331,7 @@ seqId = pcMiscPrelId seqName ty info
-- see Note [seqId magic]
ty = mkSpecForAllTys [alphaTyVar,betaTyVar]
(mkFunTy alphaTy (mkFunTy betaTy betaTy))
(mkVisFunTy alphaTy (mkVisFunTy betaTy betaTy))
[x,y] = mkTemplateLocals [alphaTy, betaTy]
rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
......@@ -1341,13 +1341,13 @@ lazyId :: Id -- See Note [lazyId magic]
lazyId = pcMiscPrelId lazyIdName ty info
where
info = noCafIdInfo `setNeverLevPoly` ty
ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)
noinlineId :: Id -- See Note [noinlineId magic]
noinlineId = pcMiscPrelId noinlineIdName ty info
where
info = noCafIdInfo `setNeverLevPoly` ty
ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)
oneShotId :: Id -- See Note [The oneShot function]
oneShotId = pcMiscPrelId oneShotName ty info
......@@ -1356,8 +1356,8 @@ oneShotId = pcMiscPrelId oneShotName ty info
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy fun_ty fun_ty)
fun_ty = mkFunTy openAlphaTy openBetaTy
(mkVisFunTy fun_ty fun_ty)
fun_ty = mkVisFunTy openAlphaTy openBetaTy
[body, x] = mkTemplateLocals [fun_ty, openAlphaTy]
x' = setOneShotLambda x -- Here is the magic bit!
rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
......@@ -1387,7 +1387,8 @@ coerceId = pcMiscPrelId coerceName ty info
, liftedTypeKind
, alphaTy, betaTy ]
ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $
mkFunTys [eqRTy, alphaTy] betaTy
mkInvisFunTy eqRTy $
mkVisFunTy alphaTy betaTy
[eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy]
rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $
......
......@@ -464,6 +464,6 @@ pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, pprType sigma_ty ]
where
sigma_ty = mkForAllTys ex_tvs $
mkFunTys prov_theta $
mkFunTys orig_args orig_res_ty
mkInvisFunTys prov_theta $
mkVisFunTys orig_args orig_res_ty
insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
......@@ -60,10 +60,13 @@ module Var (
isGlobalId, isExportedId,
mustHaveLocalBinding,
-- * ArgFlags
ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis,
AnonArgFlag(..),
-- * TyVar's
VarBndr(..), ArgFlag(..), TyCoVarBinder, TyVarBinder,
VarBndr(..), TyCoVarBinder, TyVarBinder,
binderVar, binderVars, binderArgFlag, binderType,
isVisibleArgFlag, isInvisibleArgFlag, sameVis,
mkTyCoVarBinder, mkTyCoVarBinders,
mkTyVarBinder, mkTyVarBinders,
isTyVarBinder,
......@@ -422,6 +425,31 @@ instance Binary ArgFlag where
1 -> return Specified
_ -> return Inferred
-- The non-dependent version of ArgFlag, namely AnonArgFlag,
-- appears here partly so that it's together with its friend ArgFlag,
-- but also because it is used in IfaceType, rather early in the
-- compilation chain
data AnonArgFlag
= VisArg -- Used for (->): an ordinary non-dependent arrow
-- The argument is visible in source code
| InvisArg -- Used for (=>): a non-dependent predicate arrow
-- The argument is invisible in source code
deriving (Eq, Ord, Data)
instance Outputable AnonArgFlag where
ppr VisArg = text "[vis]"
ppr InvisArg = text "[invis]"
instance Binary AnonArgFlag where
put_ bh VisArg = putByte bh 0
put_ bh InvisArg = putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> return VisArg
_ -> return InvisArg
{- *********************************************************************
* *
* VarBndr, TyCoVarBinder
......
-- Var.hs-boot is Imported (only) by TyCoRep.hs-boot
module Var where
import GhcPrelude ()
-- We compile this module with -XNoImplicitPrelude (for some
-- reason), so if there are no imports it does not seem to
-- depend on anything. But it does! We must, for example,
-- compile GHC.Types in the ghc-prim library first.
-- So this otherwise-unnecessary import tells the build system
-- that this module depends on GhcPrelude, which ensures
-- that GHC.Type is built first.
data ArgFlag
data AnonArgFlag
data Var
......@@ -928,15 +928,15 @@ getTyDescription ty
TyVarTy _ -> "*"
AppTy fun _ -> getTyDescription fun
TyConApp tycon _ -> getOccString tycon
FunTy _ res -> '-' : '>' : fun_result res
FunTy {} -> '-' : fun_result tau_ty
ForAllTy _ ty -> getTyDescription ty
LitTy n -> getTyLitDescription n
CastTy ty _ -> getTyDescription ty
CoercionTy co -> pprPanic "getTyDescription" (ppr co)
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
fun_result (FunTy { ft_res = res }) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
......
......@@ -353,7 +353,7 @@ orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr)
`unionNameSet` orphNamesOfType res
orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535
orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See Trac #8535
`unionNameSet` orphNamesOfType arg
`unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
......
......@@ -1349,7 +1349,7 @@ lintType ty@(TyConApp tc tys)
-- arrows can related *unlifted* kinds, so this has to be separate from
-- a dependent forall.
lintType ty@(FunTy t1 t2)
lintType ty@(FunTy _ t1 t2)
= do { k1 <- lintType t1
; k2 <- lintType t2
; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
......@@ -1509,7 +1509,7 @@ lint_app doc kfn kas
| Just kfn' <- coreView kfn
= go_app in_scope kfn' tka
go_app _ (FunTy kfa kfb) tka@(_,ka)
go_app _ (FunTy _ kfa kfb) tka@(_,ka)
= do { unless (ka `eqType` kfa) $
addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka)))
; return kfb }
......@@ -1765,7 +1765,7 @@ lintCoercion co@(FunCo r co1 co2)
; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2
; lintRole co1 r r1
; lintRole co2 r r2
; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) }
; return (k, k', mkVisFunTy s1 s2, mkVisFunTy t1 t2, r) }
lintCoercion (CoVarCo cv)
| not (isCoVar cv)
......
......@@ -3,12 +3,14 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module CoreMap(
-- * Maps over Core expressions
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
......@@ -33,6 +35,8 @@ module CoreMap(
(>.>), (|>), (|>>),
) where
#include "HsVersions.h"
import GhcPrelude
import TrieMap
......@@ -516,7 +520,7 @@ instance Eq (DeBruijn Type) where
-> D env t1 == D env' t1' && D env t2 == D env' t2'
(s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s
-> D env t1 == D env' t1' && D env t2 == D env' t2'
(FunTy t1 t2, FunTy t1' t2')
(FunTy _ t1 t2, FunTy _ t1' t2')
-> D env t1 == D env' t1' && D env t2 == D env' t2'
(TyConApp tc tys, TyConApp tc' tys')
-> tc == tc' && D env tys == D env' tys'
......
......@@ -1380,9 +1380,10 @@ isExpandableApp fn n_val_args
= True
| Just (bndr, ty) <- splitPiTy_maybe ty
= caseBinder bndr
(\_tv -> all_pred_args n_val_args ty)
(\bndr_ty -> isPredTy bndr_ty && all_pred_args (n_val_args-1) ty)
= case bndr of
Named {} -> all_pred_args n_val_args ty
Anon InvisArg _ -> all_pred_args (n_val_args-1) ty
Anon VisArg _ -> False
| otherwise
= False
......@@ -1578,7 +1579,7 @@ app_ok primop_ok fun args
primop_arg_ok :: TyBinder -> CoreExpr -> Bool
primop_arg_ok (Named _) _ = True -- A type argument
primop_arg_ok (Anon ty) arg -- A term argument
primop_arg_ok (Anon _ ty) arg -- A term argument
| isUnliftedType ty = expr_ok primop_ok arg
| otherwise = True -- See Note [Primops with lifted arguments]
......
......@@ -622,7 +622,7 @@ mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m)
mkBuildExpr elt_ty mk_build_inside = do
[n_tyvar] <- newTyVars [alphaTyVar]
let n_ty = mkTyVarTy n_tyvar
c_ty = mkFunTys [elt_ty, n_ty] n_ty
c_ty = mkVisFunTys [elt_ty, n_ty] n_ty
[c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
......@@ -804,7 +804,7 @@ runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
-- See Note [Error and friends have an "open-tyvar" forall]
runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
(mkFunTy addrPrimTy openAlphaTy)
(mkVisFunTy addrPrimTy openAlphaTy)
{- Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -894,7 +894,7 @@ be relying on anything from it.
aBSENT_ERROR_ID
= mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
where
absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy)
absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy)
-- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
-- lifted-type things; see Note [Absent errors] in WwLib
arity_info = vanillaIdInfo `setArityInfo` 1
......
......@@ -120,7 +120,7 @@ mkFCall dflags uniq the_fcall val_args res_ty
mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where
arg_tys = map exprType val_args
body_ty = (mkFunTys arg_tys res_ty)
body_ty = (mkVisFunTys arg_tys res_ty)
tyvars = tyCoVarsOfTypeWellScoped body_ty
ty = mkInvForAllTys tyvars body_ty
the_fcall_id = mkFCallId dflags uniq the_fcall ty
......@@ -251,7 +251,7 @@ boxResult result_ty
[the_alt]
]
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }
boxResult result_ty
= do -- It isn't IO, so do unsafePerformIO
......@@ -263,7 +263,7 @@ boxResult result_ty
ccall_res_ty
(coreAltType the_alt)
[the_alt]
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
where
return_result _ [ans] = ans
return_result _ _ = panic "return_result: expected single result"
......
......@@ -271,7 +271,7 @@ dsFCall fn_id co fcall mDeclHeader = do
return (fcall, empty)
let
-- Build the worker
worker_ty = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)
tvs = map binderVar tv_bndrs
the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
......@@ -431,7 +431,7 @@ dsFExportDynamic id co0 cconv = do
stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
let
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkFunTy stable_ptr_ty arg_ty
export_ty = mkVisFunTy stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalDs stable_ptr_ty
(h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
......
......@@ -282,7 +282,7 @@ deBindComp pat core_list1 quals core_list2 = do
let u2_ty = hsLPatType pat
let res_ty = exprType core_list2
h_ty = u1_ty `mkFunTy` res_ty
h_ty = u1_ty `mkVisFunTy` res_ty
-- no levity polymorphism here, as list comprehensions don't work
-- with RebindableSyntax. NB: These are *not* monad comps.
......@@ -425,7 +425,7 @@ mkZipBind elt_tys = do
elt_tuple_ty = mkBigCoreTupTy elt_tys
elt_tuple_list_ty = mkListTy elt_tuple_ty
zip_fn_ty = mkFunTys elt_list_tys elt_tuple_list_ty
zip_fn_ty = mkVisFunTys elt_list_tys elt_tuple_list_ty
mk_case (as, a', as') rest
= Case (Var as) as elt_tuple_list_ty
......@@ -473,7 +473,7 @@ mkUnzipBind _ elt_tys
elt_list_tys = map mkListTy elt_tys
elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys
unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
unzip_fn_ty = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty
mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
......
......@@ -849,7 +849,7 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression
CoreExpr) -- Fail variable applied to realWorld#
-- See Note [Failure thunks and CPR]
mkFailurePair expr
= do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
= do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)
; fail_fun_arg <- newSysLocalDs voidPrimTy
; let real_arg = setOneShotLambda fail_fun_arg
; return (NonRec fail_fun_var (Lam real_arg expr),
......
......@@ -623,7 +623,7 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
-- Here (k n) :: a :: Type r, so we don't know if it's lifted
-- or not; but that should be fine provided we add that void arg.
id <- newId (mkFunTy realWorldStatePrimTy ty)
id <- newId (mkVisFunTy realWorldStatePrimTy ty)
st <- newId realWorldStatePrimTy
let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
(emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
......
......@@ -752,9 +752,9 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
traceTR (text "Following a MutVar")
contents_tv <- newVar liftedTypeKind
MASSERT(isUnliftedType my_ty)
(mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
(mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy
contents_ty (mkTyConApp tycon [world,contents_ty])
addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty
x <- go (pred max_depth) contents_tv contents_ty contents
return (RefWrap my_ty x)
......@@ -1259,7 +1259,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
, Just (r1,r2) <- splitFunTy_maybe r
= do r2' <- go l2 r2
r1' <- go l1 r1
return (mkFunTy r1' r2')
return (mkVisFunTy r1' r2')
-- TyconApp Inductive case; this is the interesting bit.
| Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
, Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
......
......@@ -31,7 +31,7 @@ import Name ( Name, nameSrcSpan, setNameLoc )
import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
import SrcLoc
import TcHsSyn ( hsLitType, hsPatType )
import Type ( mkFunTys, Type )
import Type ( mkVisFunTys, Type )
import TysWiredIn ( mkListTy, mkSumTy )
import Var ( Id, Var, setVarName, varName, varType )
import TcRnTypes
......@@ -488,7 +488,7 @@ instance HasType (LHsExpr GhcTc) where
fallback = makeNode e' spn
matchGroupType :: MatchGroupTc -> Type
matchGroupType (MatchGroupTc args res) = mkFunTys args res
matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
-- | Skip desugaring of these expressions for performance reasons.
--
......
......@@ -63,7 +63,7 @@ resolveVisibility kind ty_args
where
ts' = go (extendTvSubst env tv t) res ts
go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps
go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps
= (True,t) : (go env res ts)
go env (TyVarTy tv) ts
......@@ -81,8 +81,8 @@ hieTypeToIface = foldType go
go (HLitTy l) = IfaceLitTy l
go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
go (HFunTy a b) = IfaceFunTy a b
go (HQualTy pred b) = IfaceDFunTy pred b
go (HFunTy a b) = IfaceFunTy VisArg a b
go (HQualTy pred b) = IfaceFunTy InvisArg pred b
go (HCastTy a) = a
go HCoercionTy = IfaceTyVar "<coercion type>"
go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
......@@ -158,12 +158,12 @@ getTypeIndex t
k <- getTypeIndex (varType v)
i <- getTypeIndex t
return $ HForAllTy ((varName v,k),a) i
go (FunTy a b) = do
go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do
ai <- getTypeIndex a
bi <- getTypeIndex b
return $ if isPredTy a
then HQualTy ai bi
else HFunTy ai bi
return $ case af of
InvisArg -> HQualTy ai bi
VisArg -> HFunTy ai bi
go (LitTy a) = return $ HLitTy $ toIfaceTyLit a
go (CastTy t _) = do
i <- getTypeIndex t
......
......@@ -645,13 +645,14 @@ typeToLHsType ty
= go ty
where
go :: Type -> LHsType GhcPs
go ty@(FunTy arg _)
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
, hst_xqual = noExt
, hst_body = go tau })
go (FunTy arg res) = nlHsFunTy (go arg) (go res)
go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res })
= case af of
VisArg -> nlHsFunTy (go arg) (go res)
InvisArg | (theta, tau) <- tcSplitPhiTy ty
-> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
, hst_xqual = noExt
, hst_body = go tau })
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
......
......@@ -247,8 +247,7 @@ buildClass tycon_name binders roles fds Nothing
do { traceIf (text "buildClass")
; tc_rep_name <- newTyConRepName tycon_name
; let univ_bndrs = tyConTyVarBinders binders
univ_tvs = binderVars univ_bndrs
; let univ_tvs = binderVars binders
tycon = mkClassTyCon tycon_name binders roles
AbstractTyCon rec_clas tc_rep_name
result = mkAbstractClass tycon_name univ_tvs fds tycon
......
......@@ -882,7 +882,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,
, ppWhen insert_empty_ctxt $ parens empty <+> darrow
, ex_msg
, pprIfaceContextArr prov_ctxt
, pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys ])
, pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ])
where
univ_msg = pprUserIfaceForAll univ_bndrs
ex_msg = pprUserIfaceForAll ex_bndrs
......@@ -1475,8 +1475,7 @@ freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs
freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
freeNamesIfType (IfaceLitTy _) = emptyNameSet
freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
......
......@@ -21,7 +21,7 @@ module IfaceType (
IfaceTyLit(..), IfaceAppArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..),
mkIfaceForAllTvBndr,
ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
......@@ -135,8 +135,7 @@ data IfaceType
-- See Note [Suppressing invisible arguments] for
-- an explanation of why the second field isn't
-- IfaceType, analogous to AppTy.
| IfaceFunTy IfaceType IfaceType
| IfaceDFunTy IfaceType IfaceType
| IfaceFunTy AnonArgFlag IfaceType IfaceType
| IfaceForAllTy IfaceForAllBndr IfaceType
| IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
......@@ -394,7 +393,7 @@ splitIfaceSigmaTy ty
= case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
split_foralls rho = ([], rho)
split_rho (IfaceDFunTy ty1 ty2)
split_rho (IfaceFunTy InvisArg ty1 ty2)
= case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
split_rho tau = ([], tau)
......@@ -438,8 +437,7 @@ ifTypeIsVarFree ty = go ty
go (IfaceTyVar {}) = False
go (IfaceFreeTyVar {}) = False
go (IfaceAppTy fun args) = go fun && go_args args
go (IfaceFunTy arg res) = go arg && go res
go (IfaceDFunTy arg res) = go arg && go res
go (IfaceFunTy _ arg res) = go arg && go res
go (IfaceForAllTy {}) = False
go (IfaceTyConApp _ args) = go_args args
go (IfaceTupleTy _ _ args) = go_args args
......@@ -474,8 +472,7 @@ substIfaceType env ty
go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv
go (IfaceTyVar tv) = substIfaceTyVar env tv
go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts)
go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
go (IfaceFunTy af t1 t2) = IfaceFunTy af (go t1) (go t2)
go ty@(IfaceLitTy {}) = ty
go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys)
go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys)
......@@ -720,7 +717,9 @@ pprIfaceTyConBinders = sep . map go
go (Bndr (IfaceTvBndr bndr) vis) =
-- See Note [Pretty-printing invisible arguments]
case vis of
AnonTCB -> ppr_bndr True
AnonTCB VisArg -> ppr_bndr True
AnonTCB InvisArg -> ppr_bndr True -- Rare; just promoted GADT data constructors
-- Should we print them differently?
NamedTCB Required -> ppr_bndr True
NamedTCB Specified -> char '@' <> ppr_bndr True
NamedTCB Inferred -> char '@' <> braces (ppr_bndr False)
......@@ -768,19 +767,26 @@ pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
-- called from other places, besides `:type` and `:info`.
pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty
ppr_sigma :: PprPrec -> IfaceType -> SDoc
ppr_sigma ctxt_prec ty
= maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty)
ppr_ty :: PprPrec -> IfaceType -> SDoc
ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty
ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _) = ppr_sigma ctxt_prec ty
ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar!
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType]
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys
ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
-- Function types
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
ppr_ty ctxt_prec (IfaceFunTy _ ty1 ty2