Commit b207b536 authored by Ben Gamari's avatar Ben Gamari 🐢

Generalize kind of the (->) tycon

This is generalizes the kind of `(->)`, as discussed in #11714.

This involves a few things,

 * Generalizing the kind of `funTyCon`, adding two new `RuntimeRep`
binders,
  ```lang=haskell
(->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
               (a :: TYPE r1) (b :: TYPE r2).
        a -> b -> *
  ```

 * Unsaturated applications of `(->)` are expressed as explicit
`TyConApp`s

 * Saturated applications of `(->)` are expressed as `FunTy` as they are
currently

 * Saturated applications of `(->)` are expressed by a new `FunCo`
constructor in coercions

 * `splitTyConApp` needs to ensure that `FunTy`s are split to a
`TyConApp`
   of `(->)` with the appropriate `RuntimeRep` arguments

 * Teach CoreLint to check that all saturated applications of `(->)` are
represented with `FunTy`

At the moment I assume that `Constraint ~ *`, which is an annoying
source of complexity. This will
be simplified once D3023 is resolved.

Also, this introduces two known regressions,

`tcfail181`, `T10403`
=====================
Only shows the instance,

    instance Monad ((->) r) -- Defined in ‘GHC.Base’

in its error message when -fprint-potential-instances is used. This is
because its instance head now mentions 'LiftedRep which is not in scope.
I'm not entirely sure of the right way to fix this so I'm just accepting
the new output for now.

T5963 (Typeable)
================

T5963 is now broken since Data.Typeable.Internals.mkFunTy computes its
fingerprint without the RuntimeRep variables that (->) expects. This
will be fixed with the merge of D2010.

Haddock performance
===================

The `haddock.base` and `haddock.Cabal` tests regress in allocations by
about 20%. This certainly hurts, but it's also not entirely unexpected:
the size of every function type grows with this patch and Haddock has a
lot of functions in its heap.
parent efeaf9e4
......@@ -373,6 +373,7 @@ orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` or
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ kind_co co)
= orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
......
......@@ -130,6 +130,12 @@ Outstanding issues:
-- may well be happening...);
Note [Linting function types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As described in Note [Representation of function types], all saturated
applications of funTyCon are represented with the FunTy constructor. We check
this invariant in lintType.
Note [Linting type lets]
~~~~~~~~~~~~~~~~~~~~~~~~
In the desugarer, it's very very convenient to be able to say (in effect)
......@@ -1245,6 +1251,13 @@ lintType ty@(TyConApp tc tys)
= lintType ty' -- Expand type synonyms, so that we do not bogusly complain
-- about un-saturated type synonyms
-- We should never see a saturated application of funTyCon; such applications
-- should be represented with the FunTy constructor. See Note [Linting
-- function types] and Note [Representation of function types].
| isFunTyCon tc
, length tys == 4
= failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))
| isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
-- Also type synonyms and type families
, length tys < tyConArity tc
......@@ -1487,14 +1500,9 @@ lintCoercion (Refl r ty)
lintCoercion co@(TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [co1,co2] <- cos
= do { (k1,k'1,s1,t1,r1) <- lintCoercion co1
; (k2,k'2,s2,t2,r2) <- lintCoercion co2
; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2
; 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) }
, [_rep1,_rep2,_co1,_co2] <- cos
= do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co)
} -- All saturated TyConAppCos should be FunCos
| Just {} <- synTyConDefn_maybe tc
= failWithL (text "Synonym in TyConAppCo:" <+> ppr co)
......@@ -1545,6 +1553,15 @@ lintCoercion (ForAllCo tv1 kind_co co)
substTy subst t2
; return (k3, k4, tyl, tyr, r) } }
lintCoercion co@(FunCo r co1 co2)
= do { (k1,k'1,s1,t1,r1) <- lintCoercion co1
; (k2,k'2,s2,t2,r2) <- lintCoercion co2
; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2
; 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) }
lintCoercion (CoVarCo cv)
| not (isCoVar cv)
= failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)
......
......@@ -1678,7 +1678,7 @@ pushCoValArg co
= Just (mkRepReflCo arg, mkRepReflCo res)
| isFunTy tyL
, [co1, co2] <- decomposeCo 2 co
, [_, _, co1, co2] <- decomposeCo 4 co
-- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
-- then co1 :: tyL1 ~ tyR1
-- co2 :: tyL2 ~ tyR2
......@@ -1702,7 +1702,7 @@ pushCoercionIntoLambda in_scope x e co
, Pair s1s2 t1t2 <- coercionKind co
, Just (_s1,_s2) <- splitFunTy_maybe s1s2
, Just (t1,_t2) <- splitFunTy_maybe t1t2
= let [co1, co2] = decomposeCo 2 co
= let [_rep1, _rep2, co1, co2] = decomposeCo 4 co
-- Should we optimize the coercions here?
-- Otherwise they might not match too well
x' = x `setIdType` t1
......
......@@ -796,9 +796,9 @@ data TypeMapX a
-- to nested AppTys. Why the last one? See Note [Equality on AppTys] in Type
trieMapView :: Type -> Maybe Type
trieMapView ty | Just ty' <- coreViewOneStarKind ty = Just ty'
trieMapView (TyConApp tc tys@(_:_)) = Just $ foldl AppTy (TyConApp tc []) tys
trieMapView (FunTy arg res)
= Just ((TyConApp funTyCon [] `AppTy` arg) `AppTy` res)
trieMapView ty
| Just (tc, tys@(_:_)) <- splitTyConApp_maybe ty
= Just $ foldl AppTy (TyConApp tc []) tys
trieMapView _ = Nothing
instance TrieMap TypeMapX where
......
......@@ -201,9 +201,9 @@ toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
----------------
toIfaceCoercion :: Coercion -> IfaceCoercion
toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty)
toIfaceCoercion (TyConAppCo r tc cos)
toIfaceCoercion co@(TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res)
, [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co)
| otherwise = IfaceTyConAppCo r (toIfaceTyCon tc)
(map toIfaceCoercion cos)
toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1)
......@@ -211,6 +211,8 @@ toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1)
toIfaceCoercion (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv)
(toIfaceCoercion k)
(toIfaceCoercion co)
toIfaceCoercion (FunCo r co1 co2) = IfaceFunCo r (toIfaceCoercion co1)
(toIfaceCoercion co2)
toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv)
toIfaceCoercion (AxiomInstCo con ind cos)
= IfaceAxiomInstCo (coAxiomName con) ind
......
......@@ -24,7 +24,7 @@ module TysPrim(
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,
-- Kind constructors...
tYPETyConName,
tYPETyCon, tYPETyConName,
-- Kinds
tYPE, primRepToRuntimeRep,
......@@ -94,7 +94,7 @@ import {-# SOURCE #-} TysWiredIn
, doubleElemRepDataConTy
, mkPromotedListTy )
import Var ( TyVar, mkTyVar )
import Var ( TyVar, TyVarBndr(TvBndr), mkTyVar )
import Name
import TyCon
import SrcLoc
......@@ -328,20 +328,21 @@ openBetaTy = mkTyVarTy openBetaTyVar
funTyConName :: Name
funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
-- | The @(->)@ type constructor.
--
-- @
-- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
-- TYPE rep1 -> TYPE rep2 -> *
-- @
funTyCon :: TyCon
funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm
where
tc_bndrs = mkTemplateAnonTyConBinders [liftedTypeKind, liftedTypeKind]
-- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-- But if we do that we get kind errors when saying
-- instance Control.Arrow (->)
-- because the expected kind is (*->*->*). The trouble is that the
-- expected/actual stuff in the unifier does not go contra-variant, whereas
-- the kind sub-typing does. Sigh. It really only matters if you use (->) in
-- a prefix way, thus: (->) Int# Int#. And this is unusual.
-- because they are never in scope in the source
tc_bndrs = [ TvBndr runtimeRep1TyVar (NamedTCB Inferred)
, TvBndr runtimeRep2TyVar (NamedTCB Inferred)
]
++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty
, tYPE runtimeRep2Ty
]
tc_rep_nm = mkPrelTyConRepName funTyConName
{-
......
......@@ -810,6 +810,12 @@ match_co renv subst co1 co2
| tc1 == tc2
-> match_cos renv subst cos1 cos2
_ -> Nothing
match_co renv subst co1 co2
| Just (arg1, res1) <- splitFunCo_maybe co1
= case splitFunCo_maybe co2 of
Just (arg2, res2)
-> match_cos renv subst [arg1, res1] [arg2, res2]
_ -> Nothing
match_co _ _ _co1 _co2
-- Currently just deals with CoVarCo, TyConAppCo and Refl
#ifdef DEBUG
......
......@@ -33,6 +33,7 @@ import Util
import Bag
import MonadUtils
import Control.Monad
import Data.Maybe ( isJust )
import Data.List ( zip4, foldl' )
import BasicTypes
......@@ -540,6 +541,25 @@ track whether or not we've already flattened.
It is conceivable to do a better job at tracking whether or not a type
is flattened, but this is left as future work. (Mar '15)
Note [FunTy and decomposing tycon applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked.
This means that we may very well have a FunTy containing a type of some unknown
kind. For instance, we may have,
FunTy (a :: k) Int
Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event
that it sees such a type as it cannot determine the RuntimeReps which the (->)
is applied to. Consequently, it is vital that we instead use
tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case.
When this happens can_eq_nc' will fail to decompose, zonk, and try again.
Zonking should fill the variable k, meaning that decomposition will succeed the
second time around.
-}
canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
......@@ -613,8 +633,9 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
-- Try to decompose type constructor applications
-- Including FunTy (s -> t)
can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _
| Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1
, Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2
--- See Note [FunTy and decomposing type constructor applications].
| Just (tc1, tys1) <- tcRepSplitTyConApp_maybe' ty1
, Just (tc2, tys2) <- tcRepSplitTyConApp_maybe' ty2
, not (isTypeFamilyTyCon tc1)
, not (isTypeFamilyTyCon tc2)
= canTyConApp ev eq_rel tc1 tys1 tc2 tys2
......@@ -696,6 +717,26 @@ zonk_eq_types = go
go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2
go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1
-- We handle FunTys explicitly here despite the fact that they could also be
-- treated as an application. Why? Well, for one it's cheaper to just look
-- at two types (the argument and result types) than four (the argument,
-- result, and their RuntimeReps). Also, we haven't completely zonked yet,
-- so we may run into an unzonked type variable while trying to compute the
-- RuntimeReps of the argument and result types. This can be observed in
-- testcase tc269.
go ty1 ty2
| Just (arg1, res1) <- split1
, Just (arg2, res2) <- split2
= do { res_a <- go arg1 arg2
; res_b <- go res1 res2
; return $ combine_rev mkFunTy res_b res_a
}
| isJust split1 || isJust split2
= bale_out ty1 ty2
where
split1 = tcSplitFunTy_maybe ty1
split2 = tcSplitFunTy_maybe ty2
go ty1 ty2
| Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1
, Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2
......@@ -1830,7 +1871,7 @@ unifyWanted loc role orig_ty1 orig_ty2
go (FunTy s1 t1) (FunTy s2 t2)
= do { co_s <- unifyWanted loc role s1 s2
; co_t <- unifyWanted loc role t1 t2
; return (mkTyConAppCo role funTyCon [co_s,co_t]) }
; return (mkFunCo role co_s co_t) }
go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| tc1 == tc2, tys1 `equalLength` tys2
, isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
......
......@@ -284,7 +284,7 @@ extendWorkListCt :: Ct -> WorkList -> WorkList
extendWorkListCt ct wl
= case classifyPredType (ctPred ct) of
EqPred NomEq ty1 _
| Just (tc,_) <- tcSplitTyConApp_maybe ty1
| Just tc <- tcTyConAppTyCon_maybe ty1
, isTypeFamilyTyCon tc
-> extendWorkListFunEq ct wl
......
......@@ -113,6 +113,7 @@ synonymTyConsOfType ty
go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs
go_co (AppCo co co') = go_co co `plusNameEnv` go_co co'
go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co'
go_co (FunCo _ co co') = go_co co `plusNameEnv` go_co co'
go_co (CoVarCo _) = emptyNameEnv
go_co (AxiomInstCo _ _ cs) = go_co_s cs
go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'
......
......@@ -62,8 +62,9 @@ module TcType (
tcSplitPhiTy, tcSplitPredFunTy_maybe,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcRepSplitTyConApp_maybe,
tcTyConAppTyCon, tcTyConAppArgs,
tcSplitTyConApp, tcSplitTyConApp_maybe,
tcRepSplitTyConApp_maybe, tcRepSplitTyConApp_maybe',
tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,
tcGetTyVar_maybe, tcGetTyVar, nextRole,
tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,
......@@ -862,6 +863,7 @@ exactTyCoVarsOfType ty
goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg
goCo (ForAllCo tv k_co co)
= goCo co `delVarSet` tv `unionVarSet` goCo k_co
goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2
goCo (CoVarCo v) = unitVarSet v `unionVarSet` go (varType v)
goCo (AxiomInstCo _ _ args) = goCos args
goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2
......@@ -1420,9 +1422,21 @@ tcDeepSplitSigmaTy_maybe ty
-----------------------
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
Just (tc, _) -> tc
Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty)
tcTyConAppTyCon ty
= case tcTyConAppTyCon_maybe ty of
Just tc -> tc
Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty)
-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'.
tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
tcTyConAppTyCon_maybe ty
| Just ty' <- coreView ty = tcTyConAppTyCon_maybe ty'
tcTyConAppTyCon_maybe (TyConApp tc _)
= Just tc
tcTyConAppTyCon_maybe (FunTy _ _)
= Just funTyCon
tcTyConAppTyCon_maybe _
= Nothing
tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
......@@ -1434,14 +1448,48 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "tcSplitTyConApp" (pprType ty)
tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-- | Split a type constructor application into its type constructor and
-- applied types. Note that this may fail in the case of a 'FunTy' with an
-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind
-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your
-- type before using this function.
--
-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.
tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe ty | Just ty' <- coreView ty = tcSplitTyConApp_maybe ty'
tcSplitTyConApp_maybe ty = tcRepSplitTyConApp_maybe ty
tcRepSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcRepSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
tcRepSplitTyConApp_maybe _ = Nothing
-- | Like 'tcSplitTyConApp_maybe' but doesn't look through type synonyms.
tcRepSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcRepSplitTyConApp_maybe (FunTy arg res)
| Just arg_rep <- getRuntimeRep_maybe arg
, Just res_rep <- getRuntimeRep_maybe res
= Just (funTyCon, [arg_rep, res_rep, arg, res])
| otherwise
= pprPanic "tcRepSplitTyConApp_maybe" (ppr arg $$ ppr res)
tcRepSplitTyConApp_maybe _ = Nothing
-- | Like 'tcRepSplitTyConApp_maybe', but returns 'Nothing' if,
--
-- 1. the type is structurally not a type constructor application, or
--
-- 2. the type is a function type (e.g. application of 'funTyCon'), but we
-- currently don't even enough information to fully determine its RuntimeRep
-- variables. For instance, @FunTy (a :: k) Int@.
--
-- By constrast 'tcRepSplitTyConApp_maybe' panics in the second case.
--
-- The behavior here is needed during canonicalization; see Note [FunTy and
-- decomposing tycon applications] in TcCanonical for details.
tcRepSplitTyConApp_maybe' :: HasCallStack => Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe' (TyConApp tc tys) = Just (tc, tys)
tcRepSplitTyConApp_maybe' (FunTy arg res)
| Just arg_rep <- getRuntimeRep_maybe arg
, Just res_rep <- getRuntimeRep_maybe res
= Just (funTyCon, [arg_rep, res_rep, arg, res])
tcRepSplitTyConApp_maybe' _ = Nothing
-----------------------
......@@ -1627,6 +1675,7 @@ tc_eq_type :: (TcType -> Maybe TcType) -- ^ @coreView@, if you want unwrapping
-> Type -> Type -> Maybe Bool
tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2
where
go :: Bool -> RnEnv2 -> Type -> Type -> Maybe Bool
go vis env t1 t2 | Just t1' <- view_fun t1 = go vis env t1' t2
go vis env t1 t2 | Just t2' <- view_fun t2 = go vis env t1 t2'
......@@ -1641,8 +1690,15 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2
= go (isVisibleArgFlag vis1) env (tyVarKind tv1) (tyVarKind tv2)
<!> go vis (rnBndr2 env tv1 tv2) ty1 ty2
<!> check vis (vis1 == vis2)
-- Make sure we handle all FunTy cases since falling through to the
-- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked
-- kind variable, which causes things to blow up.
go vis env (FunTy arg1 res1) (FunTy arg2 res2)
= go vis env arg1 arg2 <!> go vis env res1 res2
go vis env ty (FunTy arg res)
= eqFunTy vis env arg res ty
go vis env (FunTy arg res) ty
= eqFunTy vis env arg res ty
-- See Note [Equality on AppTys] in Type
go vis env (AppTy s1 t1) ty2
......@@ -1679,6 +1735,28 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2
orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
-- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is
-- sometimes hard to know directly because @ty@ might have some casts
-- obscuring the FunTy. And 'splitAppTy' is difficult because we can't
-- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or
-- res is unzonked/unflattened. Thus this function, which handles this
-- corner case.
eqFunTy :: Bool -> RnEnv2 -> Type -> Type -> Type -> Maybe Bool
eqFunTy vis env arg res (FunTy arg' res')
= go vis env arg arg' <!> go vis env res res'
eqFunTy vis env arg res ty@(AppTy{})
| Just (tc, [_, _, arg', res']) <- get_args ty []
, tc == funTyCon
= go vis env arg arg' <!> go vis env res res'
where
get_args :: Type -> [Type] -> Maybe (TyCon, [Type])
get_args (AppTy f x) args = get_args f (x:args)
get_args (CastTy t _) args = get_args t args
get_args (TyConApp tc tys) args = Just (tc, tys ++ args)
get_args _ _ = Nothing
eqFunTy vis _ _ _ _
= Just vis
-- | Like 'pickyEqTypeVis', but returns a Bool for convenience
pickyEqType :: TcType -> TcType -> Bool
-- Check when two types _look_ the same, _including_ synonyms.
......
......@@ -2071,6 +2071,9 @@ occCheckExpand tv ty
env' = extendVarEnv env tv' tv''
; body' <- go_co env' body_co
; return (ForAllCo tv'' kind_co' body') }
go_co env (FunCo r co1 co2) = do { co1' <- go_co env co1
; co2' <- go_co env co2
; return (mkFunCo r co1' co2') }
go_co env (CoVarCo c) = do { k' <- go env (varType c)
; return (mkCoVarCo (setVarType c k')) }
go_co env (AxiomInstCo ax ind args) = do { args' <- mapM (go_co env) args
......
......@@ -1900,6 +1900,7 @@ fvCo (Refl _ ty) = fvType ty
fvCo (TyConAppCo _ _ args) = concatMap fvCo args
fvCo (AppCo co arg) = fvCo co ++ fvCo arg
fvCo (ForAllCo tv h co) = filter (/= tv) (fvCo co) ++ fvCo h
fvCo (FunCo _ co1 co2) = fvCo co1 ++ fvCo co2
fvCo (CoVarCo v) = [v]
fvCo (AxiomInstCo _ _ args) = concatMap fvCo args
fvCo (UnivCo p _ t1 t2) = fvProv p ++ fvType t1 ++ fvType t2
......
This diff is collapsed.
{-# LANGUAGE FlexibleContexts #-}
module Coercion where
import {-# SOURCE #-} TyCoRep
......@@ -8,11 +10,13 @@ import CoAxiom
import Var
import Outputable
import Pair
import Util
mkReflCo :: Role -> Type -> Coercion
mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
mkAppCo :: Coercion -> Coercion -> Coercion
mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion
mkFunCo :: Role -> Coercion -> Coercion -> Coercion
mkCoVarCo :: CoVar -> Coercion
mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
mkPhantomCo :: Coercion -> Type -> Type -> Coercion
......
......@@ -1693,6 +1693,7 @@ allTyVarsInTy = go
go_co (AppCo co arg) = go_co co `unionVarSet` go_co arg
go_co (ForAllCo tv h co)
= unionVarSets [unitVarSet tv, go_co co, go_co h]
go_co (FunCo _ c1 c2) = go_co c1 `unionVarSet` go_co c2
go_co (CoVarCo cv) = unitVarSet cv
go_co (AxiomInstCo _ _ cos) = go_cos cos
go_co (UnivCo p _ t1 t2) = go_prov p `unionVarSet` go t1 `unionVarSet` go t2
......
......@@ -207,6 +207,15 @@ opt_co4 env sym rep r (ForAllCo tv k_co co)
opt_co4_wrap env' sym rep r co
-- Use the "mk" functions to check for nested Refls
opt_co4 env sym rep r (FunCo _r co1 co2)
= ASSERT( r == _r )
if rep
then mkFunCo Representational co1' co2'
else mkFunCo r co1' co2'
where
co1' = opt_co4_wrap env sym rep r co1
co2' = opt_co4_wrap env sym rep r co2
opt_co4 env sym rep r (CoVarCo cv)
| Just co <- lookupCoVar (lcTCvSubst env) cv
= opt_co4_wrap (zapLiftingContext env) sym rep r co
......
......@@ -441,7 +441,8 @@ Pi-types:
* A non-dependent function type,
written with ->, e.g. ty1 -> ty2
represented as FunTy ty1 ty2
represented as FunTy ty1 ty2. These are
lifted to Coercions with the corresponding FunCo.
* A dependent compile-time-only polytype,
written with forall, e.g. forall (a:*). ty
......@@ -790,6 +791,9 @@ data Coercion
| ForAllCo TyVar KindCoercion Coercion
-- ForAllCo :: _ -> N -> e -> e
| FunCo Role Coercion Coercion -- lift FunTy
-- FunCo :: "e" -> e -> e -> e
-- These are special
| CoVarCo CoVar -- :: _ -> (N or R)
-- result role depends on the tycon of the variable's type
......@@ -1440,6 +1444,8 @@ tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc
= (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc
tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc
= (delFV tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc
tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc
= (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc
tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc
= (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc
tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc
......@@ -1500,6 +1506,7 @@ coVarsOfCo (TyConAppCo _ _ args) = coVarsOfCos args
coVarsOfCo (AppCo co arg) = coVarsOfCo co `unionVarSet` coVarsOfCo arg
coVarsOfCo (ForAllCo tv kind_co co)
= coVarsOfCo co `delVarSet` tv `unionVarSet` coVarsOfCo kind_co
coVarsOfCo (FunCo _ co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
coVarsOfCo (CoVarCo v) = unitVarSet v `unionVarSet` coVarsOfType (varType v)
coVarsOfCo (AxiomInstCo _ _ args) = coVarsOfCos args
coVarsOfCo (UnivCo p _ t1 t2) = coVarsOfProv p `unionVarSet` coVarsOfTypes [t1, t2]
......@@ -1566,6 +1573,7 @@ noFreeVarsOfCo (Refl _ ty) = noFreeVarsOfType ty
noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args
noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2
noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co)
noFreeVarsOfCo (FunCo _ c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2
noFreeVarsOfCo (CoVarCo _) = False
noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args
noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p &&
......@@ -2234,6 +2242,7 @@ subst_co subst co
go (ForAllCo tv kind_co co)
= case substForAllCoBndrUnchecked subst tv kind_co of { (subst', tv', kind_co') ->
((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co }
go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2
go (CoVarCo cv) = substCoVar subst cv
go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos
go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $!
......@@ -2771,6 +2780,7 @@ tidyCo env@(_, subst) co
where (envp, tvp) = tidyTyCoVarBndr env tv
-- the case above duplicates a bit of work in tidying h and the kind
-- of tv. But the alternative is to use coercionKind, which seems worse.
go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2
go (CoVarCo cv) = case lookupVarEnv subst cv of
Nothing -> CoVarCo cv
Just cv' -> CoVarCo cv'
......@@ -2833,6 +2843,7 @@ coercionSize (Refl _ ty) = typeSize ty
coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)
coercionSize (AppCo co arg) = coercionSize co + coercionSize arg
coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h
coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2
coercionSize (CoVarCo _) = 1
coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args)
coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2
......
......@@ -1391,7 +1391,7 @@ So we compromise, and move their Kind calculation to the call site.
-}
-- | Given the name of the function type constructor and it's kind, create the
-- corresponding 'TyCon'. It is reccomended to use 'TyCoRep.funTyCon' if you want
-- corresponding 'TyCon'. It is recomended to use 'TyCoRep.funTyCon' if you want
-- this functionality
mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon
mkFunTyCon name binders rep_nm
......@@ -1401,7 +1401,7 @@ mkFunTyCon name binders rep_nm
tyConBinders = binders,
tyConResKind = liftedTypeKind,
tyConKind = mkTyConKind binders liftedTypeKind,
tyConArity = 2,
tyConArity = length binders,
tcRepName = rep_nm
}
......
This diff is collapsed.
......@@ -1162,8 +1162,8 @@ data MatchEnv = ME { me_tmpls :: TyVarSet
, me_env :: RnEnv2 }
-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if
-- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@,
-- where @==@ there means that the result of tyCoSubst has the same
-- @liftCoMatch vars ty co == Just s@, then @listCoSubst s ty == co@,
-- where @==@ there means that the result of 'liftCoSubst' has the same
-- type as the original co; but may be different under the hood.
-- That is, it matches a type against a coercion of the same
-- "shape", and returns a lifting substitution which could have been
......@@ -1269,8 +1269,15 @@ ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco
ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco
= ty_co_match_tc menv subst tc1 tys tc2 cos
ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo _ tc cos) _lkco _rkco
= ty_co_match_tc menv subst funTyCon [ty1, ty2] tc cos
ty_co_match menv subst (FunTy ty1 ty2) co _lkco _rkco
-- Despite the fact that (->) is polymorphic in four type variables (two
-- runtime rep and two types), we shouldn't need to explicitly unify the
-- runtime reps here; unifying the types themselves should be sufficient.
-- See Note [Representation of function types].
| Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co
, tc == funTyCon
= let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2]
in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos
ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1)
(ForAllCo tv2 kind_co2 co2)
......@@ -1334,7 +1341,10 @@ pushRefl :: Coercion -> Maybe Coercion
pushRefl (Refl Nominal (AppTy ty1 ty2))
= Just (AppCo (Refl Nominal ty1) (mkNomReflCo ty2))
pushRefl (Refl r (FunTy ty1 ty2))
= Just (TyConAppCo r funTyCon [mkReflCo r ty1, mkReflCo r ty2])
| Just rep1 <- getRuntimeRep_maybe ty1
, Just rep2 <- getRuntimeRep_maybe ty2
= Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2
, mkReflCo r ty1, mkReflCo r ty2 ])
pushRefl (Refl r (TyConApp tc tys))
= Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))
pushRefl (Refl r (ForAllTy (TvBndr tv _) ty))
......
......@@ -119,7 +119,7 @@ test('T2528', normal, compile_and_run, [''])
test('T4006', normal, compile_and_run, [''])
test('T5943', normal, compile_and_run, [''])
test('T5962', normal, compile_and_run, [''])
test('T5962', expect_broken(10343), compile_and_run, [''])
test('T7034', normal, compile_and_run, [''])
test('qsem001', normal, compile_and_run, [''])
......
data (->) a b -- Defined in ‘GHC.Prim’
data (->) (a :: TYPE q) (b :: TYPE r) -- Defined in ‘GHC.Prim’
infixr 0 `(->)`
instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
instance Applicative ((->) a) -- Defined in ‘GHC.Base’
......
data (->) a b -- Defined in ‘GHC.Prim’
data (->) (a :: TYPE q) (b :: TYPE r) -- Defined in ‘GHC.Prim’
infixr 0 `(->)`
instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
instance Applicative ((->) a) -- Defined in ‘GHC.Base’
......
data (->) a b -- Defined in ‘GHC.Prim’
data (->) (a :: TYPE q) (b :: TYPE r) -- Defined in ‘GHC.Prim’
infixr 0 `(->)`
instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
instance Applicative ((->) a) -- Defined in ‘GHC.Base’
......
......@@ -41,7 +41,8 @@ T10403.hs:22:15: warning: [-Wdeferred-type-errors (in -Wdefault)]
instance Functor IO -- Defined in ‘GHC.Base’
instance Functor (B t) -- Defined at T10403.hs:10:10
instance Functor I -- Defined at T10403.hs:6:10
...plus four others
...plus three others
...plus one instance involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the second argument of ‘(.)’, namely ‘fmap (const ())’
In the expression: H . fmap (const ())
......
......@@ -737,13 +737,14 @@ test('T9675',
test('T9872a',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 3134866040 , 5),
[(wordsize(64), 3304620816, 5),
# 2014-12-10 5521332656 Initally created