diff options
| author | Richard Eisenberg <eir@cis.upenn.edu> | 2015-12-11 18:19:53 -0500 |
|---|---|---|
| committer | Richard Eisenberg <eir@cis.upenn.edu> | 2015-12-11 18:23:12 -0500 |
| commit | 6746549772c5cc0ac66c0fce562f297f4d4b80a2 (patch) | |
| tree | 96869fcfb5757651462511d64d99a3712f09e7fb | |
| parent | 6e56ac58a6905197412d58e32792a04a63b94d7e (diff) | |
| download | haskell-6746549772c5cc0ac66c0fce562f297f4d4b80a2.tar.gz | |
Add kind equalities to GHC.
This implements the ideas originally put forward in
"System FC with Explicit Kind Equality" (ICFP'13).
There are several noteworthy changes with this patch:
* We now have casts in types. These change the kind
of a type. See new constructor `CastTy`.
* All types and all constructors can be promoted.
This includes GADT constructors. GADT pattern matches
take place in type family equations. In Core,
types can now be applied to coercions via the
`CoercionTy` constructor.
* Coercions can now be heterogeneous, relating types
of different kinds. A coercion proving `t1 :: k1 ~ t2 :: k2`
proves both that `t1` and `t2` are the same and also that
`k1` and `k2` are the same.
* The `Coercion` type has been significantly enhanced.
The documentation in `docs/core-spec/core-spec.pdf` reflects
the new reality.
* The type of `*` is now `*`. No more `BOX`.
* Users can write explicit kind variables in their code,
anywhere they can write type variables. For backward compatibility,
automatic inference of kind-variable binding is still permitted.
* The new extension `TypeInType` turns on the new user-facing
features.
* Type families and synonyms are now promoted to kinds. This causes
trouble with parsing `*`, leading to the somewhat awkward new
`HsAppsTy` constructor for `HsType`. This is dispatched with in
the renamer, where the kind `*` can be told apart from a
type-level multiplication operator. Without `-XTypeInType` the
old behavior persists. With `-XTypeInType`, you need to import
`Data.Kind` to get `*`, also known as `Type`.
* The kind-checking algorithms in TcHsType have been significantly
rewritten to allow for enhanced kinds.
* The new features are still quite experimental and may be in flux.
* TODO: Several open tickets: #11195, #11196, #11197, #11198, #11203.
* TODO: Update user manual.
Tickets addressed: #9017, #9173, #7961, #10524, #8566, #11142.
Updates Haddock submodule.
576 files changed, 22573 insertions, 16009 deletions
diff --git a/.gitmodules b/.gitmodules index 73ce0d1b5f..26b4fa0c0b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,119 +1,119 @@ [submodule "libraries/binary"] path = libraries/binary - url = ../packages/binary.git + url = http://git.haskell.org/packages/binary.git ignore = untracked [submodule "libraries/bytestring"] path = libraries/bytestring - url = ../packages/bytestring.git + url = http://git.haskell.org/packages/bytestring.git ignore = untracked [submodule "libraries/Cabal"] path = libraries/Cabal - url = ../packages/Cabal.git + url = http://git.haskell.org/packages/Cabal.git ignore = untracked [submodule "libraries/containers"] path = libraries/containers - url = ../packages/containers.git + url = http://git.haskell.org/packages/containers.git ignore = untracked [submodule "libraries/haskeline"] path = libraries/haskeline - url = ../packages/haskeline.git + url = http://git.haskell.org/packages/haskeline.git ignore = untracked [submodule "libraries/pretty"] path = libraries/pretty - url = ../packages/pretty.git + url = http://git.haskell.org/packages/pretty.git ignore = untracked [submodule "libraries/terminfo"] path = libraries/terminfo - url = ../packages/terminfo.git + url = http://git.haskell.org/packages/terminfo.git ignore = untracked [submodule "libraries/transformers"] path = libraries/transformers - url = ../packages/transformers.git + url = http://git.haskell.org/packages/transformers.git ignore = untracked [submodule "libraries/xhtml"] path = libraries/xhtml - url = ../packages/xhtml.git + url = http://git.haskell.org/packages/xhtml.git ignore = untracked [submodule "libraries/Win32"] path = libraries/Win32 - url = ../packages/Win32.git + url = http://git.haskell.org/packages/Win32.git ignore = untracked [submodule "libraries/primitive"] path = libraries/primitive - url = ../packages/primitive.git + url = http://git.haskell.org/packages/primitive.git ignore = untracked [submodule "libraries/vector"] path = libraries/vector - url = ../packages/vector.git + url = http://git.haskell.org/packages/vector.git ignore = untracked [submodule "libraries/time"] path = libraries/time - url = ../packages/time.git + url = http://git.haskell.org/packages/time.git ignore = untracked [submodule "libraries/random"] path = libraries/random - url = ../packages/random.git + url = http://git.haskell.org/packages/random.git ignore = untracked [submodule "libraries/array"] path = libraries/array - url = ../packages/array.git + url = http://git.haskell.org/packages/array.git ignore = none [submodule "libraries/deepseq"] path = libraries/deepseq - url = ../packages/deepseq.git + url = http://git.haskell.org/packages/deepseq.git ignore = none [submodule "libraries/directory"] path = libraries/directory - url = ../packages/directory.git + url = http://git.haskell.org/packages/directory.git ignore = none [submodule "libraries/filepath"] path = libraries/filepath - url = ../packages/filepath.git + url = http://git.haskell.org/packages/filepath.git ignore = none [submodule "libraries/hoopl"] path = libraries/hoopl - url = ../packages/hoopl.git + url = http://git.haskell.org/packages/hoopl.git ignore = none [submodule "libraries/hpc"] path = libraries/hpc - url = ../packages/hpc.git + url = http://git.haskell.org/packages/hpc.git ignore = none [submodule "libraries/process"] path = libraries/process - url = ../packages/process.git + url = http://git.haskell.org/packages/process.git ignore = none [submodule "libraries/unix"] path = libraries/unix - url = ../packages/unix.git + url = http://git.haskell.org/packages/unix.git ignore = none [submodule "libraries/parallel"] path = libraries/parallel - url = ../packages/parallel.git + url = http://git.haskell.org/packages/parallel.git ignore = none [submodule "libraries/stm"] path = libraries/stm - url = ../packages/stm.git + url = http://git.haskell.org/packages/stm.git ignore = none [submodule "libraries/dph"] path = libraries/dph - url = ../packages/dph.git + url = http://git.haskell.org/packages/dph.git ignore = none [submodule "utils/haddock"] path = utils/haddock - url = ../haddock.git + url = http://git.haskell.org/haddock.git ignore = none branch = ghc-head [submodule "nofib"] path = nofib - url = ../nofib.git + url = http://git.haskell.org/nofib.git ignore = none [submodule "utils/hsc2hs"] path = utils/hsc2hs - url = ../hsc2hs.git + url = http://git.haskell.org/hsc2hs.git ignore = none [submodule "libffi-tarballs"] path = libffi-tarballs - url = ../libffi-tarballs.git + url = http://git.haskell.org/libffi-tarballs.git ignore = none [submodule ".arc-linters/arcanist-external-json-linter"] path = .arc-linters/arcanist-external-json-linter @@ -1,39 +1,91 @@ -The Glasgow Haskell Compiler -============================ +Dependent Types Branch of GHC +============================= -[](http://travis-ci.org/ghc/ghc) +This is a fork of GHC, with work toward supporting dependent types. +Anyone is welcome to download and play with this implementation, +and I am happy to receive feedback and issue reports on GitHub. -This is the source tree for [GHC][1], a compiler and interactive -environment for the Haskell functional programming language. +There are two options of using this branch: manual, and Nix-based. -For more information, visit [GHC's web site][1]. +Manual +------ + +This code should build, but I have tested it only on `DEBUG` settings; +I recommend using build style `devel2` in `build.mk`. + +Here is a minimal script you can follow to build this at home; +see the [GHC Building Guide] [3] for more info. + +~~~ +git clone https://github.com/goldfirere/ghc.git +cd ghc +git checkout nokinds +git remote set-url origin git://git.haskell.org/ghc.git # so submodules work +git submodule update --init +cd mk +cp build.mk.sample build.mk +## edit build.mk to uncomment the line to choose the `devel2` configuration +cd .. +perl boot +./configure +make +~~~ + +Check out the `testsuite/tests/dependent/should_compile` directory for +a few sample programs that should compile on this fork of GHC. + +For more information about GHC, visit [GHC's web site][1]. Information for developers of GHC can be found on the [GHC Trac][2]. +Nix-based +--------- + +Thanks to @deepfire, this branch is available in Nixpkgs, which means that with +some effort it can be fairly automatically employed to build any package from +Hackage. This way, though, requires that one installs the Nix package manager in +parallel with the system package manager -- and this option is currently +unavailable on Windows. + +Here are the instructions: + +1. To install the Nix package manager, taking over /nix for package storage: + + curl https://nixos.org/nix/install | sh + +2. Make Nix use the `master` repository of Nixpkgs package definitions: -Getting the Source -================== + git clone https://github.com/NixOS/nixpkgs.git + pushd ~/.nix-defexpr + rm -rf channels + ln -s ../nixpkgs + popd + echo 'export NIX_PATH=nixpkgs=/home/---<USERNAME>---/nixpkgs' >> ~/.bashrc + export NIX_PATH=nixpkgs=/home/---<USERNAME>---/nixpkgs -There are two ways to get a source tree: +3. [OPTIONAL] To enable prebuilt binaries from Peter Simons/NixOS Hydra servers: - 1. *Download source tarballs* + sudo mkdir /etc/nix + echo 'binary-caches = http://hydra.nixos.org/ http://hydra.cryp.to/' | sudo dd of=/etc/nix/nix.conf - Download the GHC source distribution: + # If you don't do that, everything will still work, just it'll have + # to build everything from source. - ghc-<version>-src.tar.bz2 +4. Enter a shell with `ghc-nokinds` available: - which contains GHC itself and the "boot" libraries. + nix-shell -p haskell.compiler.ghcNokinds - 2. *Check out the source code from git* +5. See it's indeed `nokinds`: - $ git clone --recursive git://git.haskell.org/ghc.git + wget https://raw.githubusercontent.com/goldfirere/ghc/nokinds/testsuite/tests/dependent/should_compile/KindEqualities2.hs + runhaskell KindEqualities2.hs - Note: cloning GHC from Github requires a special setup. See [Getting a GHC - repository from Github] [7]. +To apply 'nokinds' to building packages from Hackage, the best option would be +to follow instructions from the "Nix loves Haskell" talk by Peter Simons: - **DO NOT submit pull request directly to the github repo.** - *See the GHC team's working conventions re [how to contribute a patch to GHC](http://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/FixingBugs "ghc.haskell.org/trac/ghc/wiki/WorkingConventions/FixingBug").* + http://cryp.to/nixos-meetup-3-slides.pdf +..where the relevant compiler name would be "ghcNokinds". Building & Installing ===================== diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index ae51d07458..4133eac35f 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -413,6 +413,10 @@ isBoxed :: Boxity -> Bool isBoxed Boxed = True isBoxed Unboxed = False +instance Outputable Boxity where + ppr Boxed = text "Boxed" + ppr Unboxed = text "Unboxed" + {- ************************************************************************ * * diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs index 7ff075c8c1..09ad68b317 100644 --- a/compiler/basicTypes/ConLike.hs +++ b/compiler/basicTypes/ConLike.hs @@ -32,7 +32,7 @@ import Unique import Util import Name import BasicTypes -import TypeRep (Type, ThetaType) +import TyCoRep (Type, ThetaType) import Var import Type (mkTyConApp) @@ -169,7 +169,7 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys -- -- 7) The original result type conLikeFullSig :: ConLike - -> ([TyVar], [TyVar], [(TyVar,Type)] + -> ([TyVar], [TyVar], [EqSpec] , ThetaType, ThetaType, [Type], Type) conLikeFullSig (RealDataCon con) = let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 6e69a1cbce..712a9b2b86 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -15,19 +15,23 @@ module DataCon ( StrictnessMark(..), ConTag, + -- ** Equality specs + EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, + eqSpecPair, eqSpecPreds, + substEqSpec, + -- ** Field labels FieldLbl(..), FieldLabel, FieldLabelString, -- ** Type construction - mkDataCon, fIRST_TAG, - buildAlgTyCon, + mkDataCon, buildAlgTyCon, fIRST_TAG, -- ** Type deconstruction dataConRepType, dataConSig, dataConInstSig, dataConFullSig, dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConOrigTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, - dataConEqSpec, eqSpecPreds, dataConTheta, + dataConEqSpec, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, @@ -45,37 +49,32 @@ module DataCon ( isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, isVanillaDataCon, classDataCon, dataConCannotMatch, isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, + specialPromotedDc, isLegacyPromotableDataCon, isLegacyPromotableTyCon, -- ** Promotion related functions - promoteDataCon, promoteDataCon_maybe, - promoteType, promoteKind, - isPromotableType, computeTyConPromotability, + promoteDataCon ) where #include "HsVersions.h" import {-# SOURCE #-} MkId( DataConBoxer ) import Type -import ForeignCall( CType ) -import TypeRep( Type(..) ) -- Used in promoteType -import PrelNames( liftedTypeKindTyConKey ) +import ForeignCall ( CType ) import Coercion -import Kind import Unify import TyCon import FieldLabel import Class import Name +import PrelNames +import NameEnv import Var import Outputable -import Unique import ListSetOps import Util import BasicTypes import FastString import Module -import VarEnv -import NameSet import Binary import qualified Data.Data as Data @@ -299,11 +298,11 @@ data DataCon -- syntax, provided its type looks like the above. -- The declaration format is held in the TyCon (algTcGadtSyntax) - dcUnivTyVars :: [TyVar], -- Universally-quantified type vars [a,b,c] + dcUnivTyVars :: [TyVar], -- Universally-quantified type vars [a,b,c] -- INVARIANT: length matches arity of the dcRepTyCon --- result type of (rep) data con is exactly (T a b c) - dcExTyVars :: [TyVar], -- Existentially-quantified type vars + dcExTyVars :: [TyVar], -- Existentially-quantified type vars -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS -- FOR THE PARENT TyCon. With GADTs the data con might not even have -- the same number of type variables. @@ -313,8 +312,9 @@ data DataCon -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames -- Reason: less confusing, and easier to generate IfaceSyn - dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type, - -- _as written by the programmer_ + dcEqSpec :: [EqSpec], -- Equalities derived from the result type, + -- _as written by the programmer_ + -- This field allows us to move conveniently between the two ways -- of representing a GADT constructor's type: -- MkT :: forall a b. (a ~ [b]) => b -> T a @@ -377,8 +377,10 @@ data DataCon dcRep :: DataConRep, -- Cached - dcRepArity :: Arity, -- == length dataConRepArgTys - dcSourceArity :: Arity, -- == length dcOrigArgTys + -- dcRepArity == length dataConRepArgTys + dcRepArity :: Arity, + -- dcSourceArity == length dcOrigArgTys + dcSourceArity :: Arity, -- Result type of constructor is T t1..tn dcRepTyCon :: TyCon, -- Result tycon, T @@ -402,8 +404,8 @@ data DataCon -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere - dcPromoted :: Promoted TyCon -- The promoted TyCon if this DataCon is promotable - -- See Note [Promoted data constructors] in TyCon + dcPromoted :: TyCon -- The promoted TyCon + -- See Note [Promoted data constructors] in TyCon } deriving Data.Typeable.Typeable @@ -496,6 +498,40 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified -- of the DataCon *worker* fields data StrictnessMark = MarkedStrict | NotMarkedStrict +-- | An 'EqSpec' is a tyvar/type pair representing an equality made in +-- rejigging a GADT constructor +data EqSpec = EqSpec TyVar + Type + +-- | Make an 'EqSpec' +mkEqSpec :: TyVar -> Type -> EqSpec +mkEqSpec tv ty = EqSpec tv ty + +eqSpecTyVar :: EqSpec -> TyVar +eqSpecTyVar (EqSpec tv _) = tv + +eqSpecType :: EqSpec -> Type +eqSpecType (EqSpec _ ty) = ty + +eqSpecPair :: EqSpec -> (TyVar, Type) +eqSpecPair (EqSpec tv ty) = (tv, ty) + +eqSpecPreds :: [EqSpec] -> ThetaType +eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty + | EqSpec tv ty <- spec ] + +-- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec +-- is mapped in the substitution, it is mapped to a type variable, not +-- a full type. +substEqSpec :: TCvSubst -> EqSpec -> EqSpec +substEqSpec subst (EqSpec tv ty) + = EqSpec tv' (substTy subst ty) + where + tv' = getTyVar "substEqSpec" (substTyVar subst tv) + +instance Outputable EqSpec where + ppr (EqSpec tv ty) = ppr (tv, ty) + {- Note [Bangs on data constructor arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -674,14 +710,13 @@ isMarkedStrict _ = True -- All others are strict -- | Build a new data constructor mkDataCon :: Name -> Bool -- ^ Is the constructor declared infix? - -> Promoted TyConRepName -- ^ Whether promoted, and if so the TyConRepName - -- for the promoted TyCon + -> TyConRepName -- ^ TyConRepName for the promoted TyCon -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user -> [FieldLabel] -- ^ Field labels for the constructor, -- if it is a record, otherwise empty -> [TyVar] -- ^ Universally quantified type variables -> [TyVar] -- ^ Existentially quantified type variables - -> [(TyVar,Type)] -- ^ GADT equalities + -> [EqSpec] -- ^ GADT equalities -> ThetaType -- ^ Theta-type occuring before the arguments proper -> [Type] -- ^ Original argument types -> Type -- ^ Original result type @@ -725,7 +760,7 @@ mkDataCon name declared_infix prom_info dcRep = rep, dcSourceArity = length orig_arg_tys, dcRepArity = length rep_arg_tys, - dcPromoted = mb_promoted } + dcPromoted = promoted } -- The 'arg_stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the @@ -733,20 +768,15 @@ mkDataCon name declared_infix prom_info tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con rep_arg_tys = dataConRepArgTys con - rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ + rep_ty = mkInvForAllTys univ_tvs $ mkInvForAllTys ex_tvs $ mkFunTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) - mb_promoted -- See Note [Promoted data constructors] in TyCon - = case prom_info of - NotPromoted -> NotPromoted - Promoted rep_nm -> Promoted (mkPromotedDataCon con name rep_nm prom_kind prom_roles) - prom_kind = promoteType (dataConUserType con) - prom_roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ - map (const Representational) orig_arg_tys + promoted -- See Note [Promoted data constructors] in TyCon + = mkPromotedDataCon con name prom_info (dataConUserType con) roles -eqSpecPreds :: [(TyVar,Type)] -> ThetaType -eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] + roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ + map (const Representational) orig_arg_tys -- | The 'Name' of the 'DataCon', giving it a unique, rooted identification dataConName :: DataCon -> Name @@ -791,11 +821,30 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) = univ_tvs ++ ex_tvs -- | Equalities derived from the result type of the data constructor, as written --- by the programmer in any GADT declaration -dataConEqSpec :: DataCon -> [(TyVar,Type)] -dataConEqSpec = dcEqSpec - --- | The *full* constraints on the constructor type +-- by the programmer in any GADT declaration. This includes *all* GADT-like +-- equalities, including those written in by hand by the programmer. +dataConEqSpec :: DataCon -> [EqSpec] +dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eq_spec ++ + [ spec -- heterogeneous equality + | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` heqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] ++ + [ spec -- homogeneous equality + | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` eqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] + + +-- | The *full* constraints on the constructor type. dataConTheta :: DataCon -> ThetaType dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) = eqSpecPreds eq_spec ++ theta @@ -906,10 +955,9 @@ dataConBoxer _ = Nothing -- -- 4) The /original/ result type of the 'DataCon' dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) -dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, - dcEqSpec = eq_spec, dcOtherTheta = theta, - dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) +dataConSig con@(MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs ++ ex_tvs, dataConTheta con, arg_tys, res_ty) dataConInstSig :: DataCon @@ -926,7 +974,7 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs , substTheta subst (eqSpecPreds eq_spec ++ theta) , substTys subst arg_tys) where - univ_subst = zipTopTvSubst univ_tvs univ_tys + univ_subst = zipOpenTCvSubst univ_tvs univ_tys (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst ex_tvs @@ -936,7 +984,7 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs -- -- 2) The result of 'dataConExTyVars' -- --- 3) The result of 'dataConEqSpec' +-- 3) The GADT equalities -- -- 4) The result of 'dataConDictTheta' -- @@ -945,7 +993,7 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs -- -- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) + -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) @@ -972,11 +1020,12 @@ dataConUserType :: DataCon -> Type -- -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. -dataConUserType (MkData { dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) - = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ +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) $ mkFunTys theta $ mkFunTys arg_tys $ res_ty @@ -1020,8 +1069,9 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc --- | Returns the arg types of the worker, including *all* evidence, after any --- flattening has been done and without substituting for any type variables +-- | Returns the arg types of the worker, including *all* +-- evidence, after any flattening has been done and without substituting for +-- any type variables dataConRepArgTys :: DataCon -> [Type] dataConRepArgTys (MkData { dcRep = rep , dcEqSpec = eq_spec @@ -1051,6 +1101,34 @@ isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc isVanillaDataCon :: DataCon -> Bool isVanillaDataCon dc = dcVanilla dc +-- | Should this DataCon be allowed in a type even without -XDataKinds? +-- Currently, only Lifted & Unlifted +specialPromotedDc :: DataCon -> Bool +specialPromotedDc dc + = dc `hasKey` liftedDataConKey || + dc `hasKey` unliftedDataConKey + +-- | Was this datacon promotable before GHC 8.0? That is, is it promotable +-- without -XTypeInType +isLegacyPromotableDataCon :: DataCon -> Bool +isLegacyPromotableDataCon dc + = null (dataConEqSpec dc) -- no GADTs + && null (dataConTheta dc) -- no context + && not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors + && all isLegacyPromotableTyCon (nameEnvElts $ + tyConsOfType (dataConUserType dc)) + +-- | Was this tycon promotable before GHC 8.0? That is, is it promotable +-- without -XTypeInType +isLegacyPromotableTyCon :: TyCon -> Bool +isLegacyPromotableTyCon tc + = isVanillaAlgTyCon tc || + -- This returns True more often than it should, but it's quite painful + -- to make this fully accurate. And no harm is caused; we just don't + -- require -XTypeInType every time we need to. (We'll always require + -- -XDataKinds, though, so there's no standards-compliance issue.) + isFunTyCon tc || isKindTyCon tc + classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr @@ -1060,8 +1138,6 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool -- Returns True iff the data con *definitely cannot* match a -- scrutinee of type (T tys) -- where T is the dcRepTyCon for the data con --- NB: look at *all* equality constraints, not only those --- in dataConEqSpec; see Trac #5168 dataConCannotMatch tys con | null inst_theta = False -- Common | all isTyVarTy tys = False -- Also common @@ -1071,161 +1147,22 @@ dataConCannotMatch tys con -- TODO: could gather equalities from superclasses too predEqs pred = case classifyPredType pred of - EqPred NomEq ty1 ty2 -> [(ty1, ty2)] - _ -> [] + EqPred NomEq ty1 ty2 -> [(ty1, ty2)] + ClassPred eq [_, ty1, ty2] + | eq `hasKey` eqTyConKey -> [(ty1, ty2)] + _ -> [] {- -************************************************************************ -* * - Promotion - - These functions are here because - - isPromotableTyCon calls dataConFullSig - - mkDataCon calls promoteType - - It's nice to keep the promotion stuff together +%************************************************************************ +%* * + Promoting of data types to the kind level * * ************************************************************************ -Note [The overall promotion story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is the overall plan. - -* Compared to a TyCon T, the promoted 'T has - same Name (and hence Unique) - same TyConRepName - In future the two will collapse into one anyhow. - -* Compared to a DataCon K, the promoted 'K (a type constructor) has - same Name (and hence Unique) - But it has a fresh TyConRepName; after all, the DataCon doesn't have - a TyConRepName at all. (See Note [Grand plan for Typeable] in TcTypeable - for TyConRepName.) - - Why does 'K have the same unique as K? It's acceptable because we don't - mix types and terms, so we won't get them confused. And it's helpful mainly - so that we know when to print 'K as a qualified name in error message. The - PrintUnqualified stuff depends on whether K is lexically in scope.. but 'K - never is! - -* It follows that the tick-mark (eg 'K) is not part of the Occ name of - either promoted data constructors or type constructors. Instead, - pretty-printing: the pretty-printer prints a tick in front of - - promoted DataCons (always) - - promoted TyCons (with -dppr-debug) - See TyCon.pprPromotionQuote - -* For a promoted data constructor K, the pipeline goes like this: - User writes (in a type): K or 'K - Parser produces OccName: K{tc} or K{d}, respectively - Renamer makes Name: M.K{d}_r62 (i.e. same unique as DataCon K) - and K{tc} has been turned into K{d} - provided it was unambiguous - Typechecker makes TyCon: PromotedDataCon MK{d}_r62 - - -Note [Checking whether a group is promotable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only want to promote a TyCon if all its data constructors -are promotable; it'd be very odd to promote some but not others. - -But the data constructors may mention this or other TyCons. - -So we treat the recursive uses as all OK (ie promotable) and -do one pass to check that each TyCon is promotable. - -Currently type synonyms are not promotable, though that -could change. -} promoteDataCon :: DataCon -> TyCon -promoteDataCon (MkData { dcPromoted = Promoted tc }) = tc -promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc) - -promoteDataCon_maybe :: DataCon -> Promoted TyCon -promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc - -computeTyConPromotability :: NameSet -> TyCon -> Bool -computeTyConPromotability rec_tycons tc - = isAlgTyCon tc -- Only algebraic; not even synonyms - -- (we could reconsider the latter) - && ok_kind (tyConKind tc) - && case algTyConRhs tc of - DataTyCon { data_cons = cs } -> all ok_con cs - TupleTyCon { data_con = c } -> ok_con c - NewTyCon { data_con = c } -> ok_con c - AbstractTyCon {} -> False - where - ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res - where -- Checks for * -> ... -> * -> * - (args, res) = splitKindFunTys kind - - -- See Note [Promoted data constructors] in TyCon - ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs - && null eq_spec -- No constraints - && null theta - && all (isPromotableType rec_tycons) orig_arg_tys - where - (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con - - -isPromotableType :: NameSet -> Type -> Bool --- Must line up with promoteType --- But the function lives here because we must treat the --- *recursive* tycons as promotable -isPromotableType rec_tcs con_arg_ty - = go con_arg_ty - where - go (TyConApp tc tys) = tys `lengthIs` tyConArity tc - && (tyConName tc `elemNameSet` rec_tcs - || isPromotableTyCon tc) - && all go tys - go (FunTy arg res) = go arg && go res - go (TyVarTy {}) = True - go _ = False - -{- -Note [Promoting a Type to a Kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppsoe we have a data constructor D - D :: forall (a:*). Maybe a -> T a -We promote this to be a type constructor 'D: - 'D :: forall (k:BOX). 'Maybe k -> 'T k - -The transformation from type to kind is done by promoteType - - * Convert forall (a:*) to forall (k:BOX), and substitute - - * Ensure all foralls are at the top (no higher rank stuff) - - * Ensure that all type constructors mentioned (Maybe and T - in the example) are promotable; that is, they have kind - * -> ... -> * -> * --} - --- | Promotes a type to a kind. --- Assumes the argument satisfies 'isPromotableType' -promoteType :: Type -> Kind -promoteType ty - = mkForAllTys kvs (go rho) - where - (tvs, rho) = splitForAllTys ty - kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ] - env = zipVarEnv tvs kvs - - go (TyConApp tc tys) | Promoted prom_tc <- promotableTyCon_maybe tc - = mkTyConApp prom_tc (map go tys) - go (FunTy arg res) = mkArrowKind (go arg) (go res) - go (TyVarTy tv) | Just kv <- lookupVarEnv env tv - = TyVarTy kv - go _ = panic "promoteType" -- Argument did not satisfy isPromotableType - -promoteKind :: Kind -> SuperKind --- Promote the kind of a type constructor --- from (* -> * -> *) to (BOX -> BOX -> BOX) -promoteKind (TyConApp tc []) - | tc `hasKey` liftedTypeKindTyConKey = superKind -promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res) -promoteKind k = pprPanic "promoteKind" (ppr k) +promoteDataCon (MkData { dcPromoted = tc }) = tc {- ************************************************************************ @@ -1283,22 +1220,13 @@ buildAlgTyCon :: Name -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag - -> Bool -- ^ True <=> this TyCon is promotable -> Bool -- ^ True <=> was declared in GADT syntax -> AlgTyConFlav -> TyCon buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs - is_rec is_promotable gadt_syn parent - = tc + is_rec gadt_syn parent + = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta + rhs parent is_rec gadt_syn where - kind = mkPiKinds ktvs liftedTypeKind - - -- tc and mb_promoted_tc are mutually recursive - tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta - rhs parent is_rec gadt_syn - mb_promoted_tc - - mb_promoted_tc - | is_promotable = Promoted (mkPromotedTyCon tc (promoteKind kind)) - | otherwise = NotPromoted + kind = mkPiTypesPreferFunTy ktvs liftedTypeKind diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot index 615ef53d09..d60977452b 100644 --- a/compiler/basicTypes/DataCon.hs-boot +++ b/compiler/basicTypes/DataCon.hs-boot @@ -6,10 +6,13 @@ import FieldLabel ( FieldLabel ) import Unique ( Uniquable ) import Outputable ( Outputable, OutputableBndr ) import BasicTypes (Arity) -import {-# SOURCE #-} TypeRep (Type, ThetaType) +import {-# SOURCE #-} TyCoRep (Type, ThetaType) data DataCon data DataConRep +data EqSpec +eqSpecTyVar :: EqSpec -> TyVar + dataConName :: DataCon -> Name dataConTyCon :: DataCon -> TyCon dataConExTyVars :: DataCon -> [TyVar] @@ -18,7 +21,7 @@ dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] dataConStupidTheta :: DataCon -> ThetaType dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) + -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) instance Eq DataCon instance Ord DataCon diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index b49a8160fe..775a77ba38 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -17,7 +17,7 @@ -- -- * 'Name.Name': see "Name#name_types" -- --- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TypeRep.Type' and some additional +-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional -- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that -- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either -- be global or local, see "Var#globalvslocal" @@ -30,11 +30,14 @@ module Id ( -- ** Simple construction mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalIdWithInfo, mkExportedLocalId, - mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, - mkDerivedLocalM, + mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, + mkLocalIdOrCoVarWithInfo, + mkLocalIdWithInfo, mkExportedLocalId, + mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, + mkUserLocal, mkUserLocalCoVar, mkUserLocalOrCoVar, + mkDerivedLocalCoVarM, mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, mkWiredInIdName, + mkWorkerId, -- ** Taking an Id apart idName, idType, idUnique, idInfo, idDetails, idRepArity, @@ -111,7 +114,7 @@ import IdInfo import BasicTypes -- Imported and re-exported -import Var( Id, DictId, +import Var( Id, CoVar, DictId, idInfo, idDetails, globaliseId, varType, isId, isLocalId, isGlobalId, isExportedId ) import qualified Var @@ -191,7 +194,7 @@ localiseId id | ASSERT( isId id ) isLocalId id && isInternalName name = id | otherwise - = mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id) + = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) where name = idName id @@ -249,7 +252,31 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId mkLocalId :: Name -> Type -> Id mkLocalId name ty = mkLocalIdWithInfo name ty (vanillaIdInfo `setOneShotInfo` typeOneShot ty) + -- It's tempting to ASSERT( not (isCoercionType ty) ), but don't. Sometimes, + -- the type is a panic. (Search invented_id) + +-- | Make a local CoVar +mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar name ty + = ASSERT( isCoercionType ty ) + Var.mkLocalVar CoVarId name ty (vanillaIdInfo `setOneShotInfo` typeOneShot ty) + +-- | Like 'mkLocalId', but checks the type to see if it should make a covar +mkLocalIdOrCoVar :: Name -> Type -> Id +mkLocalIdOrCoVar name ty + | isCoercionType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name ty + +-- | Make a local id, with the IdDetails set to CoVarId if the type indicates +-- so. +mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id +mkLocalIdOrCoVarWithInfo name ty info + = Var.mkLocalVar details name ty info + where + details | isCoercionType ty = CoVarId + | otherwise = VanillaId + -- proper ids only; no covars! mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info -- Note [Free type variables] @@ -265,26 +292,45 @@ mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanil -- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") -- that are created by the compiler out of thin air mkSysLocal :: FastString -> Unique -> Type -> Id -mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty +mkSysLocal fs uniq ty = ASSERT( not (isCoercionType ty) ) + mkLocalId (mkSystemVarName uniq fs) ty + +-- | Like 'mkSysLocal', but checks to see if we have a covar type +mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id +mkSysLocalOrCoVar fs uniq ty + | isCoercionType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name ty + where + name = mkSystemVarName uniq fs mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) +mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalOrCoVarM fs ty + = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) -- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty - -mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id -mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc)) - -mkDerivedLocalM :: MonadUnique m => (OccName -> OccName) -> Id -> Type -> m Id -mkDerivedLocalM deriv_name id ty - = getUniqueM >>= (\uniq -> return (mkLocalId (mkDerivedInternalName deriv_name uniq (getName id)) ty)) - -mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name -mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax +mkUserLocal occ uniq ty loc = ASSERT( not (isCoercionType ty) ) + mkLocalId (mkInternalName uniq occ loc) ty + +-- | Like 'mkUserLocal' for covars +mkUserLocalCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocalCoVar occ uniq ty loc + = mkLocalCoVar (mkInternalName uniq occ loc) ty + +-- | Like 'mkUserLocal', but checks if we have a coercion type +mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocalOrCoVar occ uniq ty loc + = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty + +mkDerivedLocalCoVarM :: MonadUnique m => (OccName -> OccName) -> Id -> Type -> m Id +mkDerivedLocalCoVarM deriv_name id ty + = ASSERT( isCoercionType ty ) + do { uniq <- getUniqueM + ; let name = mkDerivedInternalName deriv_name uniq (getName id) + ; return (mkLocalCoVar name ty) } {- Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -295,11 +341,11 @@ instantiated before use. -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty - = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty + = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings mkTemplateLocal :: Int -> Type -> Id -mkTemplateLocal i ty = mkSysLocal (fsLit "tpl") (mkBuiltinUnique i) ty +mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "tpl") (mkBuiltinUnique i) ty -- | Create a template local for a series of types mkTemplateLocals :: [Type] -> [Id] diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index 6f00df5f6f..450644d734 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -10,7 +10,7 @@ Haskell. [WDP 94/11]) module IdInfo ( -- * The IdDetails type - IdDetails(..), pprIdDetails, coVarDetails, + IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, RecSelParent(..), -- * The IdInfo type @@ -135,20 +135,19 @@ data IdDetails -- implemented with a newtype, so it might be bad -- to be strict on this dictionary + | CoVarId -- ^ A coercion variable + -- The rest are distinguished only for debugging reasons -- e.g. to suppress them in -ddump-types -- Currently we don't persist these through interface file -- (see MkIface.toIfaceIdDetails), but we easily could if it mattered - | DefMethId -- ^ A default-method Id, either polymorphic or generic - | ReflectionId -- ^ A top-level Id to support runtime reflection -- e.g. $trModule, or $tcT | PatSynId -- ^ A top-level Id to support pattern synonyms; -- the builder or matcher for the patern synonym - data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq -- Either `TyCon` or `PatSyn` depending -- on the origin of the record selector. @@ -160,10 +159,15 @@ instance Outputable RecSelParent where RecSelData ty_con -> ppr ty_con RecSelPatSyn ps -> ppr ps - - +-- | Just a synonym for 'CoVarId'. Written separately so it can be +-- exported in the hs-boot file. coVarDetails :: IdDetails -coVarDetails = VanillaId +coVarDetails = CoVarId + +-- | Check if an 'IdDetails' says 'CoVarId'. +isCoVarDetails :: IdDetails -> Bool +isCoVarDetails CoVarId = True +isCoVarDetails _ = False instance Outputable IdDetails where ppr = pprIdDetails @@ -173,7 +177,6 @@ pprIdDetails VanillaId = empty pprIdDetails other = brackets (pp other) where pp VanillaId = panic "pprIdDetails" - pp DefMethId = ptext (sLit "DefMethId") pp ReflectionId = ptext (sLit "ReflectionId") pp PatSynId = ptext (sLit "PatSynId") pp (DataConWorkId _) = ptext (sLit "DataCon") @@ -186,6 +189,7 @@ pprIdDetails other = brackets (pp other) pp (RecSelId { sel_naughty = is_naughty }) = brackets $ ptext (sLit "RecSel") <> ppWhen is_naughty (ptext (sLit "(naughty)")) + pp CoVarId = ptext (sLit "CoVarId") {- ************************************************************************ diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot index 2e9862944e..0fabad3bbb 100644 --- a/compiler/basicTypes/IdInfo.hs-boot +++ b/compiler/basicTypes/IdInfo.hs-boot @@ -5,4 +5,6 @@ data IdDetails vanillaIdInfo :: IdInfo coVarDetails :: IdDetails +isCoVarDetails :: IdDetails -> Bool pprIdDetails :: IdDetails -> SDoc + diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs index bce3061a20..4b1fe94cac 100644 --- a/compiler/basicTypes/Lexeme.hs +++ b/compiler/basicTypes/Lexeme.hs @@ -226,7 +226,6 @@ okSymChar c OtherSymbol -> True _ -> False - -- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. reservedIds :: Set.Set String reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 8223f3340b..b0ef583482 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -21,8 +21,7 @@ module MkId ( wrapNewTypeBody, unwrapNewTypeBody, wrapFamInstBody, unwrapFamInstScrut, - wrapTypeFamInstBody, wrapTypeUnbranchedFamInstBody, unwrapTypeFamInstScrut, - unwrapTypeUnbranchedFamInstScrut, + wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut, DataConBoxer(..), mkDataConRep, mkDataConWorkId, @@ -281,8 +280,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 = mkForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) - (getNth arg_tys val_index)) + sel_ty = mkInvForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) + (getNth arg_tys val_index)) base_info = noCafIdInfo `setArityInfo` 1 @@ -338,7 +337,7 @@ mkDictSelRhs clas val_index dict_id = mkTemplateLocal 1 pred arg_ids = mkTemplateLocalsNum 2 arg_tys - rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) + rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] -- varToCoreExpr needed for equality superclass selectors @@ -458,7 +457,7 @@ dataConCPR con type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) -- Unbox: bind rep vars by decomposing src var -data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr)) +data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) -- Box: build src arg using these rep vars newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) @@ -507,7 +506,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con -- we want to see that w is strict in its two arguments wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs - wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs + wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs wrap_rhs = mkLams wrap_tvs $ mkLams wrap_args $ wrapFamInstBody tycon res_ty_args $ @@ -520,13 +519,15 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con , dcr_bangs = arg_ibangs }) } where - (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con - res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) + = dataConFullSig data_con + res_ty_args = substTyVars (mkTopTCvSubst (map eqSpecPair eq_spec)) univ_tvs + tycon = dataConTyCon data_con -- The representation TyCon (not family) wrap_ty = dataConUserType data_con ev_tys = eqSpecPreds eq_spec ++ theta all_arg_tys = ev_tys ++ orig_arg_tys - ev_ibangs = map mk_pred_strict_mark ev_tys + ev_ibangs = map (const HsLazy) ev_tys orig_bangs = dataConSrcBangs data_con wrap_arg_tys = theta ++ orig_arg_tys @@ -550,22 +551,21 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker && (any isBanged (ev_ibangs ++ arg_ibangs) -- Some forcing/unboxing (includes eq_spec) - || isFamInstTyCon tycon) -- Cast result + || isFamInstTyCon tycon -- Cast result + || (not $ null eq_spec)) -- GADT initial_wrap_app = Var (dataConWorkId data_con) - `mkTyApps` res_ty_args - `mkVarApps` ex_tvs - `mkCoApps` map (mkReflCo Nominal . snd) eq_spec - -- Dont box the eq_spec coercions since they are - -- marked as HsUnpack by mk_dict_strict_mark + `mkTyApps` res_ty_args + `mkVarApps` ex_tvs + `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec mk_boxer :: [Boxer] -> DataConBoxer mk_boxer boxers = DCB (\ ty_args src_vars -> - do { let ex_vars = takeList ex_tvs src_vars - subst1 = mkTopTvSubst (univ_tvs `zip` ty_args) - subst2 = extendTvSubstList subst1 ex_tvs - (mkTyVarTys ex_vars) - ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars) + do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars + subst1 = mkTopTCvSubst (univ_tvs `zip` ty_args) + subst2 = extendTCvSubstList subst1 ex_tvs + (mkTyVarTys ex_vars) + ; (rep_ids, binds) <- go subst2 boxers term_vars ; return (ex_vars ++ rep_ids, binds) } ) go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) @@ -610,7 +610,7 @@ dataConOrigArgTys of the DataCon. ------------------------- newLocal :: Type -> UniqSM Var newLocal ty = do { uniq <- getUniqueM - ; return (mkSysLocal (fsLit "dt") uniq ty) } + ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } -- | Unpack/Strictness decisions from source module dataConSrcToImplBang @@ -694,7 +694,7 @@ wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) ; return ([rep_id], Var rep_id) } Boxer boxer -> boxer subst - ; let sco = substCo (tvCvSubst subst) co + ; let sco = substCo subst co ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } ------------------------ @@ -832,24 +832,6 @@ But it's the *argument* type that matters. This is fine: data S = MkS S !Int because Int is non-recursive. - -Note [Unpack equality predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a GADT with a constructor C :: (a~[b]) => b -> T a -we definitely want that equality predicate *unboxed* so that it -takes no space at all. This is easily done: just give it -an UNPACK pragma. The rest of the unpack/repack code does the -heavy lifting. This one line makes every GADT take a word less -space for each equality predicate, so it's pretty important! --} - -mk_pred_strict_mark :: PredType -> HsImplBang -mk_pred_strict_mark pred - | isEqPred pred = HsUnpack Nothing - -- Note [Unpack equality predicates] - | otherwise = HsLazy - -{- ************************************************************************ * * Wrapping and unwrapping newtypes and type families @@ -881,7 +863,7 @@ wrapNewTypeBody tycon args result_expr wrapFamInstBody tycon args $ mkCast result_expr (mkSymCo co) where - co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] -- When unwrapping, we do *not* apply any family coercion, because this will -- be done via a CoPat by the type checker. We have to do it this way as @@ -891,7 +873,7 @@ wrapNewTypeBody tycon args result_expr unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args) + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) -- If the type constructor is a representation type of a data instance, wrap -- the expression into a cast adjusting the expression type, which is an @@ -901,34 +883,36 @@ unwrapNewTypeBody tycon args result_expr wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody tycon args body | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args)) + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) | otherwise = body -- Same as `wrapFamInstBody`, but for type family instances, which are -- represented by a `CoAxiom`, and not a `TyCon` -wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr -wrapTypeFamInstBody axiom ind args body - = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args)) +wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> [Coercion] + -> CoreExpr -> CoreExpr +wrapTypeFamInstBody axiom ind args cos body + = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args cos)) -wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr - -> CoreExpr +wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> [Coercion] + -> CoreExpr -> CoreExpr wrapTypeUnbranchedFamInstBody axiom = wrapTypeFamInstBody axiom 0 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut tycon args scrut | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only + = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args []) -- data instances only | otherwise = scrut -unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr -unwrapTypeFamInstScrut axiom ind args scrut - = mkCast scrut (mkAxInstCo Representational axiom ind args) +unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> [Coercion] + -> CoreExpr -> CoreExpr +unwrapTypeFamInstScrut axiom ind args cos scrut + = mkCast scrut (mkAxInstCo Representational axiom ind args cos) -unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr - -> CoreExpr +unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> [Coercion] + -> CoreExpr -> CoreExpr unwrapTypeUnbranchedFamInstScrut axiom = unwrapTypeFamInstScrut axiom 0 @@ -945,7 +929,7 @@ mkPrimOpId prim_op = id where (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op - ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) + ty = mkInvForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) (AnId id) UserSyntax @@ -972,7 +956,7 @@ mkPrimOpId prim_op mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id mkFCallId dflags uniq fcall ty - = ASSERT( isEmptyVarSet (tyVarsOfType ty) ) + = ASSERT( isEmptyVarSet (tyCoVarsOfType ty) ) -- A CCallOpId should have no free type variables; -- when doing substitutions won't substitute over it mkGlobalId (FCallId fcall) name ty info @@ -987,9 +971,8 @@ mkFCallId dflags uniq fcall ty `setArityInfo` arity `setStrictnessInfo` strict_sig - (_, tau) = tcSplitForAllTys ty - (arg_tys, _) = tcSplitFunTys tau - arity = length arg_tys + (bndrs, _) = tcSplitPiTys ty + arity = count isIdLikeBinder bndrs strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes -- the call does not claim to be strict in its arguments, since they @@ -1030,7 +1013,7 @@ mkDictFunId dfun_name tvs theta clas tys mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type mkDictFunTy tvs theta clas tys - = mkSigmaTy tvs theta (mkClassPred clas tys) + = mkInvSigmaTy tvs theta (mkClassPred clas tys) {- ************************************************************************ @@ -1078,11 +1061,11 @@ dollarId = pcMiscPrelId dollarName ty (noCafIdInfo `setUnfoldingInfo` unf) where fun_ty = mkFunTy alphaTy openBetaTy - ty = mkForAllTys [alphaTyVar, openBetaTyVar] $ + ty = mkInvForAllTys [levity2TyVar, alphaTyVar, openBetaTyVar] $ mkFunTy fun_ty fun_ty unf = mkInlineUnfolding (Just 2) rhs [f,x] = mkTemplateLocals [fun_ty, alphaTy] - rhs = mkLams [alphaTyVar, openBetaTyVar, f, x] $ + rhs = mkLams [levity2TyVar, alphaTyVar, openBetaTyVar, f, x] $ App (Var f) (Var x) ------------------------------------------------ @@ -1092,7 +1075,7 @@ proxyHashId = pcMiscPrelId proxyName ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] where - ty = mkForAllTys [kv, tv] (mkProxyPrimTy k t) + ty = mkInvForAllTys [kv, tv] (mkProxyPrimTy k t) kv = kKiVar k = mkTyVarTy kv [tv] = mkTemplateTyVars [k] @@ -1107,12 +1090,15 @@ unsafeCoerceId info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs + ty = mkInvForAllTys [ levity1TyVar, levity2TyVar + , openAlphaTyVar, openBetaTyVar ] + (mkFunTy openAlphaTy openBetaTy) - ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] - (mkFunTy openAlphaTy openBetaTy) [x] = mkTemplateLocals [openAlphaTy] - rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCo openAlphaTy openBetaTy) + rhs = mkLams [ levity1TyVar, levity2TyVar + , openAlphaTyVar, openBetaTyVar + , x] $ + Cast (Var x) (mkUnsafeCo Representational openAlphaTy openBetaTy) ------------------------------------------------ nullAddrId :: Id @@ -1138,8 +1124,8 @@ seqId = pcMiscPrelId seqName ty info -- LHS of rules. That way we can have rules for 'seq'; -- see Note [seqId magic] - ty = mkForAllTys [alphaTyVar,betaTyVar] - (mkFunTy alphaTy (mkFunTy betaTy betaTy)) + ty = mkInvForAllTys [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)]) @@ -1171,18 +1157,23 @@ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo - ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) + ty = mkInvForAllTys [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 = mkForAllTys [openAlphaTyVar, openBetaTyVar] (mkFunTy fun_ty fun_ty) + ty = mkInvForAllTys [ levity1TyVar, levity2TyVar + , openAlphaTyVar, openBetaTyVar ] + (mkFunTy fun_ty fun_ty) fun_ty = mkFunTy alphaTy betaTy - [body, x] = mkTemplateLocals [fun_ty, alphaTy] + [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] x' = setOneShotLambda x - rhs = mkLams [openAlphaTyVar, openBetaTyVar, body, x'] $ Var body `App` Var x + rhs = mkLams [ levity1TyVar, levity2TyVar + , openAlphaTyVar, openBetaTyVar + , body, x'] $ + Var body `App` Var x runRWId :: Id -- See Note [runRW magic] in this module runRWId = pcMiscPrelId runRWName ty info @@ -1191,19 +1182,20 @@ runRWId = pcMiscPrelId runRWName ty info -- State# RealWorld stateRW = mkTyConApp statePrimTyCon [realWorldTy] -- (# State# RealWorld, o #) - ret_ty = mkTyConApp unboxedPairTyCon [stateRW, openAlphaTy] + ret_ty = mkTupleTy Unboxed [stateRW, openAlphaTy] -- State# RealWorld -> (# State# RealWorld, o #) arg_ty = stateRW `mkFunTy` ret_ty -- (State# RealWorld -> (# State# RealWorld, o #)) -- -> (# State# RealWorld, o #) - ty = mkForAllTys [openAlphaTyVar] (arg_ty `mkFunTy` ret_ty) + ty = mkInvForAllTys [levity1TyVar, openAlphaTyVar] $ + arg_ty `mkFunTy` ret_ty -------------------------------------------------------------------------------- magicDictId :: Id -- See Note [magicDictId magic] magicDictId = pcMiscPrelId magicDictName ty info where info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - ty = mkForAllTys [alphaTyVar] alphaTy + ty = mkInvForAllTys [alphaTyVar] alphaTy -------------------------------------------------------------------------------- @@ -1212,15 +1204,18 @@ coerceId = pcMiscPrelId coerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs - eqRTy = mkTyConApp coercibleTyCon [liftedTypeKind, alphaTy, betaTy] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [liftedTypeKind, alphaTy, betaTy] - ty = mkForAllTys [alphaTyVar, betaTyVar] $ + eqRTy = mkTyConApp coercibleTyCon [ liftedTypeKind + , alphaTy, betaTy ] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind + , liftedTypeKind + , alphaTy, betaTy ] + ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ mkFunTys [eqRTy, alphaTy] betaTy [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy] rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $ mkWildCase (Var eqR) eqRTy betaTy $ - [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))] + [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] {- Note [dollarId magic] @@ -1484,7 +1479,7 @@ voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy coercionTokenId :: Id -- :: () ~ () coercionTokenId -- Used to replace Coercion terms when we go to STG = pcMiscPrelId coercionTokenName - (mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy]) + (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) noCafIdInfo pcMiscPrelId :: Name -> Type -> IdInfo -> Id diff --git a/compiler/basicTypes/MkId.hs-boot b/compiler/basicTypes/MkId.hs-boot index 69a694b1a2..0a9ac2c5f1 100644 --- a/compiler/basicTypes/MkId.hs-boot +++ b/compiler/basicTypes/MkId.hs-boot @@ -1,12 +1,15 @@ module MkId where import Name( Name ) import Var( Id ) +import Class( Class ) import {-# SOURCE #-} DataCon( DataCon ) import {-# SOURCE #-} PrimOp( PrimOp ) data DataConBoxer mkDataConWorkId :: Name -> DataCon -> Id +mkDictSelId :: Name -> Class -> Id + mkPrimOpId :: PrimOp -> Id magicDictId :: Id diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index c557889606..769b5aa044 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -77,8 +77,8 @@ module Name ( module OccName ) where -import {-# SOURCE #-} TypeRep( TyThing ) -import {-# SOURCE #-} PrelNames( liftedTypeKindTyConKey ) +import {-# SOURCE #-} TyCoRep( TyThing ) +import {-# SOURCE #-} PrelNames( starKindTyConKey, unicodeStarKindTyConKey ) import OccName import Module @@ -645,7 +645,7 @@ pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) pprPrefixName :: NamedThing a => a -> SDoc pprPrefixName thing - | name `hasKey` liftedTypeKindTyConKey + | name `hasKey` starKindTyConKey || name `hasKey` unicodeStarKindTyConKey = ppr name -- See Note [Special treatment for kind *] | otherwise = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) @@ -661,7 +661,7 @@ an operator, it is really a special case. This pprPrefixName stuff is really only used when printing HsSyn, which has to be polymorphic in the name type, and hence has to go via the overloaded function pprPrefixOcc. It's easier where we know the -type being pretty printed; eg the pretty-printing code in TypeRep. +type being pretty printed; eg the pretty-printing code in TyCoRep. See Trac #7645, which led to this. -} diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs index 9018bc44f9..d2641e22c0 100644 --- a/compiler/basicTypes/NameEnv.hs +++ b/compiler/basicTypes/NameEnv.hs @@ -12,7 +12,8 @@ module NameEnv ( -- ** Manipulating these environments mkNameEnv, - emptyNameEnv, unitNameEnv, nameEnvElts, nameEnvUniqueElts, + emptyNameEnv, isEmptyNameEnv, + unitNameEnv, nameEnvElts, nameEnvUniqueElts, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, foldNameEnv, filterNameEnv, anyNameEnv, @@ -68,6 +69,7 @@ depAnal get_defs get_uses nodes type NameEnv a = UniqFM a -- Domain is Name emptyNameEnv :: NameEnv a +isEmptyNameEnv :: NameEnv a -> Bool mkNameEnv :: [(Name,a)] -> NameEnv a nameEnvElts :: NameEnv a -> [a] nameEnvUniqueElts :: NameEnv a -> [(Unique, a)] @@ -93,6 +95,7 @@ disjointNameEnv :: NameEnv a -> NameEnv a -> Bool nameEnvElts x = eltsUFM x emptyNameEnv = emptyUFM +isEmptyNameEnv = isNullUFM unitNameEnv x y = unitUFM x y extendNameEnv x y z = addToUFM x y z extendNameEnvList x l = addListToUFM x l diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index e2997096aa..9f162d5b1c 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -56,7 +56,6 @@ module OccName ( mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkBuilderOcc, mkDefaultMethodOcc, - mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, @@ -94,6 +93,7 @@ module OccName ( extendOccSetList, unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, + filterOccSet, -- * Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, @@ -449,6 +449,7 @@ foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b isEmptyOccSet :: OccSet -> Bool intersectOccSet :: OccSet -> OccSet -> OccSet intersectsOccSet :: OccSet -> OccSet -> Bool +filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet emptyOccSet = emptyUniqSet unitOccSet = unitUniqSet @@ -464,6 +465,7 @@ foldOccSet = foldUniqSet isEmptyOccSet = isEmptyUniqSet intersectOccSet = intersectUniqSets intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +filterOccSet = filterUniqSet {- ************************************************************************ @@ -582,7 +584,7 @@ isDerivedOccName occ = mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkBuilderOcc, mkDefaultMethodOcc, - mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, + mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenR, mkGen1R, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, @@ -597,7 +599,6 @@ mkWorkerOcc = mk_simple_deriv varName "$w" mkMatcherOcc = mk_simple_deriv varName "$m" mkBuilderOcc = mk_simple_deriv varName "$b" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies as a tycon/datacon mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 01e52afa5c..b7aff18534 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -25,7 +25,7 @@ module PatSyn ( #include "HsVersions.h" import Type -import TcType( mkSigmaTy ) +import TcType( mkInvSigmaTy ) import Name import Outputable import Unique @@ -80,14 +80,16 @@ data PatSyn -- Matcher function. -- If Bool is True then prov_theta and arg_tys are empty -- and type is - -- forall (r :: ?) univ_tvs. req_theta + -- forall (v :: Levity) (r :: TYPE v) univ_tvs. + -- req_theta -- => res_ty -- -> (forall ex_tvs. Void# -> r) -- -> (Void# -> r) -- -> r -- -- Otherwise type is - -- forall (r :: ?) univ_tvs. req_theta + -- forall (v :: Levity) (r :: TYPE v) univ_tvs. + -- req_theta -- => res_ty -- -> (forall ex_tvs. prov_theta => arg_tys -> r) -- -> (Void# -> r) @@ -326,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 }) - = mkSigmaTy univ_tvs req_theta $ - mkSigmaTy ex_tvs prov_theta $ + = mkInvSigmaTy univ_tvs req_theta $ + mkInvSigmaTy ex_tvs prov_theta $ mkFunTys orig_args orig_res_ty -- | Should the 'PatSyn' be presented infix? diff --git a/compiler/basicTypes/PatSyn.hs-boot b/compiler/basicTypes/PatSyn.hs-boot index 0ac4b7a625..07f24a5ba0 100644 --- a/compiler/basicTypes/PatSyn.hs-boot +++ b/compiler/basicTypes/PatSyn.hs-boot @@ -5,7 +5,7 @@ import Data.Data ( Data ) import Outputable ( Outputable, OutputableBndr ) import Unique ( Uniquable ) import BasicTypes (Arity) -import {-# SOURCE #-} TypeRep (Type) +import {-# SOURCE #-} TyCoRep (Type) import Var (TyVar) import Name (Name) diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 7733aee3e1..e171e702be 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -45,6 +45,7 @@ module SrcLoc ( interactiveSrcSpan, srcLocSpan, realSrcLocSpan, combineSrcSpans, + srcSpanFirstCharacter, -- ** Deconstructing SrcSpan srcSpanStart, srcSpanEnd, @@ -342,6 +343,13 @@ combineRealSrcSpans span1 span2 (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 +-- | Convert a SrcSpan into one that represents only its first character +srcSpanFirstCharacter :: SrcSpan -> SrcSpan +srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 + where + loc1@(SrcLoc f l c) = realSrcSpanStart span + loc2 = SrcLoc f l (c+1) {- ************************************************************************ * * diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index 5705c6fbaf..c9c2240490 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -23,7 +23,7 @@ module Unique ( Unique, Uniquable(..), -- ** Constructors, desctructors and operations on 'Unique's - hasKey, + hasKey, cmpByUnique, pprUnique, @@ -46,7 +46,7 @@ module Unique ( mkCTupleTyConUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, - mkPArrDataConUnique, + mkPArrDataConUnique, mkCoVarUnique, mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, @@ -168,6 +168,9 @@ instance Uniquable FastString where instance Uniquable Int where getUnique i = mkUniqueGrimily i +cmpByUnique :: Uniquable a => a -> a -> Ordering +cmpByUnique x y = (getUnique x) `cmpUnique` (getUnique y) + {- ************************************************************************ * * @@ -307,8 +310,10 @@ mkTupleDataConUnique :: Boxity -> Arity -> Unique mkPrimOpIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique mkPArrDataConUnique :: Int -> Unique +mkCoVarUnique :: Int -> Unique mkAlphaTyVarUnique i = mkUnique '1' i +mkCoVarUnique i = mkUnique 'g' i mkPreludeClassUnique i = mkUnique '2' i -------------------------------------------------- diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index 87658b542e..f57111fc40 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -5,7 +5,8 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf #-} + -- | -- #name_types# -- GHC uses several kinds of name internally: @@ -19,8 +20,8 @@ -- * 'Id.Id': see "Id#name_types" -- -- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally --- potentially contain type variables, which have a 'TypeRep.Kind' --- rather than a 'TypeRep.Type' and only contain some extra +-- potentially contain type variables, which have a 'TyCoRep.Kind' +-- rather than a 'TyCoRep.Type' and only contain some extra -- details during typechecking. -- -- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" @@ -34,13 +35,14 @@ module Var ( -- * The main data type and synonyms Var, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId, - TyVar, TypeVar, KindVar, TKVar, + TyVar, TypeVar, KindVar, TKVar, TyCoVar, -- ** Taking 'Var's apart varName, varUnique, varType, -- ** Modifying 'Var's - setVarName, setVarUnique, setVarType, + setVarName, setVarUnique, setVarType, updateVarType, + updateVarTypeM, -- ** Constructing, taking apart, modifying 'Id's mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, @@ -50,12 +52,12 @@ module Var ( -- ** Predicates isId, isTKVar, isTyVar, isTcTyVar, - isLocalVar, isLocalId, + isLocalVar, isLocalId, isCoVar, isTyCoVar, isGlobalId, isExportedId, mustHaveLocalBinding, -- ** Constructing 'TyVar's - mkTyVar, mkTcTyVar, mkKindVar, + mkTyVar, mkTcTyVar, -- ** Taking 'TyVar's apart tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, @@ -68,13 +70,14 @@ module Var ( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep( Type, Kind, SuperKind ) -import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails ) +import {-# SOURCE #-} TyCoRep( Type, Kind ) +import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) +import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails ) import Name hiding (varName) import Unique import Util +import DynFlags import FastString import Outputable @@ -109,16 +112,13 @@ type EqVar = EvId -- Boxed equality evidence type CoVar = Id -- See Note [Evidence: EvIds and CoVars] +type TyCoVar = Id -- Type, kind, *or* coercion variable + {- Note [Evidence: EvIds and CoVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* An EvId (evidence Id) is a *boxed*, term-level evidence variable - (dictionary, implicit parameter, or equality). - -* A CoVar (coercion variable) is an *unboxed* term-level evidence variable - of type (t1 ~# t2). So it's the unboxed version of an EqVar. - -* Only CoVars can occur in Coercions, EqVars appear in TcCoercions. +* An EvId (evidence Id) is a term-level evidence variable + (dictionary, implicit parameter, or equality). Could be boxed or unboxed. * DictId, IpId, and EqVar are synonyms when we know what kind of evidence we are talking about. For example, an EqVar has type (t1 ~ t2). @@ -166,7 +166,8 @@ data Var varName :: !Name, realUnique :: {-# UNPACK #-} !Int, varType :: Kind, - tc_tv_details :: TcTyVarDetails } + tc_tv_details :: TcTyVarDetails + } | Id { varName :: !Name, @@ -225,7 +226,13 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds -} instance Outputable Var where - ppr var = ppr (varName var) <> getPprStyle (ppr_debug var) + ppr var = sdocWithDynFlags $ \dflags -> + getPprStyle $ \ppr_style -> + if | debugStyle ppr_style && (not (gopt Opt_SuppressVarKinds dflags)) + -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> + dcolon <+> ppr (tyVarKind var)) + | otherwise + -> ppr (varName var) <> ppr_debug var ppr_style ppr_debug :: Var -> PprStyle -> SDoc ppr_debug (TyVar {}) sty @@ -279,6 +286,13 @@ setVarName var new_name setVarType :: Id -> Type -> Id setVarType id ty = id { varType = ty } +updateVarType :: (Type -> Type) -> Id -> Id +updateVarType f id = id { varType = f (varType id) } + +updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id +updateVarTypeM f id = do { ty' <- f (varType id) + ; return (id { varType = ty' }) } + {- ************************************************************************ * * @@ -314,7 +328,7 @@ mkTyVar :: Name -> Kind -> TyVar mkTyVar name kind = TyVar { varName = name , realUnique = getKey (nameUnique name) , varType = kind - } + } mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar mkTcTyVar name kind details @@ -327,22 +341,15 @@ mkTcTyVar name kind details tcTyVarDetails :: TyVar -> TcTyVarDetails tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details -tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var) +tcTyVarDetails (TyVar {}) = vanillaSkolemTv +tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> ppr (tyVarKind var)) setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar setTcTyVarDetails tv details = tv { tc_tv_details = details } -mkKindVar :: Name -> SuperKind -> KindVar --- mkKindVar take a SuperKind as argument because we don't have access --- to superKind here. -mkKindVar name kind = TyVar - { varName = name - , realUnique = getKey (nameUnique name) - , varType = kind } - {- -************************************************************************ -* * +%************************************************************************ +%* * \subsection{Ids} * * ************************************************************************ @@ -431,6 +438,12 @@ isId :: Var -> Bool isId (Id {}) = True isId _ = False +isTyCoVar :: Var -> Bool +isTyCoVar v = isTyVar v || isCoVar v + +isCoVar :: Var -> Bool +isCoVar v = isId v && isCoVarDetails (id_details v) + isLocalId :: Var -> Bool isLocalId (Id { idScope = LocalId _ }) = True isLocalId _ = False diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index 8051721f33..bdc451a2b4 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -5,19 +5,20 @@ module VarEnv ( -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, CoVarEnv, + VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, -- ** Manipulating these environments - emptyVarEnv, unitVarEnv, mkVarEnv, - elemVarEnv, varEnvElts, varEnvKeys, - extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, + emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, + elemVarEnv, varEnvElts, varEnvKeys, varEnvToList, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, + extendVarEnvList, plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv, - delVarEnvList, delVarEnv, + delVarEnvList, delVarEnv, delVarEnv_Directly, minusVarEnv, intersectsVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, foldVarEnv, + isEmptyVarEnv, foldVarEnv, foldVarEnv_Directly, elemVarEnvByKey, lookupVarEnv_Directly, filterVarEnv, filterVarEnv_Directly, restrictVarEnv, partitionVarEnv, @@ -44,13 +45,14 @@ module VarEnv ( RnEnv2, -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, + mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, delBndrL, delBndrR, delBndrsL, delBndrsR, addRnInScopeSet, rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, + rnEnvL, rnEnvR, -- * TidyEnv and its operation TidyEnv, @@ -224,6 +226,14 @@ rnInScope x env = x `elemInScopeSet` in_scope env rnInScopeSet :: RnEnv2 -> InScopeSet rnInScopeSet = in_scope +-- | Retrieve the left mapping +rnEnvL :: RnEnv2 -> VarEnv Var +rnEnvL = envL + +-- | Retrieve the right mapping +rnEnvR :: RnEnv2 -> VarEnv Var +rnEnvR = envR + rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 -- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR @@ -233,10 +243,15 @@ rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 -- and binder @bR@ in the Right term. -- It finds a new binder, @new_b@, -- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ -rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR - = RV2 { envL = extendVarEnv envL bL new_b -- See Note - , envR = extendVarEnv envR bR new_b -- [Rebinding] - , in_scope = extendInScopeSet in_scope new_b } +rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR + +rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but returns the new variable as well as the +-- new environment +rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = (RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b }, new_b) where -- Find a new binder not in scope in either term new_b | not (bL `elemInScopeSet` in_scope) = bL @@ -326,6 +341,11 @@ nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 nukeRnEnvL env = env { envL = emptyVarEnv } nukeRnEnvR env = env { envR = emptyVarEnv } +rnSwap :: RnEnv2 -> RnEnv2 +-- ^ swap the meaning of left and right +rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) + = RV2 { envL = envR, envR = envL, in_scope = in_scope } + {- Note [Eta expansion] ~~~~~~~~~~~~~~~~~~~~ @@ -364,24 +384,28 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) ************************************************************************ -} -type VarEnv elt = UniqFM elt -type IdEnv elt = VarEnv elt -type TyVarEnv elt = VarEnv elt -type CoVarEnv elt = VarEnv elt +type VarEnv elt = UniqFM elt +type IdEnv elt = VarEnv elt +type TyVarEnv elt = VarEnv elt +type TyCoVarEnv elt = VarEnv elt +type CoVarEnv elt = VarEnv elt emptyVarEnv :: VarEnv a mkVarEnv :: [(Var, a)] -> VarEnv a +mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a zipVarEnv :: [Var] -> [a] -> VarEnv a unitVarEnv :: Var -> a -> VarEnv a alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b +extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a @@ -394,6 +418,7 @@ mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a varEnvElts :: VarEnv a -> [a] varEnvKeys :: VarEnv a -> [Unique] +varEnvToList :: VarEnv a -> [(Unique, a)] isEmptyVarEnv :: VarEnv a -> Bool lookupVarEnv :: VarEnv a -> Var -> Maybe a @@ -403,6 +428,7 @@ lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a elemVarEnv :: Var -> VarEnv a -> Bool elemVarEnvByKey :: Unique -> VarEnv a -> Bool foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b +foldVarEnv_Directly :: (Unique -> a -> b -> b) -> b -> VarEnv a -> b elemVarEnv = elemUFM elemVarEnvByKey = elemUFM_Directly @@ -410,6 +436,7 @@ alterVarEnv = alterUFM extendVarEnv = addToUFM extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc +extendVarEnv_Directly = addToUFM_Directly extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C plusVarEnv_CD = plusUFM_CD @@ -423,14 +450,18 @@ filterVarEnv = filterUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM +mkVarEnv_Directly= listToUFM_Directly emptyVarEnv = emptyUFM varEnvElts = eltsUFM varEnvKeys = keysUFM +varEnvToList = ufmToList unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM foldVarEnv = foldUFM +foldVarEnv_Directly = foldUFM_Directly lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv_Directly = filterUFM_Directly +delVarEnv_Directly = delFromUFM_Directly partitionVarEnv = partitionUFM restrictVarEnv env vs = filterVarEnv_Directly keep env diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs index ce6aea68ab..7966139d8c 100644 --- a/compiler/basicTypes/VarSet.hs +++ b/compiler/basicTypes/VarSet.hs @@ -7,7 +7,7 @@ module VarSet ( -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, CoVarSet, + VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, -- ** Manipulating these sets emptyVarSet, unitVarSet, mkVarSet, @@ -18,11 +18,12 @@ module VarSet ( isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, minusVarSet, foldVarSet, filterVarSet, transCloVarSet, fixVarSet, - lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, + lookupVarSet, lookupVarSetByName, + mapVarSet, sizeVarSet, seqVarSet, elemVarSetByKey, partitionVarSet, -- * Deterministic Var set types - DVarSet, DIdSet, DTyVarSet, + DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, -- ** Manipulating these sets emptyDVarSet, unitDVarSet, mkDVarSet, @@ -39,8 +40,9 @@ module VarSet ( #include "HsVersions.h" -import Var ( Var, TyVar, CoVar, Id ) +import Var ( Var, TyVar, CoVar, TyCoVar, Id ) import Unique +import Name ( Name ) import UniqSet import UniqDSet import UniqFM( disjointUFM ) @@ -55,6 +57,7 @@ type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar type CoVarSet = UniqSet CoVar +type TyCoVarSet = UniqSet TyCoVar emptyVarSet :: VarSet intersectVarSet :: VarSet -> VarSet -> VarSet @@ -78,6 +81,7 @@ foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a lookupVarSet :: VarSet -> Var -> Maybe Var -- Returns the set element, which may be -- (==) to the argument, but not the same as +lookupVarSetByName :: VarSet -> Name -> Maybe Var mapVarSet :: (Var -> Var) -> VarSet -> VarSet sizeVarSet :: VarSet -> Int filterVarSet :: (Var -> Bool) -> VarSet -> VarSet @@ -110,6 +114,7 @@ isEmptyVarSet = isEmptyUniqSet mkVarSet = mkUniqSet foldVarSet = foldUniqSet lookupVarSet = lookupUniqSet +lookupVarSetByName = lookupUniqSet mapVarSet = mapUniqSet sizeVarSet = sizeUniqSet filterVarSet = filterUniqSet @@ -168,9 +173,10 @@ seqVarSet s = sizeVarSet s `seq` () -- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need -- DVarSet. -type DVarSet = UniqDSet Var -type DIdSet = UniqDSet Id -type DTyVarSet = UniqDSet TyVar +type DVarSet = UniqDSet Var +type DIdSet = UniqDSet Id +type DTyVarSet = UniqDSet TyVar +type DTyCoVarSet = UniqDSet TyCoVar emptyDVarSet :: DVarSet emptyDVarSet = emptyUniqDSet diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index d0564e6f68..ea9fe934a6 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -16,12 +16,12 @@ module Cmm ( -- * Cmm graphs CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite, - + -- * Info Tables CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable, - ClosureTypeInfo(..), + ClosureTypeInfo(..), C_SRT(..), needsSRT, - ProfilingInfo(..), ConstrDescription, + ProfilingInfo(..), ConstrDescription, -- * Statements, expressions and types module CmmNode, @@ -45,8 +45,8 @@ import Data.Word ( Word8 ) -- Cmm, GenCmm ----------------------------------------------------------------------------- --- A CmmProgram is a list of CmmGroups --- A CmmGroup is a list of top-level declarations +-- A CmmProgram is a list of CmmGroups +-- A CmmGroup is a list of top-level declarations -- When object-splitting is on, each group is compiled into a separate -- .o file. So typically we put closely related stuff in a CmmGroup. @@ -150,7 +150,7 @@ data ProfilingInfo = NoProfilingInfo | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc --- C_SRT is what StgSyn.SRT gets translated to... +-- C_SRT is what StgSyn.SRT gets translated to... -- we add a label for the table, and expect only the 'offset/length' form data C_SRT = NoC_SRT diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 8a86bb46f6..4b3897fce4 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -430,10 +430,10 @@ data GlobalReg | XmmReg -- 128-bit SIMD vector register {-# UNPACK #-} !Int -- its number - | YmmReg -- 256-bit SIMD vector register + | YmmReg -- 256-bit SIMD vector register {-# UNPACK #-} !Int -- its number - | ZmmReg -- 512-bit SIMD vector register + | ZmmReg -- 512-bit SIMD vector register {-# UNPACK #-} !Int -- its number -- STG registers diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 2c332a524d..53cfd11b3c 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -851,17 +851,17 @@ areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n) -- Replace (CmmStackSlot area n) with an offset from Sp -areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) +areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr dflags sp_hwm - -- Replace CmmHighStackMark with the number of bytes of stack used, + -- Replace CmmHighStackMark with the number of bytes of stack used, -- the sp_hwm. See Note [Stack usage] in StgCmmHeap -areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) +areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) [CmmMachOp (MO_Sub _) [ CmmRegOff (CmmGlobal Sp) x_off , CmmLit (CmmInt y_lit _)], CmmReg (CmmGlobal SpLim)]) - | fromIntegral x_off >= y_lit + | fromIntegral x_off >= y_lit = zeroExpr dflags -- Replace a stack-overflow test that cannot fail with a no-op -- See Note [Always false stack check] diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs index beaf6bcec8..1e3adf4726 100644 --- a/compiler/cmm/Hoopl/Dataflow.hs +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -131,7 +131,7 @@ arfGraph pass@FwdPass { fp_lattice = lattice, fp_transfer = transfer, fp_rewrite = rewrite } entries g in_fact = graph g in_fact where - {- nested type synonyms would be so lovely here + {- nested type synonyms would be so lovely here type ARF thing = forall e x . thing e x -> f -> m (DG f n e x, Fact x f) type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f) -} @@ -190,7 +190,7 @@ arfGraph pass@FwdPass { fp_lattice = lattice, -- | Compose fact transformers and concatenate the resulting -- rewritten graphs. - {-# INLINE cat #-} + {-# INLINE cat #-} cat ft1 ft2 f = do { (g1,f1) <- ft1 f ; (g2,f2) <- ft2 f1 ; let !g = g1 `dgSplice` g2 @@ -199,7 +199,7 @@ arfGraph pass@FwdPass { fp_lattice = lattice, arfx :: forall x . (Block n C x -> f -> UniqSM (DG f n C x, Fact x f)) -> (Block n C x -> Fact C f -> UniqSM (DG f n C x, Fact x f)) - arfx arf thing fb = + arfx arf thing fb = arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb -- joinInFacts adds debugging information @@ -398,14 +398,14 @@ arbGraph pass@BwdPass { bp_lattice = lattice, bp_transfer = transfer, bp_rewrite = rewrite } entries g in_fact = graph g in_fact where - {- nested type synonyms would be so lovely here + {- nested type synonyms would be so lovely here type ARB thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f) type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f) -} graph :: Graph n e x -> Fact x f -> UniqSM (DG f n e x, Fact e f) block :: forall e x . Block n e x -> Fact x f -> UniqSM (DG f n e x, f) body :: [Label] -> Body n -> Fact C f -> UniqSM (DG f n C C, Fact C f) - node :: forall e x . (ShapeLifter e x) + node :: forall e x . (ShapeLifter e x) => n e x -> Fact x f -> UniqSM (DG f n e x, f) cat :: forall e a x info info' info''. (info' -> UniqSM (DG f n e a, info'')) @@ -450,7 +450,7 @@ arbGraph pass@BwdPass { bp_lattice = lattice, -- | Compose fact transformers and concatenate the resulting -- rewritten graphs. - {-# INLINE cat #-} + {-# INLINE cat #-} cat ft1 ft2 f = do { (g2,f2) <- ft2 f ; (g1,f1) <- ft1 f2 ; let !g = g1 `dgSplice` g2 @@ -591,7 +591,7 @@ fixpoint direction DataflowLattice{ fact_bot = _, fact_join = join } let newblocks' = case rg of GMany _ blks _ -> mapUnion blks newblocks - + loop todo' fbase' newblocks' @@ -633,7 +633,7 @@ iteration. Note [Unreachable blocks] ~~~~~~~~~~~~~~~~~~~~~~~~~ A block that is not in the domain of tfb_fbase is "currently unreachable". -A currently-unreachable block is not even analyzed. Reason: consider +A currently-unreachable block is not even analyzed. Reason: consider constant prop and this graph, with entry point L1: L1: x:=3; goto L4 L2: x:=4; goto L4 @@ -849,7 +849,7 @@ getFact lat l fb = case lookupFact l fb of Just f -> f ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -} -- $fuel --- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if +-- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if -- any function contained within the value satisfies the following properties: -- -- * When fuel is exhausted, it always returns 'Nothing'. @@ -857,7 +857,7 @@ getFact lat l fb = case lookupFact l fb of Just f -> f -- * When it returns @Just g rw@, it consumes /exactly/ one unit -- of fuel, and new rewrite 'rw' also respects fuel. -- --- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', +-- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', -- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply, -- the results respect fuel. -- diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index f5a722ebb6..d10903d78f 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -77,7 +77,7 @@ import DataCon import FastString import Name import Type -import TypeRep +import TyCoRep import TcType import TyCon import BasicTypes @@ -957,16 +957,18 @@ getTyDescription :: Type -> String getTyDescription ty = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon - ForAllTy _ ty -> getTyDescription ty + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + TyConApp tycon _ -> getOccString tycon + ForAllTy (Anon _) res -> '-' : '>' : fun_result res + ForAllTy (Named {}) 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 (ForAllTy (Anon _) res) = '>' : fun_result res + fun_result other = getTyDescription other getTyLitDescription :: TyLit -> String getTyLitDescription l = diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 03c11cc19b..b46ab5ae14 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -17,7 +17,7 @@ module StgCmmLayout ( slowCall, directCall, - mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, + mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep ) where diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index 30bc962ec2..e832f54437 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -106,11 +106,10 @@ typeArity ty = go initRecTc ty where go rec_nts ty - | Just (_, ty') <- splitForAllTy_maybe ty - = go rec_nts ty' - - | Just (arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res + | Just (bndr, ty') <- splitPiTy_maybe ty + = if isIdLikeBinder bndr + then typeOneShot (binderType bndr) : go rec_nts ty' + else go rec_nts ty' | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys @@ -771,11 +770,11 @@ arityType env (Tick t e) arityType _ _ = vanillaArityType {- -************************************************************************ -* * +%************************************************************************ +%* * The main eta-expander -* * -************************************************************************ +%* * +%************************************************************************ We go for: f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym @@ -964,21 +963,19 @@ mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type mkEtaWW orig_n orig_expr in_scope orig_ty = go orig_n empty_subst orig_ty [] where - empty_subst = TvSubst in_scope emptyTvSubstEnv + empty_subst = mkEmptyTCvSubst in_scope go n subst ty eis -- See Note [exprArity invariant] | n == 0 - = (getTvInScope subst, reverse eis) - - | Just (tv,ty') <- splitForAllTy_maybe ty - , let (subst', tv') = Type.substTyVarBndr subst tv - -- Avoid free vars of the original expression - = go n subst' ty' (EtaVar tv' : eis) + = (getTCvInScope subst, reverse eis) - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , let (subst', eta_id') = freshEtaId n subst arg_ty - -- Avoid free vars of the original expression - = go (n-1) subst' res_ty (EtaVar eta_id' : eis) + | Just (bndr,ty') <- splitPiTy_maybe ty + = let ((subst', eta_id'), new_n) = caseBinder bndr + (\tv -> (Type.substTyVarBndr subst tv, n)) + (\arg_ty -> (freshEtaVar n subst arg_ty, n-1)) + in + -- Avoid free vars of the original expression + go new_n subst' ty' (EtaVar eta_id' : eis) | Just (co, ty') <- topNormaliseNewType_maybe ty = -- Given this: @@ -992,7 +989,7 @@ mkEtaWW orig_n orig_expr in_scope orig_ty | otherwise -- We have an expression of arity > 0, -- but its type isn't a function. = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) - (getTvInScope subst, reverse eis) + (getTCvInScope subst, reverse eis) -- This *can* legitmately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is -- playing fast and loose with types (Happy does this a lot). @@ -1011,7 +1008,7 @@ subst_bind = substBindSC -------------- -freshEtaId :: Int -> TvSubst -> Type -> (TvSubst, Id) +freshEtaVar :: Int -> TCvSubst -> Type -> (TCvSubst, Var) -- Make a fresh Id, with specified type (after applying substitution) -- It should be "fresh" in the sense that it's not in the in-scope set -- of the TvSubstEnv; and it should itself then be added to the in-scope @@ -1019,10 +1016,10 @@ freshEtaId :: Int -> TvSubst -> Type -> (TvSubst, Id) -- -- The Int is just a reasonable starting point for generating a unique; -- it does not necessarily have to be unique itself. -freshEtaId n subst ty +freshEtaVar n subst ty = (subst', eta_id') where ty' = Type.substTy subst ty - eta_id' = uniqAway (getTvInScope subst) $ - mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty' - subst' = extendTvInScope subst eta_id' + eta_id' = uniqAway (getTCvInScope subst) $ + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' + subst' = extendTCvInScope subst eta_id' diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 398f6bee39..bf5d773a66 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -22,9 +22,10 @@ module CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars, -- * Free variables of Rules, Vars and Ids - varTypeTyVars, - varTypeTyVarsAcc, - idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, + varTypeTyCoVars, + varTypeTyCoVarsAcc, + idUnfoldingVars, idFreeVars, dIdFreeVars, + idRuleAndUnfoldingVars, idRuleAndUnfoldingVarsDSet, idFreeVarsAcc, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, @@ -35,10 +36,16 @@ module CoreFVs ( expr_fvs, -- * Core syntax tree annotation with free variables - CoreExprWithFVs, -- = AnnExpr Id DVarSet - CoreBindWithFVs, -- = AnnBind Id DVarSet + FVAnn, -- annotation, abstract + CoreExprWithFVs, -- = AnnExpr Id FVAnn + CoreExprWithFVs', -- = AnnExpr' Id FVAnn + CoreBindWithFVs, -- = AnnBind Id FVAnn + CoreAltWithFVs, -- = AnnAlt Id FVAnn freeVars, -- CoreExpr -> CoreExprWithFVs - freeVarsOf -- CoreExprWithFVs -> DIdSet + freeVarsOf, -- CoreExprWithFVs -> DIdSet + freeVarsOfType, -- CoreExprWithFVs -> TyCoVarSet + freeVarsOfAnn, freeVarsOfTypeAnn, + exprTypeFV -- CoreExprWithFVs -> Type ) where #include "HsVersions.h" @@ -48,10 +55,12 @@ import Id import IdInfo import NameSet import UniqFM +import Literal ( literalType ) import Name import VarSet import Var import TcType +import Type import Coercion import Maybes( orElse ) import Util @@ -161,7 +170,7 @@ exprsSomeFreeVars fv_cand es = addBndr :: CoreBndr -> FV -> FV addBndr bndr fv fv_cand in_scope acc - = (varTypeTyVarsAcc bndr `unionFV` + = (varTypeTyCoVarsAcc bndr `unionFV` -- Include type varibles in the binder's type -- (not just Ids; coercion variables too!) FV.delFV bndr fv) fv_cand in_scope acc @@ -171,7 +180,7 @@ addBndrs bndrs fv = foldr addBndr fv bndrs expr_fvs :: CoreExpr -> FV expr_fvs (Type ty) fv_cand in_scope acc = - tyVarsOfTypeAcc ty fv_cand in_scope acc + tyCoVarsOfTypeAcc ty fv_cand in_scope acc expr_fvs (Coercion co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc expr_fvs (Var var) fv_cand in_scope acc = oneVar var fv_cand in_scope acc @@ -186,7 +195,7 @@ expr_fvs (Cast expr co) fv_cand in_scope acc = (expr_fvs expr `unionFV` tyCoVarsOfCoAcc co) fv_cand in_scope acc expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc - = (expr_fvs scrut `unionFV` tyVarsOfTypeAcc ty `unionFV` addBndr bndr + = (expr_fvs scrut `unionFV` tyCoVarsOfTypeAcc ty `unionFV` addBndr bndr (mapUnionFV alt_fvs alts)) fv_cand in_scope acc where alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) @@ -353,16 +362,42 @@ The free variable pass annotates every node in the expression with its NON-GLOBAL free variables and type variables. -} +data FVAnn = FVAnn { fva_fvs :: DVarSet -- free in expression + , fva_ty_fvs :: DVarSet -- free only in expression's type + , fva_ty :: Type -- expression's type + } + -- | Every node in a binding group annotated with its --- (non-global) free variables, both Ids and TyVars -type CoreBindWithFVs = AnnBind Id DVarSet +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreBindWithFVs = AnnBind Id FVAnn +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreExprWithFVs = AnnExpr Id FVAnn +type CoreExprWithFVs' = AnnExpr' Id FVAnn + -- | Every node in an expression annotated with its --- (non-global) free variables, both Ids and TyVars -type CoreExprWithFVs = AnnExpr Id DVarSet +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreAltWithFVs = AnnAlt Id FVAnn freeVarsOf :: CoreExprWithFVs -> DIdSet -- ^ Inverse function to 'freeVars' -freeVarsOf (free_vars, _) = free_vars +freeVarsOf (FVAnn { fva_fvs = fvs }, _) = fvs + +-- | Extract the vars free in an annotated expression's type +freeVarsOfType :: CoreExprWithFVs -> DTyCoVarSet +freeVarsOfType (FVAnn { fva_ty_fvs = ty_fvs }, _) = ty_fvs + +-- | Extract the type of an annotated expression. (This is cheap.) +exprTypeFV :: CoreExprWithFVs -> Type +exprTypeFV (FVAnn { fva_ty = ty }, _) = ty + +-- | Extract the vars reported in a FVAnn +freeVarsOfAnn :: FVAnn -> DIdSet +freeVarsOfAnn = fva_fvs + +-- | Extract the type-level vars reported in a FVAnn +freeVarsOfTypeAnn :: FVAnn -> DTyCoVarSet +freeVarsOfTypeAnn = fva_ty_fvs noFVs :: VarSet noFVs = emptyVarSet @@ -373,6 +408,9 @@ aFreeVar = unitDVarSet unionFVs :: DVarSet -> DVarSet -> DVarSet unionFVs = unionDVarSet +unionFVss :: [DVarSet] -> DVarSet +unionFVss = unionDVarSets + delBindersFV :: [Var] -> DVarSet -> DVarSet delBindersFV bs fvs = foldr delBinderFV fvs bs @@ -407,27 +445,30 @@ delBinderFV :: Var -> DVarSet -> DVarSet -- where -- bottom = bottom -- Never evaluated -delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyVars b +delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b -- Include coercion variables too! -varTypeTyVars :: Var -> TyVarSet +varTypeTyCoVars :: Var -> TyCoVarSet -- Find the type/kind variables free in the type of the id/tyvar -varTypeTyVars var = runFVSet $ varTypeTyVarsAcc var +varTypeTyCoVars var = runFVSet $ varTypeTyCoVarsAcc var -dVarTypeTyVars :: Var -> DTyVarSet --- Find the type/kind variables free in the type of the id/tyvar -dVarTypeTyVars var = runFVDSet $ varTypeTyVarsAcc var +dVarTypeTyCoVars :: Var -> DTyCoVarSet +-- Find the type/kind/coercion variables free in the type of the id/tyvar +dVarTypeTyCoVars var = runFVDSet $ varTypeTyCoVarsAcc var -varTypeTyVarsAcc :: Var -> FV -varTypeTyVarsAcc var = tyVarsOfTypeAcc (varType var) +varTypeTyCoVarsAcc :: Var -> FV +varTypeTyCoVarsAcc var = tyCoVarsOfTypeAcc (varType var) idFreeVars :: Id -> VarSet idFreeVars id = ASSERT( isId id) runFVSet $ idFreeVarsAcc id +dIdFreeVars :: Id -> DVarSet +dIdFreeVars id = runFVDSet $ idFreeVarsAcc id + idFreeVarsAcc :: Id -> FV -- Type variables, rule variables, and inline variables idFreeVarsAcc id = ASSERT( isId id) - varTypeTyVarsAcc id `unionFV` + varTypeTyCoVarsAcc id `unionFV` idRuleAndUnfoldingVarsAcc id bndrRuleAndUnfoldingVarsAcc :: Var -> FV @@ -437,6 +478,9 @@ bndrRuleAndUnfoldingVarsAcc v | isTyVar v = noVars idRuleAndUnfoldingVars :: Id -> VarSet idRuleAndUnfoldingVars id = runFVSet $ idRuleAndUnfoldingVarsAcc id +idRuleAndUnfoldingVarsDSet :: Id -> DVarSet +idRuleAndUnfoldingVarsDSet id = runFVDSet $ idRuleAndUnfoldingVarsAcc id + idRuleAndUnfoldingVarsAcc :: Id -> FV idRuleAndUnfoldingVarsAcc id = ASSERT( isId id) idRuleVarsAcc id `unionFV` idUnfoldingVarsAcc id @@ -485,83 +529,127 @@ stableUnfoldingVarsAcc unf freeVars :: CoreExpr -> CoreExprWithFVs -- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node -freeVars (Var v) - = (fvs, AnnVar v) - where - -- ToDo: insert motivating example for why we *need* - -- to include the idSpecVars in the FV list. - -- Actually [June 98] I don't think it's necessary - -- fvs = fvs_v `unionVarSet` idSpecVars v - - fvs | isLocalVar v = aFreeVar v - | otherwise = emptyDVarSet - -freeVars (Lit lit) = (emptyDVarSet, AnnLit lit) -freeVars (Lam b body) - = (b `delBinderFV` freeVarsOf body', AnnLam b body') - where - body' = freeVars body - -freeVars (App fun arg) - = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2) - where - fun2 = freeVars fun - arg2 = freeVars arg - -freeVars (Case scrut bndr ty alts) - = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` runFVDSet (tyVarsOfTypeAcc ty), - AnnCase scrut2 bndr ty alts2) +freeVars = go where - scrut2 = freeVars scrut - - (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts - alts_fvs = foldr unionFVs emptyDVarSet alts_fvs_s - - fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), - (con, args, rhs2)) - where - rhs2 = freeVars rhs - -freeVars (Let (NonRec binder rhs) body) - = (freeVarsOf rhs2 - `unionFVs` body_fvs - `unionFVs` runFVDSet (bndrRuleAndUnfoldingVarsAcc binder), - -- Remember any rules; cf rhs_fvs above - AnnLet (AnnNonRec binder rhs2) body2) - where - rhs2 = freeVars rhs - body2 = freeVars body - body_fvs = binder `delBinderFV` freeVarsOf body2 - -freeVars (Let (Rec binds) body) - = (delBindersFV binders all_fvs, - AnnLet (AnnRec (binders `zip` rhss2)) body2) - where - (binders, rhss) = unzip binds - - rhss2 = map freeVars rhss - rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 - binders_fvs = runFVDSet $ mapUnionFV idRuleAndUnfoldingVarsAcc binders - all_fvs = rhs_body_fvs `unionFVs` binders_fvs - -- The "delBinderFV" happens after adding the idSpecVars, - -- since the latter may add some of the binders as fvs - - body2 = freeVars body - body_fvs = freeVarsOf body2 + go :: CoreExpr -> CoreExprWithFVs + go (Var v) + = (FVAnn fvs ty_fvs (idType v), AnnVar v) + where + -- ToDo: insert motivating example for why we *need* + -- to include the idSpecVars in the FV list. + -- Actually [June 98] I don't think it's necessary + -- fvs = fvs_v `unionVarSet` idSpecVars v + + (fvs, ty_fvs) + | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, dVarTypeTyCoVars v) + | otherwise = (emptyDVarSet, emptyDVarSet) + + go (Lit lit) = (FVAnn emptyDVarSet emptyDVarSet (literalType lit), AnnLit lit) + go (Lam b body) + = ( FVAnn { fva_fvs = b_fvs `unionFVs` (b `delBinderFV` body_fvs) + , fva_ty_fvs = b_fvs `unionFVs` (b `delBinderFV` body_ty_fvs) + , fva_ty = mkFunTy b_ty body_ty } + , AnnLam b body' ) + where + body'@(FVAnn { fva_fvs = body_fvs, fva_ty_fvs = body_ty_fvs + , fva_ty = body_ty }, _) = go body + b_ty = idType b + b_fvs = tyCoVarsOfTypeDSet b_ty + + go (App fun arg) + = ( FVAnn { fva_fvs = freeVarsOf fun' `unionFVs` freeVarsOf arg' + , fva_ty_fvs = tyCoVarsOfTypeDSet res_ty + , fva_ty = res_ty } + , AnnApp fun' arg' ) + where + fun' = go fun + fun_ty = exprTypeFV fun' + arg' = go arg + res_ty = applyTypeToArg fun_ty arg + + go (Case scrut bndr ty alts) + = ( FVAnn { fva_fvs = (bndr `delBinderFV` alts_fvs) + `unionFVs` freeVarsOf scrut2 + `unionFVs` tyCoVarsOfTypeDSet ty + -- don't need to look at (idType bndr) + -- b/c that's redundant with scrut + , fva_ty_fvs = tyCoVarsOfTypeDSet ty + , fva_ty = ty } + , AnnCase scrut2 bndr ty alts2 ) + where + scrut2 = go scrut + + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = unionFVss alts_fvs_s + + fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), + (con, args, rhs2)) + where + rhs2 = go rhs + + go (Let (NonRec binder rhs) body) + = ( FVAnn { fva_fvs = freeVarsOf rhs2 + `unionFVs` body_fvs + `unionFVs` runFVDSet + (bndrRuleAndUnfoldingVarsAcc binder) + -- Remember any rules; cf rhs_fvs above + , fva_ty_fvs = freeVarsOfType body2 + , fva_ty = exprTypeFV body2 } + , AnnLet (AnnNonRec binder rhs2) body2 ) + where + rhs2 = go rhs + body2 = go body + body_fvs = binder `delBinderFV` freeVarsOf body2 + + go (Let (Rec binds) body) + = ( FVAnn { fva_fvs = delBindersFV binders all_fvs + , fva_ty_fvs = freeVarsOfType body2 + , fva_ty = exprTypeFV body2 } + , AnnLet (AnnRec (binders `zip` rhss2)) body2 ) + where + (binders, rhss) = unzip binds -freeVars (Cast expr co) - = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co)) - where - expr2 = freeVars expr - cfvs = runFVDSet $ tyCoVarsOfCoAcc co + rhss2 = map go rhss + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + binders_fvs = runFVDSet $ mapUnionFV idRuleAndUnfoldingVarsAcc binders + all_fvs = rhs_body_fvs `unionFVs` binders_fvs + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs -freeVars (Tick tickish expr) - = (tickishFVs tickish `unionFVs` freeVarsOf expr2, AnnTick tickish expr2) - where - expr2 = freeVars expr - tickishFVs (Breakpoint _ ids) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + body2 = go body + body_fvs = freeVarsOf body2 -freeVars (Type ty) = (runFVDSet $ tyVarsOfTypeAcc ty, AnnType ty) + go (Cast expr co) + = ( FVAnn (freeVarsOf expr2 `unionFVs` cfvs) (tyCoVarsOfTypeDSet to_ty) to_ty + , AnnCast expr2 (c_ann, co) ) + where + expr2 = go expr + cfvs = tyCoVarsOfCoDSet co + c_ann = FVAnn cfvs (tyCoVarsOfTypeDSet co_ki) co_ki + co_ki = coercionType co + Just (_, to_ty) = splitCoercionType_maybe co_ki + + + go (Tick tickish expr) + = ( FVAnn { fva_fvs = tickishFVs tickish `unionFVs` freeVarsOf expr2 + , fva_ty_fvs = freeVarsOfType expr2 + , fva_ty = exprTypeFV expr2 } + , AnnTick tickish expr2 ) + where + expr2 = go expr + tickishFVs (Breakpoint _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet + + go (Type ty) = ( FVAnn (tyCoVarsOfTypeDSet ty) + (tyCoVarsOfTypeDSet ki) + ki + , AnnType ty) + where + ki = typeKind ty -freeVars (Coercion co) = (runFVDSet $ tyCoVarsOfCoAcc co, AnnCoercion co) + go (Coercion co) = ( FVAnn (tyCoVarsOfCoDSet co) + (tyCoVarsOfTypeDSet ki) + ki + , AnnCoercion co) + where + ki = coercionType co diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 10a93e5281..0030e3c433 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -7,7 +7,6 @@ A ``lint'' pass to check for Core correctness -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fprof-auto #-} module CoreLint ( lintCoreBindings, lintUnfolding, @@ -31,7 +30,6 @@ import Bag import Literal import DataCon import TysWiredIn -import TysPrim import TcType ( isFloatingTy ) import Var import VarEnv @@ -44,7 +42,7 @@ import Coercion import SrcLoc import Kind import Type -import TypeRep +import TyCoRep -- checks validity of types/coercions import TyCon import CoAxiom import BasicTypes @@ -78,12 +76,30 @@ This file implements the type-checking algorithm for System FC, the "official" name of the Core language. Type safety of FC is heart of the claim that executables produced by GHC do not have segmentation faults. Thus, it is useful to be able to reason about System FC independently of reading the code. -To this purpose, there is a document ghc.pdf built in docs/core-spec that +To this purpose, there is a document core-spec.pdf built in docs/core-spec that contains a formalism of the types and functions dealt with here. If you change just about anything in this file or you change other types/functions throughout the Core language (all signposted to this note), you should update that formalism. See docs/core-spec/README for more info about how to do so. +Note [check vs lint] +~~~~~~~~~~~~~~~~~~~~ +This file implements both a type checking algorithm and also general sanity +checking. For example, the "sanity checking" checks for TyConApp on the left +of an AppTy, which should never happen. These sanity checks don't really +affect any notion of type soundness. Yet, it is convenient to do the sanity +checks at the same time as the type checks. So, we use the following naming +convention: + +- Functions that begin with 'lint'... are involved in type checking. These + functions might also do some sanity checking. + +- Functions that begin with 'check'... are *not* involved in type checking. + They exist only for sanity checking. + +Issues surrounding variable naming, shadowing, and such are considered *not* +to be part of type checking, as the formalism omits these details. + Summary of checks ~~~~~~~~~~~~~~~~~ Checks that a set of core bindings is well-formed. The PprStyle and String @@ -120,14 +136,14 @@ That is, use a type let. See Note [Type let] in CoreSyn. However, when linting <body> we need to remember that a=Int, else we might reject a correct program. So we carry a type substitution (in this example [a -> Int]) and apply this substitution before comparing types. The functin - lintInTy :: Type -> LintM Type -returns a substituted type; that's the only reason it returns anything. + lintInTy :: Type -> LintM (Type, Kind) +returns a substituted type. When we encounter a binder (like x::a) we must apply the substitution to the type of the binding variable. lintBinders does this. For Ids, the type-substituted Id is added to the in_scope set (which -itself is part of the TvSubst we are carrying down), and when we +itself is part of the TCvSubst we are carrying down), and when we find an occurrence of an Id, we fetch it from the in-scope set. Note [Bad unsafe coercion] @@ -337,7 +353,7 @@ interactiveInScope hsc_env te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) ids = typeEnvIds te - tyvars = mapUnionVarSet (tyVarsOfType . idType) ids + tyvars = mapUnionVarSet (tyCoVarsOfType . idType) ids -- Why the type variables? How can the top level envt have free tyvars? -- I think it's because of the GHCi debugger, which can bind variables -- f :: [t] -> [t] @@ -453,7 +469,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) do { ty <- lintCoreExpr rhs ; lintBinder binder -- Check match to RHS type ; binder_ty <- applySubstTy (idType binder) - ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) + ; ensureEqTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) -- Check the let/app invariant -- See Note [CoreSyn let/app invariant] in CoreSyn @@ -524,7 +540,7 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) | isStableSource src = do { ty <- lintCoreExpr rhs - ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } lintIdUnfolding _ _ _ = return () -- Do not Lint unstable unfoldings, because that leads -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars @@ -546,24 +562,23 @@ the desugarer. ************************************************************************ -} ---type InKind = Kind -- Substitution not yet applied type InType = Type type InCoercion = Coercion type InVar = Var -type InTyVar = TyVar - -type OutKind = Kind -- Substitution has been applied to this, - -- but has not been linted yet -type LintedKind = Kind -- Substitution applied, and type is linted +type InTyVar = Var +type InCoVar = Var type OutType = Type -- Substitution has been applied to this, -- but has not been linted yet +type OutKind = Kind type LintedType = Type -- Substitution applied, and type is linted +type LintedKind = Kind -type OutCoercion = Coercion -type OutVar = Var -type OutTyVar = TyVar +type OutCoercion = Coercion +type OutVar = Var +type OutTyVar = TyVar +type OutCoVar = Var lintCoreExpr :: CoreExpr -> LintM OutType -- The returned type has the substitution from the monad @@ -591,9 +606,11 @@ lintCoreExpr (Lit lit) lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr ; co' <- applySubstCo co - ; (_, from_ty, to_ty, r) <- lintCoercion co' - ; checkRole co' Representational r - ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; (_, k2, from_ty, to_ty, r) <- lintCoercion co' + ; lintL (classifiesTypeWithValues k2) + (ptext (sLit "Target of cast not # or *:") <+> ppr co) + ; lintRole co' Representational r + ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) ; return to_ty } lintCoreExpr (Tick (Breakpoint _ ids) expr) @@ -610,7 +627,7 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body) = -- See Note [Linting type lets] do { ty' <- applySubstTy ty ; lintTyBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ checkTyKind tv' ty' + do { addLoc (RhsOf tv) $ lintTyKind tv' ty' -- Now extend the substitution so we -- take advantage of it in the body ; extendSubstL tv' ty' $ @@ -645,18 +662,13 @@ lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ lintBinder var $ \ var' -> do { body_ty <- lintCoreExpr expr - ; if isId var' then - return (mkFunTy (idType var') body_ty) - else - return (mkForAllTy var' body_ty) - } - -- The applySubstTy is needed to apply the subst to var + ; return $ mkPiType var' body_ty } lintCoreExpr e@(Case scrut var alt_ty alts) = -- Check the scrutinee do { scrut_ty <- lintCoreExpr scrut - ; alt_ty <- lintInTy alt_ty - ; var_ty <- lintInTy (idType var) + ; (alt_ty, _) <- lintInTy alt_ty + ; (var_ty, _) <- lintInTy (idType var) -- See Note [No alternatives lint check] ; when (null alts) $ @@ -688,8 +700,8 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = -- Don't use lintIdBndr on var, because unboxed tuple is legitimate - ; subst <- getTvSubst - ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) + ; subst <- getTCvSubst + ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) ; lintAndScopeId var $ \_ -> do { -- Check the alternatives @@ -703,29 +715,10 @@ lintCoreExpr (Type ty) = failWithL (ptext (sLit "Type found as expression") <+> ppr ty) lintCoreExpr (Coercion co) - = do { (_kind, ty1, ty2, role) <- lintInCo co - ; return (mkCoercionType role ty1 ty2) } + = do { (k1, k2, ty1, ty2, role) <- lintInCo co + ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) } {- -Note [Kind instantiation in coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following coercion axiom: - ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa - -Consider the following instantiation: - ax_co <* -> *> <Monad> - -We need to split the co_ax_tvs into kind and type variables in order -to find out the coercion kind instantiations. Those can only be Refl -since we don't have kind coercions. This is just a way to represent -kind instantiation. - -We use the number of kind variables to know how to split the coercions -instantiations between kind coercions and type coercions. We lint the -kind coercions and produce the following substitution which is to be -applied in the type variables: - k_ag ~~> * -> * - Note [No alternatives lint check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case expressions with no alternatives are odd beasts, and worth looking at @@ -758,7 +751,10 @@ subtype of the required type, as one would expect. lintCoreArg :: OutType -> CoreArg -> LintM OutType lintCoreArg fun_ty (Type arg_ty) - = do { arg_ty' <- applySubstTy arg_ty + = do { checkL (not (isCoercionTy arg_ty)) + (ptext (sLit "Unnecessary coercion-to-type injection:") + <+> ppr arg_ty) + ; arg_ty' <- applySubstTy arg_ty ; lintTyApp fun_ty arg_ty' } lintCoreArg fun_ty arg @@ -775,7 +771,7 @@ lintAltBinders :: OutType -- Scrutinee type -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintAltBinders scrut_ty con_ty [] - = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) + = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) lintAltBinders scrut_ty con_ty (bndr:bndrs) | isTyVar bndr = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) @@ -787,10 +783,9 @@ lintAltBinders scrut_ty con_ty (bndr:bndrs) ----------------- lintTyApp :: OutType -> OutType -> LintM OutType lintTyApp fun_ty arg_ty - | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty - , isTyVar tyvar - = do { checkTyKind tyvar arg_ty - ; return (substTyWith [tyvar] [arg_ty] body_ty) } + | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty + = do { lintTyKind tv arg_ty + ; return (substTyWith [tv] [arg_ty] body_ty) } | otherwise = failWithL (mkTyAppMsg fun_ty arg_ty) @@ -799,7 +794,7 @@ lintTyApp fun_ty arg_ty lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType lintValApp arg fun_ty arg_ty | Just (arg,res) <- splitFunTy_maybe fun_ty - = do { checkTys arg arg_ty err1 + = do { ensureEqTys arg arg_ty err1 ; return res } | otherwise = failWithL err2 @@ -807,21 +802,18 @@ lintValApp arg fun_ty arg_ty err1 = mkAppMsg fun_ty arg_ty arg err2 = mkNonFunAppMsg fun_ty arg_ty arg -checkTyKind :: OutTyVar -> OutType -> LintM () +lintTyKind :: OutTyVar -> OutType -> LintM () -- Both args have had substitution applied -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -checkTyKind tyvar arg_ty - | isSuperKind tyvar_kind -- kind forall - = lintKind arg_ty +lintTyKind tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. - | otherwise -- type forall = do { arg_kind <- lintType arg_ty - ; unless (arg_kind `isSubKind` tyvar_kind) + ; unless (arg_kind `eqType` tyvar_kind) (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) } where tyvar_kind = tyVarKind tyvar @@ -882,10 +874,10 @@ checkCaseAlts e ty alts = Nothing -> False Just tycon -> isPrimTyCon tycon -checkAltExpr :: CoreExpr -> OutType -> LintM () -checkAltExpr expr ann_ty +lintAltExpr :: CoreExpr -> OutType -> LintM () +lintAltExpr expr ann_ty = do { actual_ty <- lintCoreExpr expr - ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } lintCoreAlt :: OutType -- Type of scrutinee -> OutType -- Type of the alternative @@ -894,16 +886,16 @@ lintCoreAlt :: OutType -- Type of scrutinee -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = - do { checkL (null args) (mkDefaultArgsMsg args) - ; checkAltExpr rhs alt_ty } + do { lintL (null args) (mkDefaultArgsMsg args) + ; lintAltExpr rhs alt_ty } lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) | litIsLifted lit = failWithL integerScrutinisedMsg | otherwise - = do { checkL (null args) (mkDefaultArgsMsg args) - ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; checkAltExpr rhs alt_ty } + = do { lintL (null args) (mkDefaultArgsMsg args) + ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; lintAltExpr rhs alt_ty } where lit_ty = literalType lit @@ -915,13 +907,13 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) { -- First instantiate the universally quantified -- type variables of the data constructor -- We've already check - checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys -- And now bring the new binders into scope ; lintBinders args $ \ args' -> do { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') - ; checkAltExpr rhs alt_ty } } + ; lintAltExpr rhs alt_ty } } | otherwise -- Scrut-ty is wrong shape = addErrL (mkBadAltMsg scrut_ty alt) @@ -948,15 +940,25 @@ lintBinders (var:vars) linterF = lintBinder var $ \var' -> -- See Note [GHC Formalism] lintBinder :: Var -> (Var -> LintM a) -> LintM a lintBinder var linterF - | isId var = lintIdBndr var linterF - | otherwise = lintTyBndr var linterF + | isTyVar var = lintTyBndr var linterF + | isCoVar var = lintCoBndr var linterF + | otherwise = lintIdBndr var linterF lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a lintTyBndr tv thing_inside - = do { subst <- getTvSubst - ; let (subst', tv') = Type.substTyVarBndr subst tv - ; lintTyBndrKind tv' - ; updateTvSubst subst' (thing_inside tv') } + = do { subst <- getTCvSubst + ; let (subst', tv') = substTyVarBndr subst tv + ; lintKind (varType tv') + ; updateTCvSubst subst' (thing_inside tv') } + +lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a +lintCoBndr cv thing_inside + = do { subst <- getTCvSubst + ; let (subst', cv') = substCoVarBndr subst cv + ; lintKind (varType cv') + ; lintL (isCoercionType (varType cv')) + (text "CoVar with non-coercion type:" <+> pprTvBndr cv) + ; updateTCvSubst subst' (thing_inside cv') } lintIdBndr :: Id -> (Id -> LintM a) -> LintM a -- Do substitution on the type of a binder and add the var with this @@ -981,36 +983,35 @@ lintAndScopeId id linterF ; checkL (not (lf_check_global_ids flags) || isLocalId id) (ptext (sLit "Non-local Id binder") <+> ppr id) -- See Note [Checking for global Ids] - ; ty <- lintInTy (idType id) + ; (ty, k) <- lintInTy (idType id) + ; lintL (not (isLevityPolymorphic k)) + (text "Levity polymorphic binder:" <+> + (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k))) ; let id' = setIdType id ty ; addInScopeVar id' $ (linterF id') } {- -************************************************************************ -* * - Types and kinds -* * -************************************************************************ - -We have a single linter for types and kinds. That is convenient -because sometimes it's not clear whether the thing we are looking -at is a type or a kind. +%************************************************************************ +%* * + Types +%* * +%************************************************************************ -} -lintInTy :: InType -> LintM LintedType +lintInTy :: InType -> LintM (LintedType, LintedKind) -- Types only, not kinds -- Check the type, and apply the substitution to it -- See Note [Linting type lets] lintInTy ty = addLoc (InType ty) $ do { ty' <- applySubstTy ty - ; _k <- lintType ty' - ; return ty' } + ; k <- lintType ty' + ; lintKind k + ; return (ty', k) } -------------------- -lintTyBndrKind :: OutTyVar -> LintM () --- Handles both type and kind foralls. -lintTyBndrKind tv = lintKind (tyVarKind tv) +checkTyCon :: TyCon -> LintM () +checkTyCon tc + = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) ------------------- lintType :: OutType -> LintM LintedKind @@ -1019,57 +1020,83 @@ lintType :: OutType -> LintM LintedKind -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintType (TyVarTy tv) - = do { checkTyCoVarInScope tv + = do { checkL (isTyVar tv) (mkBadTyVarMsg tv) + ; lintTyCoVarInScope tv ; return (tyVarKind tv) } -- We checked its kind when we added it to the envt lintType ty@(AppTy t1 t2) + | TyConApp {} <- t1 + = failWithL $ ptext (sLit "TyConApp to the left of AppTy:") <+> ppr ty + | otherwise = do { k1 <- lintType t1 ; k2 <- lintType t2 ; lint_ty_app ty k1 [(t2,k2)] } -lintType ty@(FunTy t1 t2) -- (->) has two different rules, for types and kinds - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } - lintType ty@(TyConApp tc tys) | Just ty' <- coreView ty = lintType ty' -- Expand type synonyms, so that we do not bogusly complain -- about un-saturated type synonyms | isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - -- See Note [The kind invariant] in TypeRep -- Also type synonyms and type families , length tys < tyConArity tc = failWithL (hang (ptext (sLit "Un-saturated type application")) 2 (ppr ty)) | otherwise - = do { ks <- mapM lintType tys + = do { checkTyCon tc + ; ks <- mapM lintType tys ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } -lintType (ForAllTy tv ty) - = do { lintTyBndrKind tv - ; addInScopeVar tv (lintType ty) } +-- arrows can related *unlifted* kinds, so this has to be separate from +-- a dependent forall. +lintType ty@(ForAllTy (Anon t1) t2) + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } + +lintType t@(ForAllTy (Named tv _vis) ty) + = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t) + ; lintTyBndr tv $ \tv' -> + do { k <- lintType ty + ; lintL (not (tv' `elemVarSet` tyCoVarsOfType k)) + (text "Variable escape in forall:" <+> ppr t) + ; lintL (classifiesTypeWithValues k) + (text "Non-* and non-# kind in forall:" <+> ppr t) + ; return k }} lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) +lintType (CastTy ty co) + = do { k1 <- lintType ty + ; (k1', k2) <- lintStarCoercion co + ; ensureEqTys k1 k1' (mkCastErr ty co k1' k1) + ; return k2 } + +lintType (CoercionTy co) + = do { (k1, k2, ty1, ty2, r) <- lintCoercion co + ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 } + lintKind :: OutKind -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintKind k = do { sk <- lintType k - ; unless (isSuperKind sk) + ; unless ((isStarKind sk) || (isUnliftedTypeKind sk)) (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) 2 (ptext (sLit "has kind:") <+> ppr sk))) } +-- confirms that a type is really * +lintStar :: SDoc -> OutKind -> LintM () +lintStar doc k + = lintL (classifiesTypeWithValues k) + (ptext (sLit "Non-*-like kind when *-like expected:") <+> ppr k $$ + ptext (sLit "when checking") <+> doc) + lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 -- or lintarrow "coercion `blah'" k1 k2 - | isSuperKind k1 - = return superKind - | otherwise = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1)) ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2)) ; return liftedTypeKind } @@ -1115,13 +1142,13 @@ lint_app doc kfn kas | Just kfn' <- coreView kfn = go_app kfn' ka - go_app (FunTy kfa kfb) (_,ka) - = do { unless (ka `isSubKind` kfa) (addErrL fail_msg) + go_app (ForAllTy (Anon kfa) kfb) (_,ka) + = do { unless (ka `eqType` kfa) (addErrL fail_msg) ; return kfb } - go_app (ForAllTy kv kfn) (ta,ka) - = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg) - ; return (substKiWith [kv] [ta] kfn) } + go_app (ForAllTy (Named kv _vis) kfn) (ta,ka) + = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg) + ; return (substTyWith [kv] [ta] kfn) } go_app _ _ = failWithL fail_msg @@ -1140,7 +1167,7 @@ lintCoreRule fun_ty (Rule { ru_name = name, ru_bndrs = bndrs = lintBinders bndrs $ \ _ -> do { lhs_ty <- foldM lintCoreArg fun_ty args ; rhs_ty <- lintCoreExpr rhs - ; checkTys lhs_ty rhs_ty $ + ; ensureEqTys lhs_ty rhs_ty $ (rule_doc <+> vcat [ ptext (sLit "lhs type:") <+> ppr lhs_ty , ptext (sLit "rhs type:") <+> ppr rhs_ty ]) ; let bad_bndrs = filterOut (`elemVarSet` exprsFreeVars args) bndrs @@ -1176,7 +1203,7 @@ this check will nail it. ************************************************************************ -} -lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role) +lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) -- Check the coercion, and apply the substitution to it -- See Note [Linting type lets] lintInCo co @@ -1184,79 +1211,109 @@ lintInCo co do { co' <- applySubstCo co ; lintCoercion co' } -lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role) +-- lints a coercion, confirming that its lh kind and its rh kind are both * +-- also ensures that the role is Nominal +lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType) +lintStarCoercion g + = do { (k1, k2, t1, t2, r) <- lintCoercion g + ; lintStar (ptext (sLit "the kind of the left type in") <+> ppr g) k1 + ; lintStar (ptext (sLit "the kind of the right type in") <+> ppr g) k2 + ; lintRole g Nominal r + ; return (t1, t2) } + +lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) -- Check the kind of a coercion term, returning the kind -- Post-condition: the returned OutTypes are lint-free --- and have the same kind as each other -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintCoercion (Refl r ty) = do { k <- lintType ty - ; return (k, ty, ty, r) } + ; return (k, k, ty, ty, r) } lintCoercion co@(TyConAppCo r tc cos) | tc `hasKey` funTyConKey , [co1,co2] <- cos - = do { (k1,s1,t1,r1) <- lintCoercion co1 - ; (k2,s2,t2,r2) <- lintCoercion co2 - ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 - ; checkRole co1 r r1 - ; checkRole co2 r r2 - ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) } + = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 + ; (k2,k'2,s2,t2,r2) <- lintCoercion co2 + ; k <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 + ; k' <- lintArrow (ptext (sLit "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) } | Just {} <- synTyConDefn_maybe tc = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co) | otherwise - = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos - ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) - ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs - ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) } + = do { checkTyCon tc + ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos + ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's) + ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks) + ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs + ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) } lintCoercion co@(AppCo co1 co2) - = do { (k1,s1,t1,r1) <- lintCoercion co1 - ; (k2,s2,t2,r2) <- lintCoercion co2 - ; rk <- lint_co_app co k1 [(s2,k2)] + | TyConAppCo {} <- co1 + = failWithL (ptext (sLit "TyConAppCo to the left of AppCo:") <+> ppr co) + | Refl _ (TyConApp {}) <- co1 + = failWithL (ptext (sLit "Refl (TyConApp ...) to the left of AppCo:") <+> ppr co) + | otherwise + = do { (k1,k2,s1,s2,r1) <- lintCoercion co1 + ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2 + ; k3 <- lint_co_app co k1 [(t1,k'1)] + ; k4 <- lint_co_app co k2 [(t2,k'2)] ; if r1 == Phantom - then checkL (r2 == Phantom || r2 == Nominal) + then lintL (r2 == Phantom || r2 == Nominal) (ptext (sLit "Second argument in AppCo cannot be R:") $$ ppr co) - else checkRole co Nominal r2 - ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) } - -lintCoercion (ForAllCo tv co) - = do { lintTyBndrKind tv - ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co) - ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) } + else lintRole co Nominal r2 + ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) } + +---------- +lintCoercion (ForAllCo tv1 kind_co co) + = do { (_, k2) <- lintStarCoercion kind_co + ; let tv2 = setTyVarKind tv1 k2 + ; (k3, k4, t1, t2, r) <- addInScopeVar tv1 $ lintCoercion co + ; let tyl = mkNamedForAllTy tv1 Invisible t1 + tyr = mkNamedForAllTy tv2 Invisible $ + substTyWith [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo kind_co] t2 + ; return (k3, k4, tyl, tyr, r) } lintCoercion (CoVarCo cv) | not (isCoVar cv) = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv) 2 (ptext (sLit "With offending type:") <+> ppr (varType cv))) | otherwise - = do { checkTyCoVarInScope cv + = do { lintTyCoVarInScope cv ; cv' <- lookupIdInScope cv - ; let (s,t) = coVarKind cv' - k = typeKind s - r = coVarRole cv' - ; when (isSuperKind k) $ - do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality")) - 2 (ppr cv)) - ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) - 2 (ppr cv)) } - ; return (k, s, t, r) } + ; lintUnLiftedCoVar cv + ; return $ coVarKindsTypesRole cv' } -- See Note [Bad unsafe coercion] -lintCoercion (UnivCo _prov r ty1 ty2) +lintCoercion co@(UnivCo prov r ty1 ty2) = do { k1 <- lintType ty1 ; k2 <- lintType ty2 --- ; unless (k1 `eqKind` k2) $ --- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) --- 2 (ppr co)) - ; when (r /= Phantom && isSubOpenTypeKind k1 && isSubOpenTypeKind k2) + ; case prov of + UnsafeCoerceProv -> return () -- no extra checks + + PhantomProv kco -> do { lintRole co Phantom r + ; check_kinds kco k1 k2 } + + ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $ + mkBadProofIrrelMsg ty1 co + ; lintL (isCoercionTy ty2) $ + mkBadProofIrrelMsg ty2 co + ; check_kinds kco k1 k2 } + + PluginProv _ -> return () -- no extra checks + HoleProv h -> addErrL $ + text "Unfilled coercion hole:" <+> ppr h + + ; when (r /= Phantom && classifiesTypeWithValues k1 + && classifiesTypeWithValues k2) (checkTypes ty1 ty2) - ; return (k1, ty1, ty2, r) } + ; return (k1, k2, ty1, ty2, r) } where report s = hang (text $ "Unsafe coercion between " ++ s) 2 (vcat [ text "From:" <+> ppr ty1 @@ -1290,60 +1347,80 @@ lintCoercion (UnivCo _prov r ty1 ty2) _ -> return () } + check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco + ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) + ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } + + lintCoercion (SymCo co) - = do { (k, ty1, ty2, r) <- lintCoercion co - ; return (k, ty2, ty1, r) } + = do { (k1, k2, ty1, ty2, r) <- lintCoercion co + ; return (k2, k1, ty2, ty1, r) } lintCoercion co@(TransCo co1 co2) - = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1 - ; (_, ty2a, ty2b, r2) <- lintCoercion co2 - ; checkL (ty1b `eqType` ty2a) - (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) - 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; checkRole co r1 r2 - ; return (k1, ty1a, ty2b, r1) } + = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1 + ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2 + ; ensureEqTys ty1b ty2a + (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) + 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) + ; lintRole co r1 r2 + ; return (k1a, k2b, ty1a, ty2b, r1) } lintCoercion the_co@(NthCo n co) - = do { (_,s,t,r) <- lintCoercion co - ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of - (Just (tc_s, tys_s), Just (tc_t, tys_t)) + = do { (_, _, s, t, r) <- lintCoercion co + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + { (Just (tv_s, _ty_s), Just (tv_t, _ty_t)) + | n == 0 + -> return (ks, kt, ts, tt, Nominal) + where + ts = tyVarKind tv_s + tt = tyVarKind tv_t + ks = typeKind ts + kt = typeKind tt + + ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + { (Just (tc_s, tys_s), Just (tc_t, tys_t)) | tc_s == tc_t , isInjectiveTyCon tc_s r - -- see Note [NthCo and newtypes] in Coercion + -- see Note [NthCo and newtypes] in TyCoRep , tys_s `equalLength` tys_t , n < length tys_s - -> return (ks, ts, tt, tr) + -> return (ks, kt, ts, tt, tr) where ts = getNth tys_s n tt = getNth tys_t n tr = nthRole r tc_s n ks = typeKind ts + kt = typeKind tt - _ -> failWithL (hang (ptext (sLit "Bad getNth:")) - 2 (ppr the_co $$ ppr s $$ ppr t)) } + ; _ -> failWithL (hang (ptext (sLit "Bad getNth:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) }}} lintCoercion the_co@(LRCo lr co) - = do { (_,s,t,r) <- lintCoercion co - ; checkRole co Nominal r + = do { (_,_,s,t,r) <- lintCoercion co + ; lintRole co Nominal r ; case (splitAppTy_maybe s, splitAppTy_maybe t) of (Just s_pr, Just t_pr) - -> return (k, s_pick, t_pick, Nominal) + -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal) where - s_pick = pickLR lr s_pr - t_pick = pickLR lr t_pr - k = typeKind s_pick + s_pick = pickLR lr s_pr + t_pick = pickLR lr t_pr + ks_pick = typeKind s_pick + kt_pick = typeKind t_pick _ -> failWithL (hang (ptext (sLit "Bad LRCo:")) 2 (ppr the_co $$ ppr s $$ ppr t)) } -lintCoercion (InstCo co arg_ty) - = do { (k,s,t,r) <- lintCoercion co - ; arg_kind <- lintType arg_ty - ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of - (Just (tv1,ty1), Just (tv2,ty2)) - | arg_kind `isSubKind` tyVarKind tv1 - -> return (k, substTyWith [tv1] [arg_ty] ty1, - substTyWith [tv2] [arg_ty] ty2, r) +lintCoercion (InstCo co arg) + = do { (k3, k4, t1',t2', r) <- lintCoercion co + ; (k1',k2',s1,s2, r') <- lintCoercion arg + ; lintRole arg Nominal r' + ; case (splitForAllTy_maybe t1', splitForAllTy_maybe t2') of + (Just (tv1,t1), Just (tv2,t2)) + | k1' `eqType` tyVarKind tv1 + , k2' `eqType` tyVarKind tv2 + -> return (k3, k4, + substTyWith [tv1] [s1] t1, + substTyWith [tv2] [s2] t2, r) | otherwise -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) _ -> failWithL (ptext (sLit "Bad argument of inst")) } @@ -1351,90 +1428,89 @@ lintCoercion (InstCo co arg_ty) lintCoercion co@(AxiomInstCo con ind cos) = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) (bad_ax (text "index out of range")) - -- See Note [Kind instantiation in coercions] ; let CoAxBranch { cab_tvs = ktvs + , cab_cvs = cvs , cab_roles = roles , cab_lhs = lhs , cab_rhs = rhs } = coAxiomNthBranch con ind - ; unless (equalLength ktvs cos) (bad_ax (text "lengths")) - ; in_scope <- getInScope - ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv + ; unless (length ktvs + length cvs == length cos) $ + bad_ax (text "lengths") + ; subst <- getTCvSubst + ; let empty_subst = zapTCvSubst subst ; (subst_l, subst_r) <- foldlM check_ki (empty_subst, empty_subst) - (zip3 ktvs roles cos) - ; let lhs' = Type.substTys subst_l lhs - rhs' = Type.substTy subst_r rhs + (zip3 (ktvs ++ cvs) roles cos) + ; let lhs' = substTys subst_l lhs + rhs' = substTy subst_r rhs ; case checkAxInstCo co of Just bad_branch -> bad_ax $ text "inconsistent with" <+> pprCoAxBranch con bad_branch Nothing -> return () - ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) } + ; let s2 = mkTyConApp (coAxiomTyCon con) lhs' + ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) } where bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) 2 (ppr co)) - check_ki (subst_l, subst_r) (ktv, role, co) - = do { (k, t1, t2, r) <- lintCoercion co - ; checkRole co role r - ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) - -- Using subst_l is ok, because subst_l and subst_r - -- must agree on kind equalities - ; unless (k `isSubKind` ktv_kind) - (bad_ax (text "check_ki2" <+> - vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) - ; return (Type.extendTvSubst subst_l ktv t1, - Type.extendTvSubst subst_r ktv t2) } - -lintCoercion co@(SubCo co') - = do { (k,s,t,r) <- lintCoercion co' - ; checkRole co Nominal r - ; return (k,s,t,Representational) } - - -lintCoercion this@(AxiomRuleCo co ts cs) - = do _ks <- mapM lintType ts - eqs <- mapM lintCoercion cs - - let tyNum = length ts - - case compare (coaxrTypeArity co) tyNum of - EQ -> return () - LT -> err "Too many type arguments" - [ txt "expected" <+> int (coaxrTypeArity co) - , txt "provided" <+> int tyNum ] - GT -> err "Not enough type arguments" - [ txt "expected" <+> int (coaxrTypeArity co) - , txt "provided" <+> int tyNum ] - checkRoles 0 (coaxrAsmpRoles co) eqs - - case coaxrProves co ts [ Pair l r | (_,l,r,_) <- eqs ] of - Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] - Just (Pair l r) -> - do kL <- lintType l - kR <- lintType r - unless (eqKind kL kR) - $ err "Kind error in CoAxiomRule" - [ppr kL <+> txt "/=" <+> ppr kR] - return (kL, l, r, coaxrRole co) + check_ki (subst_l, subst_r) (ktv, role, arg) + = do { (k', k'', s', t', r) <- lintCoercion arg + ; lintRole arg role r + ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) + ktv_kind_r = substTy subst_r (tyVarKind ktv) + ; unless (k' `eqType` ktv_kind_l) + (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] )) + ; unless (k'' `eqType` ktv_kind_r) + (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] )) + ; return (extendTCvSubst subst_l ktv s', + extendTCvSubst subst_r ktv t') } + +lintCoercion (CoherenceCo co1 co2) + = do { (_, k2, t1, t2, r) <- lintCoercion co1 + ; let lhsty = mkCastTy t1 co2 + ; k1' <- lintType lhsty + ; return (k1', k2, lhsty, t2, r) } + +lintCoercion (KindCo co) + = do { (k1, k2, _, _, _) <- lintCoercion co + ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) } + +lintCoercion (SubCo co') + = do { (k1,k2,s,t,r) <- lintCoercion co' + ; lintRole co' Nominal r + ; return (k1,k2,s,t,Representational) } + +lintCoercion this@(AxiomRuleCo co cs) + = do { eqs <- mapM lintCoercion cs + ; lintRoles 0 (coaxrAsmpRoles co) eqs + ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of + Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] + Just (Pair l r) -> + return (typeKind l, typeKind r, l, r, coaxrRole co) } where - txt = ptext . sLit err m xs = failWithL $ - hang (txt m) 2 $ vcat (txt "Rule:" <+> ppr (coaxrName co) : xs) + hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs) - checkRoles n (e : es) ((_,_,_,r) : rs) - | e == r = checkRoles (n+1) es rs + lintRoles n (e : es) ((_,_,_,_,r) : rs) + | e == r = lintRoles (n+1) es rs | otherwise = err "Argument roles mismatch" - [ txt "In argument:" <+> int (n+1) - , txt "Expected:" <+> ppr e - , txt "Found:" <+> ppr r ] - checkRoles _ [] [] = return () - checkRoles n [] rs = err "Too many coercion arguments" - [ txt "Expected:" <+> int n - , txt "Provided:" <+> int (n + length rs) ] - - checkRoles n es [] = err "Not enough coercion arguments" - [ txt "Expected:" <+> int (n + length es) - , txt "Provided:" <+> int n ] + [ text "In argument:" <+> int (n+1) + , text "Expected:" <+> ppr e + , text "Found:" <+> ppr r ] + lintRoles _ [] [] = return () + lintRoles n [] rs = err "Too many coercion arguments" + [ text "Expected:" <+> int n + , text "Provided:" <+> int (n + length rs) ] + + lintRoles n es [] = err "Not enough coercion arguments" + [ text "Expected:" <+> int (n + length es) + , text "Provided:" <+> int n ] + +---------- +lintUnLiftedCoVar :: CoVar -> LintM () +lintUnLiftedCoVar cv + = when (not (isUnLiftedType (coVarKind cv))) $ + failWithL (text "Bad lifted equality:" <+> ppr cv + <+> dcolon <+> ppr (coVarKind cv)) {- ************************************************************************ @@ -1449,7 +1525,7 @@ lintCoercion this@(AxiomRuleCo co ts cs) data LintEnv = LE { le_flags :: LintFlags -- Linting the result of this pass , le_loc :: [LintLocInfo] -- Locations - , le_subst :: TvSubst -- Current type substitution; we also use this + , le_subst :: TCvSubst -- Current type substitution; we also use this -- to keep track of all the variables in scope, -- both Ids and TyVars , le_dynflags :: DynFlags -- DynamicFlags @@ -1533,7 +1609,7 @@ initL dflags flags m = case unLintM m env (emptyBag, emptyBag) of (_, errs) -> errs where - env = LE { le_flags = flags, le_subst = emptyTvSubst, le_loc = [], le_dynflags = dflags } + env = LE { le_flags = flags, le_subst = emptyTCvSubst, le_loc = [], le_dynflags = dflags } getLintFlags :: LintM LintFlags getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) @@ -1542,6 +1618,10 @@ checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = failWithL msg +-- like checkL, but relevant to type checking +lintL :: Bool -> MsgDoc -> LintM () +lintL = checkL + checkWarnL :: Bool -> MsgDoc -> LintM () checkWarnL True _ = return () checkWarnL False msg = addWarnL msg @@ -1586,42 +1666,39 @@ inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars vars m = LintM $ \ env errs -> - unLintM m (env { le_subst = extendTvInScopeList (le_subst env) vars }) + unLintM m (env { le_subst = extendTCvInScopeList (le_subst env) vars }) errs addInScopeVar :: Var -> LintM a -> LintM a addInScopeVar var m = LintM $ \ env errs -> - unLintM m (env { le_subst = extendTvInScope (le_subst env) var }) errs + unLintM m (env { le_subst = extendTCvInScope (le_subst env) var }) errs extendSubstL :: TyVar -> Type -> LintM a -> LintM a extendSubstL tv ty m = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + unLintM m (env { le_subst = Type.extendTCvSubst (le_subst env) tv ty }) errs -updateTvSubst :: TvSubst -> LintM a -> LintM a -updateTvSubst subst' m +updateTCvSubst :: TCvSubst -> LintM a -> LintM a +updateTCvSubst subst' m = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs -getTvSubst :: LintM TvSubst -getTvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getTvInScope (le_subst env)), errs)) +getTCvSubst :: LintM TCvSubst +getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) applySubstTy :: InType -> LintM OutType -applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } +applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) } applySubstCo :: InCoercion -> LintM OutCoercion -applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) } +applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) } lookupIdInScope :: Id -> LintM Id lookupIdInScope id | not (mustHaveLocalBinding id) = return id -- An imported Id | otherwise - = do { subst <- getTvSubst - ; case lookupInScope (getTvInScope subst) id of + = do { subst <- getTCvSubst + ; case lookupInScope (getTCvInScope subst) id of Just v -> return v Nothing -> do { addErrL out_of_scope ; return id } } @@ -1632,30 +1709,31 @@ lookupIdInScope id oneTupleDataConId :: Id -- Should not happen oneTupleDataConId = dataConWorkId (tupleDataCon Boxed 1) -checkTyCoVarInScope :: Var -> LintM () -checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v +lintTyCoVarInScope :: Var -> LintM () +lintTyCoVarInScope v = lintInScope (ptext (sLit "is out of scope")) v -checkInScope :: SDoc -> Var -> LintM () -checkInScope loc_msg var = - do { subst <- getTvSubst - ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) +lintInScope :: SDoc -> Var -> LintM () +lintInScope loc_msg var = + do { subst <- getTCvSubst + ; lintL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) (hsep [pprBndr LetBind var, loc_msg]) } -checkTys :: OutType -> OutType -> MsgDoc -> LintM () +ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied -checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg +ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg -checkRole :: Coercion +lintRole :: Outputable thing + => thing -- where the role appeared -> Role -- expected -> Role -- actual -> LintM () -checkRole co r1 r2 - = checkL (r1 == r2) - (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+> - ptext (sLit "got") <+> ppr r2 $$ - ptext (sLit "in") <+> ppr co) +lintRole co r1 r2 + = lintL (r1 == r2) + (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+> + ptext (sLit "got") <+> ppr r2 $$ + ptext (sLit "in") <+> ppr co) {- ************************************************************************ @@ -1717,12 +1795,12 @@ mkCaseAltMsg e ty1 ty2 = hang (text "Type of case alternatives not the same as the annotation on case:") 4 (vcat [ppr ty1, ppr ty2, ppr e]) -mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc +mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, - hsep [ptext (sLit "Current TV subst"), ppr subst]] + hsep [ptext (sLit "Current TCv subst"), ppr subst]] mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc mkNonDefltMsg e @@ -1857,7 +1935,7 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder -} -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr co from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), ptext (sLit "From-type:") <+> ppr from_ty, @@ -1866,6 +1944,26 @@ mkCastErr expr co from_ty expr_ty ptext (sLit "Coercion used in cast:") <+> ppr co ] +mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc +mkBadUnivCoMsg lr co + = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> + text "side of a UnivCo:" <+> ppr co + +mkBadProofIrrelMsg :: Type -> Coercion -> SDoc +mkBadProofIrrelMsg ty co + = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") + 2 (vcat [ text "type:" <+> ppr ty + , text "co:" <+> ppr co ]) + +mkBadTyVarMsg :: Var -> SDoc +mkBadTyVarMsg tv + = ptext (sLit "Non-tyvar used in TyVarTy:") + <+> ppr tv <+> dcolon <+> ppr (varType tv) + +pprLeftOrRight :: LeftOrRight -> MsgDoc +pprLeftOrRight CLeft = ptext (sLit "left") +pprLeftOrRight CRight = ptext (sLit "right") + dupVars :: [[Var]] -> MsgDoc dupVars vars = hang (ptext (sLit "Duplicate variables brought into scope")) diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 999ca54478..70eb1a1df9 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -516,6 +516,7 @@ cpeRhsE env (Var f `App` _{-type-} `App` arg) | f `hasKey` lazyIdKey -- Replace (lazy a) by a = cpeRhsE env arg -- See Note [lazyId magic] in MkId +cpeRhsE env (Var f `App` _{-levity-} `App` _{-type-} `App` arg) -- See Note [runRW magic] in MkId | f `hasKey` runRWKey -- Replace (runRW# f) by (f realWorld#), = case arg of -- beta reducing if possible @@ -680,11 +681,11 @@ cpeApp env expr collect_args (App fun arg@(Type arg_ty)) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth - ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) } + ; return (App fun' arg, hd, piResultTy fun_ty arg_ty, floats, ss) } - collect_args (App fun arg@(Coercion arg_co)) depth + collect_args (App fun arg@(Coercion {})) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth - ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) } + ; return (App fun' arg, hd, funResultTy fun_ty, floats, ss) } collect_args (App fun arg) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) @@ -1127,7 +1128,7 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs -- any non-static things or it would *already* be Caffy rhs_ok = rhsIsStatic platform (\_ -> False) (\i -> pprPanic "rhsIsStatic" (integer i)) - -- Integer literals should not show up + -- Integer literals should not show up wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec strict_or_unlifted floats rhs @@ -1258,7 +1259,7 @@ newVar :: Type -> UniqSM Id newVar ty = seqType ty `seq` do uniq <- getUniqueM - return (mkSysLocal (fsLit "sat") uniq ty) + return (mkSysLocalOrCoVar (fsLit "sat") uniq ty) ------------------------------------------------------------------------------ diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index 697ce4b6db..0668816a18 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -16,13 +16,12 @@ module CoreSubst ( deShadowBinds, substSpec, substRulesForImportedIds, substTy, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, - lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc, + lookupIdSubst, lookupTCvSubst, substIdOcc, substTickish, substDVarSet, -- ** Operations on substitutions emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, - extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, - extendCvSubst, extendCvSubstList, + extendIdSubst, extendIdSubstList, extendTCvSubst, extendTCvSubstList, extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, isInScope, setInScope, @@ -51,14 +50,13 @@ import qualified Type import qualified Coercion -- We are defining local versions -import Type hiding ( substTy, extendTvSubst, extendTvSubstList +import Type hiding ( substTy, extendTCvSubst, extendTCvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) -import TypeRep (tyVarsOfTypeAcc) -import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) +import Coercion hiding ( substCo, substCoVarBndr ) import TyCon ( tyConArity ) import DataCon -import PrelNames ( eqBoxDataConKey, coercibleDataConKey, unpackCStringIdKey +import PrelNames ( heqDataConKey, coercibleDataConKey, unpackCStringIdKey , unpackCStringUtf8IdKey ) import OptCoercion ( optCoercion ) import PprCore ( pprCoreBindings, pprRules ) @@ -93,7 +91,8 @@ import TysWiredIn ************************************************************************ -} --- | A substitution environment, containing both 'Id' and 'TyVar' substitutions. +-- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' +-- substitutions. -- -- Some invariants apply to how you use the substitution: -- @@ -132,7 +131,7 @@ Note [Extending the Subst] For a core Subst, which binds Ids as well, we make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TvSubst] with Type.TvSubstEnv +For TyVars, see Note [Extending the TCvSubst] with Type.TvSubstEnv For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes @@ -140,7 +139,7 @@ For Ids, we have a different invariant In consequence: -* If the TvSubstEnv and IdSubstEnv are both empty, substExpr would be a +* If all subst envs are empty, substExpr would be a no-op, so substExprSC ("short cut") does nothing. However, substExpr still goes ahead and substitutes. Reason: we may @@ -218,38 +217,48 @@ extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv id extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs +-- | Add a substitution for a 'TyVar' to the 'Subst': the 'TyVar' *must* +-- be a real TyVar, and not a CoVar +extend_tv_subst :: Subst -> TyVar -> Type -> Subst +extend_tv_subst (Subst in_scope ids tvs cvs) tv ty + = ASSERT( isTyVar tv ) + Subst in_scope ids (extendVarEnv tvs tv ty) cvs + -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this -extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs +extendTCvSubst :: Subst -> TyVar -> Type -> Subst +extendTCvSubst subst v r + | isTyVar v + = extend_tv_subst subst v r + | Just co <- isCoercionTy_maybe r + = extendCvSubst subst v co + | otherwise + = pprPanic "CoreSubst.extendTCvSubst" (ppr v <+> ptext (sLit "|->") <+> ppr r) --- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' -extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTCvSubst' +extendTCvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTCvSubstList subst vrs + = foldl' extend subst vrs + where extend subst (v, r) = extendTCvSubst subst v r -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this extendCvSubst :: Subst -> CoVar -> Coercion -> Subst extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r) --- | Adds multiple 'CoVar' -> 'Coercion' substitutions to the --- 'Subst': see also 'extendCvSubst' -extendCvSubstList :: Subst -> [(CoVar,Coercion)] -> Subst -extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs) - -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also --- 'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'. +-- 'extendIdSubst', 'extendTCvSubst' extendSubst :: Subst -> Var -> CoreArg -> Subst extendSubst subst var arg = case arg of - Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty + Type ty -> ASSERT( isTyVar var ) extend_tv_subst subst var ty Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co _ -> ASSERT( isId var ) extendIdSubst subst var arg extendSubstWithVar :: Subst -> Var -> Var -> Subst extendSubstWithVar subst v1 v2 - | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) + | isTyVar v1 = ASSERT( isTyVar v2 ) extend_tv_subst subst v1 (mkTyVarTy v2) | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) @@ -272,12 +281,12 @@ lookupIdSubst doc (Subst in_scope ids _ _) v Var v -- | Find the substitution for a 'TyVar' in the 'Subst' -lookupTvSubst :: Subst -> TyVar -> Type -lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v - --- | Find the coercion substitution for a 'CoVar' in the 'Subst' -lookupCvSubst :: Subst -> CoVar -> Coercion -lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v +lookupTCvSubst :: Subst -> TyVar -> Type +lookupTCvSubst (Subst _ _ tvs cvs) v + | isTyVar v + = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + | otherwise + = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v delBndr :: Subst -> Var -> Subst delBndr (Subst in_scope ids tvs cvs) v @@ -487,8 +496,8 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id | otherwise = setIdType id1 (substTy subst old_ty) old_ty = idType old_id - no_type_change = isEmptyVarEnv tvs || - isEmptyVarSet (Type.tyVarsOfType old_ty) + no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + isEmptyVarSet (tyCoVarsOfType old_ty) -- new_id has the right IdInfo -- The lazy-set is because we're in a loop here, with @@ -566,40 +575,37 @@ clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) For types and coercions we just call the corresponding functions in Type and Coercion, but we have to repackage the substitution, from a -Subst to a TvSubst. +Subst to a TCvSubst. -} substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv - = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of - (TvSubst in_scope' tv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env, tv') + = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq - = case Type.cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq of - (TvSubst in_scope' tv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env, tv') + = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv - = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of - (CvSubst in_scope' tv_env' cv_env', cv') + = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of + (TCvSubst in_scope' tv_env' cv_env', cv') -> (Subst in_scope' id_env tv_env' cv_env', cv') -- | See 'Type.substTy' substTy :: Subst -> Type -> Type -substTy subst ty = Type.substTy (getTvSubst subst) ty - -getTvSubst :: Subst -> TvSubst -getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv +substTy subst ty = Type.substTy (getTCvSubst subst) ty -getCvSubst :: Subst -> CvSubst -getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv +getTCvSubst :: Subst -> TCvSubst +getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv -- | See 'Coercion.substCo' substCo :: Subst -> Coercion -> Coercion -substCo subst co = Coercion.substCo (getCvSubst subst) co +substCo subst co = Coercion.substCo (getTCvSubst subst) co {- ************************************************************************ @@ -611,9 +617,9 @@ substCo subst co = Coercion.substCo (getCvSubst subst) co substIdType :: Subst -> Id -> Id substIdType subst@(Subst _ _ tv_env cv_env) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (tyCoVarsOfType old_ty) = id | otherwise = setIdType id (substTy subst old_ty) - -- The tyVarsOfType is cheaper than it looks + -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself where @@ -728,7 +734,7 @@ substDVarSet subst fvs where subst_fv subst fv acc | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc - | otherwise = tyVarsOfTypeAcc (lookupTvSubst subst fv) (const True) emptyVarSet $! acc + | otherwise = tyCoVarsOfTypeAcc (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc ------------------ substTickish :: Subst -> Tickish Id -> Tickish Id @@ -785,56 +791,67 @@ InlVanilla. The WARN is just so I can see if it happens a lot. * * ************************************************************************ -Note [Optimise coercion boxes aggressively] +Note [Getting the map/coerce RULE to work] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to allow the "map/coerce" RULE to fire: -The simple expression optimiser needs to deal with Eq# boxes as follows: - 1. If the result of optimising the RHS of a non-recursive binding is an - Eq# box, that box is substituted rather than turned into a let, just as - if it were trivial. - let eqv = Eq# co in e ==> e[Eq# co/eqv] + {-# RULES "map/coerce" map coerce = coerce #-} - 2. If the result of optimising a case scrutinee is a Eq# box and the case - deconstructs it in a trivial way, we evaluate the case then and there. - case Eq# co of Eq# cov -> e ==> e[co/cov] +The naive core produced for this is -We do this for two reasons: + forall a b (dict :: Coercible * a b). + map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' - 1. Bindings/case scrutinisation of this form is often created by the - evidence-binding mechanism and we need them to be inlined to be able - desugar RULE LHSes that involve equalities (see e.g. T2291) + where dict' :: Coercible [a] [b] + dict' = ... - 2. The test T4356 fails Lint because it creates a coercion between types - of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this - inlining aggressively we can collapse away the intermediate coercion between - these two types and hence pass Lint again. (This is a sort of a hack.) +This matches literal uses of `map coerce` in code, but that's not what we +want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) +too. Some of this is addressed by compulsorily unfolding coerce on the LHS, +yielding -In fact, our implementation uses slightly liberalised versions of the second rule -rule so that the optimisations are a bit more generally applicable. Precisely: - 2a. We reduce any situation where we can spot a case-of-known-constructor + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... -As a result, the only time we should get residual coercion boxes in the code is -when the type checker generates something like: +Getting better. But this isn't exactly what gets produced. This is because +Coercible essentially has ~R# as a superclass, and superclasses get eagerly +extracted during solving. So we get this: - \eqv -> let eqv' = Eq# (case eqv of Eq# cov -> ... cov ...) + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... -However, the case of lambda-bound equality evidence is fairly rare, so these two -rules should suffice for solving the rule LHS problem for now. +Unfortunately, this still abstracts over a Coercible dictionary. We really +want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, +which transforms the above to (see also Note [Desugaring coerce as cast] in +Desugar) -Annoyingly, we cannot use this modified rule 1a instead of 1: + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... - 1a. If we come across a let-bound constructor application with trivial arguments, - add an appropriate unfolding to the let binder. We spot constructor applications - by using exprIsConApp_maybe, so this would actually let rule 2a reduce more. +Now, we need simpleOptExpr to fix this up. It does so by taking three +separate actions: + 1. Inline certain non-recursive bindings. The choice whether to inline + is made in maybe_substitute. Note the rather specific check for + MkCoercible in there. -The reason is that we REALLY NEED coercion boxes to be substituted away. With rule 1a -we wouldn't simplify this expression at all: + 2. Stripping silly case expressions, like the Coercible_SCSel one. + A case expression is silly if its binder is dead, it has only one, + DEFAULT, alternative, and the scrutinee is a coercion. + See the `Case` case of simple_opt_expr's `go` function. - let eqv = Eq# co - in foo eqv (bar eqv) + 3. Look for case expressions that unpack something that was + just packed and inline them. This is also done in simple_opt_expr's + `go` function. + +This is all a fair amount of special-purpose hackery, but it's for +a good cause. And it won't hurt other RULES and such that it comes across. -The rule LHS desugarer can't deal with Let at all, so we need to push that box into -the use sites. -} simpleOptExpr :: CoreExpr -> CoreExpr @@ -844,7 +861,7 @@ simpleOptExpr :: CoreExpr -> CoreExpr -- or where the RHS is trivial -- -- We also inline bindings that bind a Eq# box: see --- See Note [Optimise coercion boxes aggressively]. +-- See Note [Getting the map/coerce RULE to work]. -- -- The result is NOT guaranteed occurrence-analysed, because -- in (let x = y in ....) we substitute for x; so y's occ-info @@ -907,13 +924,13 @@ simple_opt_expr subst expr go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v go (App e1 e2) = simple_app subst e1 [go e2] go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co) + go (Coercion co) = Coercion (optCoercion (getTCvSubst subst) co) go (Lit lit) = Lit lit go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) go (Cast e co) | isReflCo co' = go e | otherwise = Cast (go e) co' where - co' = optCoercion (getCvSubst subst) co + co' = optCoercion (getTCvSubst subst) co go (Let bind body) = case simple_opt_bind subst bind of (subst', Nothing) -> simple_opt_expr subst' body @@ -921,7 +938,7 @@ simple_opt_expr subst expr go lam@(Lam {}) = go_lam [] subst lam go (Case e b ty as) - -- See Note [Optimise coercion boxes aggressively] + -- See Note [Getting the map/coerce RULE to work] | isDeadBinder b , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as @@ -931,6 +948,12 @@ simple_opt_expr subst expr where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst (zipEqual "simpleOptExpr" bs es) + -- Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , [(DEFAULT, _, rhs)] <- as + , isCoercionType (varType b) + = go rhs + | otherwise = Case e' b' (substTy subst ty) (map (go_alt subst') as) @@ -1022,7 +1045,7 @@ maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst maybe_substitute subst b r | Type ty <- r -- let a::* = TYPE ty in <body> = ASSERT( isTyVar b ) - Just (extendTvSubst subst b ty) + Just (extendTCvSubst subst b ty) | Coercion co <- r = ASSERT( isCoVar b ) @@ -1051,8 +1074,9 @@ maybe_substitute subst b r trivial | exprIsTrivial r = True | (Var fun, args) <- collectArgs r , Just dc <- isDataConWorkId_maybe fun - , dc `hasKey` eqBoxDataConKey || dc `hasKey` coercibleDataConKey - , all exprIsTrivial args = True -- See Note [Optimise coercion boxes aggressively] + , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey + , all exprIsTrivial args = True + -- See Note [Getting the map/coerce RULE to work] | otherwise = False ---------------------- @@ -1183,7 +1207,7 @@ data ConCont = CC [CoreExpr] Coercion -- where t1..tk are the *universally-qantified* type args of 'dc' exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) exprIsConApp_maybe (in_scope, id_unf) expr - = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr))) + = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr))) where go :: Either InScopeSet Subst -> CoreExpr -> ConCont @@ -1275,7 +1299,7 @@ dealWithCoercion :: Coercion -> DataCon -> [CoreExpr] dealWithCoercion co dc dc_args | isReflCo co , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args - = Just (dc, stripTypeArgs univ_ty_args, rest_args) + = Just (dc, map exprToType univ_ty_args, rest_args) | Pair _from_ty to_ty <- coercionKind co , Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty @@ -1286,7 +1310,7 @@ dealWithCoercion co dc dc_args -- will probably not be called in such circumstances, -- but there't nothing wrong with it - = -- Here we do the KPush reduction rule as described in the FC paper + = -- Here we do the KPush reduction rule as described in "Down with kinds" -- The transformation applies iff we have -- (C e1 ... en) `cast` co -- where co :: (T t1 .. tn) ~ to_ty @@ -1301,36 +1325,32 @@ dealWithCoercion co dc dc_args non_univ_args = dropList dc_univ_tyvars dc_args (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args - -- Make the "theta" from Fig 3 of the paper - gammas = decomposeCo tc_arity co - theta_subst = liftCoSubstWith Representational - (dc_univ_tyvars ++ dc_ex_tyvars) - -- existentials are at role N - (gammas ++ map (mkReflCo Nominal) - (stripTypeArgs ex_args)) + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx Representational + dc_univ_tyvars + omegas + dc_ex_tyvars + (map exprToType ex_args) -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty) + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + + to_ex_args = map Type to_ex_arg_tys dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, ppr arg_tys, ppr dc_args, ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ] in - ASSERT2( eqType _from_ty (mkTyConApp to_tc (stripTypeArgs $ takeList dc_univ_tyvars dc_args)) - , dump_doc ) - ASSERT2( all isTypeArg ex_args, dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) - Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) + Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) | otherwise = Nothing -stripTypeArgs :: [CoreExpr] -> [Type] -stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) - [ty | Type ty <- args] - -- We really do want isTypeArg here, not isTyCoArg! - {- Note [Unfolding DFuns] ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 24ce641039..12f35735b2 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -31,9 +31,12 @@ module CoreSyn ( -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, - collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectBinders, collectTyAndValBinders, collectArgs, collectArgsTicks, flattenBinds, + exprToType, exprToCoercion_maybe, + applyTypeToArg, + isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, @@ -1446,11 +1449,16 @@ mkVarApps :: Expr b -> [Var] -> Expr b mkConApp :: DataCon -> [Arg b] -> Expr b mkApps f args = foldl App f args -mkTyApps f args = foldl (\ e a -> App e (Type a)) f args mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars mkConApp con args = mkApps (Var (dataConWorkId con)) args +mkTyApps f args = foldl (\ e a -> App e (typeOrCoercion a)) f args + where + typeOrCoercion ty + | Just co <- isCoercionTy_maybe ty = Coercion co + | otherwise = Type ty + mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b mkConApp2 con tys arg_ids = Var (dataConWorkId con) `mkApps` map Type tys @@ -1547,6 +1555,33 @@ varsToCoreExprs vs = map varToCoreExpr vs {- ************************************************************************ * * + Getting a result type +* * +************************************************************************ + +These are defined here to avoid a module loop between CoreUtils and CoreFVs + +-} + +applyTypeToArg :: Type -> CoreExpr -> Type +-- ^ Determines the type resulting from applying an expression with given type +-- to a given argument expression +applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg) + +-- | If the expression is a 'Type', converts. Otherwise, +-- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'. +exprToType :: CoreExpr -> Type +exprToType (Type ty) = ty +exprToType _bad = pprPanic "exprToType" empty + +-- | If the expression is a 'Coercion', converts. +exprToCoercion_maybe :: CoreExpr -> Maybe Coercion +exprToCoercion_maybe (Coercion co) = Just co +exprToCoercion_maybe _ = Nothing + +{- +************************************************************************ +* * \subsection{Simple access functions} * * ************************************************************************ @@ -1580,13 +1615,11 @@ flattenBinds [] = [] -- | We often want to strip off leading lambdas before getting down to -- business. This function is your friend. collectBinders :: Expr b -> ([b], Expr b) --- | Collect as many type bindings as possible from the front of a nested lambda -collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) --- | Collect as many value bindings as possible from the front of a nested lambda -collectValBinders :: CoreExpr -> ([Id], CoreExpr) --- | Collect type binders from the front of the lambda first, --- then follow up by collecting as many value bindings as possible --- from the resulting stripped expression +-- | Collect type and value binders from nested lambdas, stopping +-- right before any "forall"s within a non-forall. For example, +-- forall (a :: *) (b :: Foo ~ Bar) (c :: *). Baz -> forall (d :: *). Blob +-- will pull out the binders for a, b, c, and Baz, but not for d or anything +-- within Blob. This is to coordinate with tcSplitSigmaTy. collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) collectBinders expr @@ -1596,22 +1629,15 @@ collectBinders expr go bs e = (reverse bs, e) collectTyAndValBinders expr - = (tvs, ids, body) - where - (tvs, body1) = collectTyBinders expr - (ids, body) = collectValBinders body1 - -collectTyBinders expr - = go [] expr - where - go tvs (Lam b e) | isTyVar b = go (b:tvs) e - go tvs e = (reverse tvs, e) - -collectValBinders expr - = go [] expr - where - go ids (Lam b e) | isId b = go (b:ids) e - go ids body = (reverse ids, body) + = go_forall [] [] expr + where go_forall tvs ids (Lam b e) + | isTyVar b = go_forall (b:tvs) ids e + | isCoVar b = go_forall tvs (b:ids) e + go_forall tvs ids e = go_fun tvs ids e + + go_fun tvs ids (Lam b e) + | isId b = go_fun tvs (b:ids) e + go_fun tvs ids e = (reverse tvs, reverse ids, e) -- | Takes a nested application expression and returns the the function -- being applied and the arguments to which it is applied diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs index 4ee867ad0a..aed4e214ad 100644 --- a/compiler/coreSyn/CoreTidy.hs +++ b/compiler/coreSyn/CoreTidy.hs @@ -18,7 +18,7 @@ import CoreSyn import CoreArity import Id import IdInfo -import Type( tidyType, tidyTyVarBndr ) +import Type( tidyType, tidyTyCoVarBndr ) import Coercion( tidyCo ) import Var import VarEnv @@ -126,13 +126,13 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v -- tidyBndr is used for lambda and case binders tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var - | isTyVar var = tidyTyVarBndr env var - | otherwise = tidyIdBndr env var + | isTyCoVar var = tidyTyCoVarBndr env var + | otherwise = tidyIdBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) tidyBndrs env vars = mapAccumL tidyBndr env vars --- Non-top-level variables +-- Non-top-level variables, not covars tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) tidyIdBndr env@(tidy_env, var_env) id = -- Do this pattern match strictly, otherwise we end up holding on to @@ -172,7 +172,8 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs) let ty' = tidyType env (idType id) name' = mkInternalName (idUnique id) occ' noSrcSpan - id' = mkLocalIdWithInfo name' ty' new_info + details = idDetails id + id' = mkLocalVar details name' ty' new_info var_env' = extendVarEnv var_env id id' -- Note [Tidy IdInfo] diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index edbe503fc4..d033dde30d 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -1370,4 +1370,3 @@ computeDiscount dflags arg_discounts res_discount arg_infos cont_info -- Otherwise we, rather arbitrarily, threshold it. Yuk. -- But we want to aovid inlining large functions that return -- constructors into contexts that are simply "interesting" - diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 5c1c986522..059abf1c67 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -37,6 +37,7 @@ module CoreUtils ( tryEtaReduce, -- * Manipulating data constructors and types + exprToType, exprToCoercion_maybe, applyTypeToArgs, applyTypeToArg, dataConRepInstPat, dataConRepFSInstPat, isEmptyTy, @@ -115,8 +116,8 @@ coreAltType (_,bs,rhs) | otherwise = ty -- Note [Existential variables and silly type synonyms] where ty = exprType rhs - free_tvs = tyVarsOfType ty - bad_binder b = isTyVar b && b `elemVarSet` free_tvs + free_tvs = tyCoVarsOfType ty + bad_binder b = b `elemVarSet` free_tvs coreAltsType :: [CoreAlt] -> Type -- ^ Returns the type of the first alternative, which should be the same as for all alternatives @@ -156,29 +157,29 @@ Various possibilities suggest themselves: - Expand synonyms on the fly, when the problem arises. That is what we are doing here. It's not too expensive, I think. --} -applyTypeToArg :: Type -> CoreExpr -> Type --- ^ Determines the type resulting from applying an expression with given type --- to a given argument expression -applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty -applyTypeToArg fun_ty _ = funResultTy fun_ty +Note that there might be existentially quantified coercion variables, too. +-} +-- Not defined with applyTypeToArg because you can't print from CoreSyn. applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context applyTypeToArgs e op_ty args = go op_ty args where - go op_ty [] = op_ty - go op_ty (Type ty : args) = go_ty_args op_ty [ty] args - go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty - = go res_ty args + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args + go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args go _ _ = pprPanic "applyTypeToArgs" panic_msg -- go_ty_args: accumulate type arguments so we can instantiate all at once go_ty_args op_ty rev_tys (Type ty : args) = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys (Coercion co : args) + = go_ty_args op_ty (mkCoercionTy co : rev_tys) args go_ty_args op_ty rev_tys args = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args @@ -187,6 +188,7 @@ applyTypeToArgs e op_ty args , ptext (sLit "Type:") <+> ppr op_ty , ptext (sLit "Args:") <+> ppr args ] + {- ************************************************************************ * * @@ -206,7 +208,7 @@ mkCast e co = e mkCast (Coercion e_co) co - | isCoVarType (pSnd (coercionKind co)) + | isCoercionType (pSnd (coercionKind co)) -- The guard here checks that g has a (~#) on both sides, -- otherwise decomposeCo fails. Can in principle happen -- with unsafeCoerce @@ -700,7 +702,7 @@ combineIdenticalAlts imposs_cons ((_con1,bndrs1,rhs1) : con_alts) cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 identical_to_alt1 (_con,bndrs,rhs) = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 - tickss = map (stripTicksT tickishFloatable . thirdOf3) eliminated_alts + tickss = map (stripTicksT tickishFloatable . thdOf3) eliminated_alts combineIdenticalAlts imposs_cons alts = (False, imposs_cons, alts) @@ -1111,10 +1113,12 @@ isExpandableApp fn n_val_args -- This incidentally picks up the (n_val_args = 0) case go 0 _ = True go n_val_args ty - | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty - | Just (arg, ty) <- splitFunTy_maybe ty - , isPredTy arg = go (n_val_args-1) ty - | otherwise = False + | Just (bndr, ty) <- splitPiTy_maybe ty + = caseBinder bndr + (\_tv -> go n_val_args ty) + (\bndr_ty -> isPredTy bndr_ty && go (n_val_args-1) ty) + | otherwise + = False {- Note [Expandable overloadings] @@ -1515,24 +1519,24 @@ dataConInstPat fss uniqs con inst_tys (ex_fss, id_fss) = splitAt n_ex fss -- Make the instantiating substitution for universals - univ_subst = zipOpenTvSubst univ_tvs inst_tys + univ_subst = zipOpenTCvSubst univ_tvs inst_tys -- Make existential type variables, applyingn and extending the substitution (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) - mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) - mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv) + mk_ex_var :: TCvSubst -> (TyVar, FastString, Unique) -> (TCvSubst, TyVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubst subst tv + (mkTyVarTy new_tv) , new_tv) where - new_tv = mkTyVar new_name kind - new_name = mkSysTvName uniq fs - kind = Type.substTy subst (tyVarKind tv) + new_tv = mkTyVar (mkSysTvName uniq fs) kind + kind = Type.substTy subst (tyVarKind tv) -- Make value vars, instantiating types arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs mk_id_var uniq fs ty str - = mkLocalIdWithInfo name (Type.substTy full_subst ty) info + = mkLocalIdOrCoVarWithInfo name (Type.substTy full_subst ty) info where name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding @@ -1576,13 +1580,13 @@ cheapEqExpr' ignoreTick = go_s go (Var v1) (Var v2) = v1 == v2 go (Lit lit1) (Lit lit2) = lit1 == lit2 go (Type t1) (Type t2) = t1 `eqType` t2 - go (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2 + go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 go (App f1 a1) (App f2 a2) = f1 `go_s` f2 && a1 `go_s` a2 go (Cast e1 t1) (Cast e2 t2) - = e1 `go_s` e2 && t1 `coreEqCoercion` t2 + = e1 `go_s` e2 && t1 `eqCoercion` t2 go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go_s` e2 @@ -1614,8 +1618,8 @@ eqExpr in_scope e1 e2 go _ (Lit lit1) (Lit lit2) = lit1 == lit2 go env (Type t1) (Type t2) = eqTypeX env t1 t2 - go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2 - go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2 + go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 @@ -1660,9 +1664,9 @@ diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] diffExpr _ env (Coercion co1) (Coercion co2) - | coreEqCoercion2 env co1 co2 = [] + | eqCoercionX env co1 co2 = [] diffExpr top env (Cast e1 co1) (Cast e2 co2) - | coreEqCoercion2 env co1 co2 = diffExpr top env e1 e2 + | eqCoercionX env co1 co2 = diffExpr top env e1 e2 diffExpr top env (Tick n1 e1) e2 | not (tickishIsCode n1) = diffExpr top env e1 e2 diffExpr top env e1 (Tick n2 e2) @@ -1890,7 +1894,7 @@ need to address that here. tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body - = go (reverse bndrs) body (mkReflCo Representational (exprType body)) + = go (reverse bndrs) body (mkRepReflCo (exprType body)) where incoming_arity = count isId bndrs @@ -1954,9 +1958,9 @@ tryEtaReduce bndrs body -- See Note [Eta reduction with casted arguments] ok_arg bndr (Type ty) co | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkForAllCo tv co, []) + , bndr == tv = Just (mkHomoForAllCos [tv] co, []) ok_arg bndr (Var v) co - | bndr == v = let reflCo = mkReflCo Representational (idType bndr) + | bndr == v = let reflCo = mkRepReflCo (idType bndr) in Just (mkFunCo Representational reflCo co, []) ok_arg bndr (Cast e co_arg) co | (ticks, Var v) <- stripTicksTop tickishFloatable e diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index b1d535f90f..c3e445a2bc 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -19,11 +19,9 @@ module MkCore ( -- * Floats FloatBind(..), wrapFloat, - -- * Constructing equality evidence boxes - mkEqBox, - -- * Constructing small tuples - mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, + mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, + mkCoreTupBoxity, -- * Constructing big tuples mkBigCoreVarTup, mkBigCoreVarTupTy, @@ -64,9 +62,9 @@ import TysWiredIn import PrelNames import HsUtils ( mkChunkified, chunkify ) -import TcType ( mkSigmaTy ) +import TcType ( mkInvSigmaTy ) import Type -import Coercion +import Coercion ( isCoVar ) import TysPrim import DataCon ( DataCon, dataConWorkId ) import IdInfo ( vanillaIdInfo, setStrictnessInfo, @@ -78,10 +76,8 @@ import FastString import UniqSupply import BasicTypes import Util -import Pair import DynFlags import Data.List -import Data.Ord import Data.Char ( ord ) #if __GLASGOW_HASKELL__ < 709 @@ -98,18 +94,15 @@ infixl 4 `mkCoreApp`, `mkCoreApps` ************************************************************************ -} sortQuantVars :: [Var] -> [Var] --- Sort the variables (KindVars, TypeVars, and Ids) --- into order: Kind, then Type, then Id +-- Sort the variables, putting type and covars first, in scoped order, +-- and then other Ids -- It is a deterministic sort, meaining it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism] -- in Unique. -sortQuantVars = sortBy (comparing category) +sortQuantVars vs = sorted_tcvs ++ ids where - category :: Var -> Int - category v - | isKindVar v = 1 - | isTyVar v = 2 - | otherwise = 3 + (tcvs, ids) = partition (isTyVar <||> isCoVar) vs + sorted_tcvs = toposortTyVars tcvs -- | Bind a binding group over an expression, using a @let@ or @case@ as -- appropriate (see "CoreSyn#let_app_invariant") @@ -148,8 +141,7 @@ mkCoreApps orig_fun orig_args = go orig_fun (exprType orig_fun) orig_args where go fun _ [] = fun - go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args - go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args + go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (piResultTy fun_ty ty) args go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args ) go (mk_val_app fun arg arg_ty res_ty) res_ty args @@ -194,7 +186,7 @@ mkWildEvBinder pred = mkWildValBinder pred -- easy to get into difficulties with shadowing. That's why it is used so little. -- See Note [WildCard binders] in SimplEnv mkWildValBinder :: Type -> Id -mkWildValBinder ty = mkLocalId wildCardName ty +mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr -- Make a case expression whose case binder is unused @@ -240,19 +232,19 @@ mkCoreLams = mkLams -- | Create a 'CoreExpr' which will evaluate to the given @Int@ mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int -mkIntExpr dflags i = mkConApp intDataCon [mkIntLit dflags i] +mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] -- | Create a 'CoreExpr' which will evaluate to the given @Int@ mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int -mkIntExprInt dflags i = mkConApp intDataCon [mkIntLitInt dflags i] +mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value mkWordExpr :: DynFlags -> Integer -> CoreExpr -mkWordExpr dflags w = mkConApp wordDataCon [mkWordLit dflags w] +mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Word@ mkWordExprWord :: DynFlags -> Word -> CoreExpr -mkWordExprWord dflags w = mkConApp wordDataCon [mkWordLitWord dflags w] +mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer @@ -261,16 +253,16 @@ mkIntegerExpr i = do t <- lookupTyCon integerTyConName -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr -mkFloatExpr f = mkConApp floatDataCon [mkFloatLitFloat f] +mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] -- | Create a 'CoreExpr' which will evaluate to the given @Double@ mkDoubleExpr :: Double -> CoreExpr -mkDoubleExpr d = mkConApp doubleDataCon [mkDoubleLitDouble d] +mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] -- | Create a 'CoreExpr' which will evaluate to the given @Char@ mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int -mkCharExpr c = mkConApp charDataCon [mkCharLit c] +mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] -- | Create a 'CoreExpr' which will evaluate to the given @String@ mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String @@ -296,18 +288,6 @@ mkStringExprFS str chars = unpackFS str safeChar c = ord c >= 1 && ord c <= 0x7F --- This take a ~# b (or a ~# R b) and returns a ~ b (or Coercible a b) -mkEqBox :: Coercion -> CoreExpr -mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) - Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co - where (Pair ty1 ty2, role) = coercionKindRole co - k = typeKind ty1 - datacon = case role of - Nominal -> eqBoxDataCon - Representational -> coercibleDataCon - Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" - (ppr co) - {- ************************************************************************ * * @@ -339,8 +319,23 @@ mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) mkCoreTup :: [CoreExpr] -> CoreExpr mkCoreTup [] = Var unitDataConId mkCoreTup [c] = c -mkCoreTup cs = mkConApp (tupleDataCon Boxed (length cs)) - (map (Type . exprType) cs ++ cs) +mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) + +-- | Build a small unboxed tuple holding the specified expressions, +-- with the given types. The types must be the types of the expressions. +-- Do not include the levity specifiers; this function calculates them +-- for you. +mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr +mkCoreUbxTup tys exps + = ASSERT( tys `equalLength` exps) + mkCoreConApps (tupleDataCon Unboxed (length tys)) + (map (Type . getLevity "mkCoreUbxTup") tys ++ map Type tys ++ exps) + +-- | Make a core tuple of the given boxity +mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr +mkCoreTupBoxity Boxed exps = mkCoreTup exps +mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps -- | Build a big tuple holding the specified variables mkBigCoreVarTup :: [Id] -> CoreExpr @@ -513,11 +508,11 @@ interact well with rules. -- | Makes a list @[]@ for lists of the specified type mkNilExpr :: Type -> CoreExpr -mkNilExpr ty = mkConApp nilDataCon [Type ty] +mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] -- | Makes a list @(:)@ for lists of the specified type mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr -mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl] +mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] -- | Make a list containing the given expressions, where the list has the given type mkListExpr :: Type -> [CoreExpr] -> CoreExpr @@ -595,7 +590,7 @@ mkRuntimeErrorApp -> CoreExpr mkRuntimeErrorApp err_id res_ty err_msg - = mkApps (Var err_id) [Type res_ty, err_string] + = mkApps (Var err_id) [Type (getLevity "mkRuntimeErrorApp" res_ty), Type res_ty, err_string] where err_string = Lit (mkMachString err_msg) @@ -688,7 +683,8 @@ mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy runtimeErrorTy :: Type -- The runtime error Ids take a UTF8-encoded string as argument -runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) +runtimeErrorTy = mkInvSigmaTy [levity1TyVar, openAlphaTyVar] [] + (mkFunTy addrPrimTy openAlphaTy) errorName :: Name errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID @@ -697,7 +693,7 @@ eRROR_ID :: Id eRROR_ID = pc_bottoming_Id2 errorName errorTy errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] -errorTy = mkSigmaTy [openAlphaTyVar] [] +errorTy = mkInvSigmaTy [levity1TyVar, openAlphaTyVar] [] (mkFunTys [ mkClassPred ipClass [ mkStrLitTy (fsLit "callStack") @@ -712,7 +708,7 @@ uNDEFINED_ID :: Id uNDEFINED_ID = pc_bottoming_Id1 undefinedName undefinedTy undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] -undefinedTy = mkSigmaTy [openAlphaTyVar] [] +undefinedTy = mkInvSigmaTy [levity1TyVar, openAlphaTyVar] [] (mkFunTy (mkClassPred ipClass [ mkStrLitTy (fsLit "callStack") @@ -723,14 +719,14 @@ undefinedTy = mkSigmaTy [openAlphaTyVar] [] Note [Error and friends have an "open-tyvar" forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'error' and 'undefined' have types - error :: forall (a::OpenKind). String -> a - undefined :: forall (a::OpenKind). a -Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that + error :: forall (v :: Levity) (a :: TYPE v). String -> a + undefined :: forall (v :: Levity) (a :: TYPE v). a +Notice the levity polymophism. This ensures that "error" can be instantiated at * unboxed as well as boxed types * polymorphic types This is OK because it never returns, so the return type is irrelevant. -See Note [OpenTypeKind accepts foralls] in TcUnify. +See Note [Sort-polymorphic tyvars accept foralls] in TcUnify. ************************************************************************ diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index eb5e595925..da2b311ab6 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -131,8 +131,8 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- an atomic value (e.g. function args) ppr_expr _ (Var name) = ppr name -ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Weird -ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE:") <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO:") <+> ppr co) ppr_expr add_par (Lit lit) = pprLiteral add_par lit ppr_expr add_par (Cast expr co) @@ -183,7 +183,7 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) ] else add_par $ sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, - ifPprDebug (braces (ppr ty)), + ifPprDebug (text "return" <+> ppr ty), sep [ptext (sLit "of") <+> ppr_bndr var, char '{' <+> ppr_case_pat con args <+> arrow] ], @@ -197,7 +197,7 @@ ppr_expr add_par (Case expr var ty alts) = add_par $ sep [sep [ptext (sLit "case") <+> pprCoreExpr expr - <+> ifPprDebug (braces (ppr ty)), + <+> ifPprDebug (text "return" <+> ppr ty), ptext (sLit "of") <+> ppr_bndr var <+> char '{'], nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), char '}' diff --git a/compiler/coreSyn/TrieMap.hs b/compiler/coreSyn/TrieMap.hs index b437db9978..5b34c9aa8b 100644 --- a/compiler/coreSyn/TrieMap.hs +++ b/compiler/coreSyn/TrieMap.hs @@ -12,11 +12,10 @@ module TrieMap( CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, - CoercionMap, + LooseTypeMap, MaybeMap, ListMap, - TrieMap(..), insertTM, deleteTM, - lookupTypeMapTyCon + TrieMap(..), insertTM, deleteTM ) where import CoreSyn @@ -24,13 +23,11 @@ import Coercion import Literal import Name import Type -import TypeRep -import TyCon(TyCon) +import TyCoRep import Var import UniqFM import Unique( Unique ) import FastString(FastString) -import CoAxiom(CoAxiomRule(coaxrName)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap @@ -652,222 +649,41 @@ fdA k m = foldTM k (am_deflt m) ************************************************************************ -} +-- We should really never care about the contents of a coercion. Instead, +-- just look up the coercion's type. newtype CoercionMap a = CoercionMap (CoercionMapG a) instance TrieMap CoercionMap where - type Key CoercionMap = Coercion - emptyTM = CoercionMap emptyTM - lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m - alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) - foldTM k (CoercionMap m) = foldTM k m - mapTM f (CoercionMap m) = CoercionMap (mapTM f m) + type Key CoercionMap = Coercion + emptyTM = CoercionMap emptyTM + lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) + foldTM k (CoercionMap m) = foldTM k m + mapTM f (CoercionMap m) = CoercionMap (mapTM f m) type CoercionMapG = GenMap CoercionMapX -data CoercionMapX a - = KM { km_refl :: RoleMap (TypeMapG a) - , km_tc_app :: RoleMap (NameEnv (ListMap CoercionMapG a)) - , km_app :: CoercionMapG (CoercionMapG a) - , km_forall :: CoercionMapG (BndrMap a) -- See Note [Binders] - , km_var :: VarMap a - , km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMapG a)) - , km_univ :: RoleMap (TypeMapG (TypeMapG a)) - , km_sym :: CoercionMapG a - , km_trans :: CoercionMapG (CoercionMapG a) - , km_nth :: IntMap.IntMap (CoercionMapG a) - , km_left :: CoercionMapG a - , km_right :: CoercionMapG a - , km_inst :: CoercionMapG (TypeMapG a) - , km_sub :: CoercionMapG a - , km_axiom_rule :: Map.Map FastString - (ListMap TypeMapG (ListMap CoercionMapG a)) - } - -instance Eq (DeBruijn Coercion) where - D env1 co1 == D env2 co2 = go co1 co2 where - go (Refl eq1 ty1) (Refl eq2 ty2) - = eq1 == eq2 && D env1 ty1 == D env2 ty2 - go (TyConAppCo eq1 tc1 cos1) (TyConAppCo eq2 tc2 cos2) - = eq1 == eq2 && tc1 == tc2 && D env1 cos1 == D env2 cos2 - go (AppCo co11 co12) (AppCo co21 co22) - = D env1 co11 == D env2 co21 && - D env1 co12 == D env2 co22 - go (ForAllCo v1 co1) (ForAllCo v2 co2) - = D env1 (tyVarKind v1) == D env2 (tyVarKind v2) && - D (extendCME env1 v1) co1 == D (extendCME env2 v2) co2 - go (CoVarCo cv1) (CoVarCo cv2) - = case (lookupCME env1 cv1, lookupCME env2 cv2) of - (Just bv1, Just bv2) -> bv1 == bv2 - (Nothing, Nothing) -> cv1 == cv2 - _ -> False - go (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) - = con1 == con2 && ind1 == ind2 && D env1 cos1 == D env2 cos2 - go (UnivCo _ r1 ty11 ty12) (UnivCo _ r2 ty21 ty22) - = r1 == r2 && D env1 ty11 == D env2 ty21 && - D env1 ty12 == D env2 ty22 - go (SymCo co1) (SymCo co2) - = D env1 co1 == D env2 co2 - go (TransCo co11 co12) (TransCo co21 co22) - = D env1 co11 == D env2 co21 && - D env1 co12 == D env2 co22 - go (NthCo d1 co1) (NthCo d2 co2) - = d1 == d2 && D env1 co1 == D env2 co2 - go (LRCo d1 co1) (LRCo d2 co2) - = d1 == d2 && D env1 co1 == D env2 co2 - go (InstCo co1 ty1) (InstCo co2 ty2) - = D env1 co1 == D env2 co2 && D env1 ty1 == D env2 ty2 - go (SubCo co1) (SubCo co2) - = D env1 co1 == D env2 co2 - go (AxiomRuleCo a1 ts1 cs1) (AxiomRuleCo a2 ts2 cs2) - = a1 == a2 && D env1 ts1 == D env2 ts2 && D env1 cs1 == D env2 cs2 - go _ _ = False - - -emptyC :: CoercionMapX a -emptyC = KM { km_refl = emptyTM, km_tc_app = emptyTM - , km_app = emptyTM, km_forall = emptyTM - , km_var = emptyTM, km_axiom = emptyNameEnv - , km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM - , km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM - , km_inst = emptyTM, km_sub = emptyTM - , km_axiom_rule = emptyTM } +newtype CoercionMapX a = CoercionMapX (TypeMapX a) instance TrieMap CoercionMapX where - type Key CoercionMapX = DeBruijn Coercion - emptyTM = emptyC - lookupTM = lkC - alterTM = xtC - foldTM = fdC - mapTM = mapC - -mapC :: (a->b) -> CoercionMapX a -> CoercionMapX b -mapC f (KM { km_refl = krefl, km_tc_app = ktc - , km_app = kapp, km_forall = kforall - , km_var = kvar, km_axiom = kax - , km_univ = kuniv , km_sym = ksym, km_trans = ktrans - , km_nth = knth, km_left = kml, km_right = kmr - , km_inst = kinst, km_sub = ksub - , km_axiom_rule = kaxr }) - = KM { km_refl = mapTM (mapTM f) krefl - , km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc - , km_app = mapTM (mapTM f) kapp - , km_forall = mapTM (mapTM f) kforall - , km_var = mapTM f kvar - , km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax - , km_univ = mapTM (mapTM (mapTM f)) kuniv - , km_sym = mapTM f ksym - , km_trans = mapTM (mapTM f) ktrans - , km_nth = IntMap.map (mapTM f) knth - , km_left = mapTM f kml - , km_right = mapTM f kmr - , km_inst = mapTM (mapTM f) kinst - , km_sub = mapTM f ksub - , km_axiom_rule = mapTM (mapTM (mapTM f)) kaxr - } + type Key CoercionMapX = DeBruijn Coercion + emptyTM = CoercionMapX emptyTM + lookupTM = lkC + alterTM = xtC + foldTM f (CoercionMapX core_tm) = foldTM f core_tm + mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) -lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a -lkC (D env co) m = go co m - where - go (Refl r ty) = km_refl >.> lookupTM r >=> lkG (D env ty) - go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> - lkList (lkG . D env) cs - go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> - lkList (lkG . D env) cs - go (AppCo c1 c2) = km_app >.> lkG (D env c1) >=> lkG (D env c2) - go (TransCo c1 c2) = km_trans >.> lkG (D env c1) >=> lkG (D env c2) - - -- the provenance is not used in the map - go (UnivCo _ r t1 t2) = km_univ >.> lookupTM r >=> lkG (D env t1) >=> - lkG (D env t2) - go (InstCo c t) = km_inst >.> lkG (D env c) >=> lkG (D env t) - go (ForAllCo v c) = km_forall >.> lkG (D (extendCME env v) c) >=> - lkBndr env v - go (CoVarCo v) = km_var >.> lkVar env v - go (SymCo c) = km_sym >.> lkG (D env c) - go (NthCo n c) = km_nth >.> lookupTM n >=> lkG (D env c) - go (LRCo CLeft c) = km_left >.> lkG (D env c) - go (LRCo CRight c) = km_right >.> lkG (D env c) - go (SubCo c) = km_sub >.> lkG (D env c) - go (AxiomRuleCo co ts cs) = km_axiom_rule >.> - lookupTM (coaxrName co) >=> - lkList (lkG . D env) ts >=> - lkList (lkG . D env) cs +instance Eq (DeBruijn Coercion) where + D env1 co1 == D env2 co2 + = D env1 (coercionType co1) == + D env2 (coercionType co2) +lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a +lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) + core_tm xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a -xtC (D env c) f m = case c of - Refl r ty -> m { km_refl = km_refl m |> xtR r - |>> xtG (D env ty) f } - TyConAppCo r tc cs -> m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc - |>> xtList (xtG . D env) cs f} - AxiomInstCo ax ind cs -> m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind - |>> xtList (xtG . D env) cs f} - AppCo c1 c2 -> m { km_app = km_app m |> xtG (D env c1) - |>> xtG (D env c2) f } - TransCo c1 c2 -> m { km_trans = km_trans m |> xtG (D env c1) - |>> xtG (D env c2) f } - -- the provenance is not used in the map - UnivCo _ r t1 t2 -> m { km_univ = km_univ m |> xtR r - |>> xtG (D env t1) - |>> xtG (D env t2) f } - InstCo c t -> m { km_inst = km_inst m |> xtG (D env c) - |>> xtG (D env t) f} - ForAllCo v c -> m { km_forall = km_forall m - |> xtG (D (extendCME env v) c) - |>> xtBndr env v f } - CoVarCo v -> m { km_var = km_var m |> xtVar env v f } - SymCo c -> m { km_sym = km_sym m |> xtG (D env c) f } - NthCo n c -> m { km_nth = km_nth m |> xtInt n - |>> xtG (D env c) f } - LRCo CLeft c -> m { km_left = km_left m |> xtG (D env c) f } - LRCo CRight c -> m { km_right = km_right m |> xtG (D env c) f } - SubCo c -> m { km_sub = km_sub m |> xtG (D env c) f } - AxiomRuleCo co ts cs -> m { km_axiom_rule = km_axiom_rule m - |> alterTM (coaxrName co) - |>> xtList (xtG . D env) ts - |>> xtList (xtG . D env) cs f } - -fdC :: (a -> b -> b) -> CoercionMapX a -> b -> b -fdC k m = foldTM (foldTM k) (km_refl m) - . foldTM (foldTM (foldTM k)) (km_tc_app m) - . foldTM (foldTM k) (km_app m) - . foldTM (foldTM k) (km_forall m) - . foldTM k (km_var m) - . foldTM (foldTM (foldTM k)) (km_axiom m) - . foldTM (foldTM (foldTM k)) (km_univ m) - . foldTM k (km_sym m) - . foldTM (foldTM k) (km_trans m) - . foldTM (foldTM k) (km_nth m) - . foldTM k (km_left m) - . foldTM k (km_right m) - . foldTM (foldTM k) (km_inst m) - . foldTM k (km_sub m) - . foldTM (foldTM (foldTM k)) (km_axiom_rule m) - -newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) } - -instance TrieMap RoleMap where - type Key RoleMap = Role - emptyTM = RM emptyTM - lookupTM = lkR - alterTM = xtR - foldTM = fdR - mapTM = mapR - -lkR :: Role -> RoleMap a -> Maybe a -lkR Nominal = lookupTM 1 . unRM -lkR Representational = lookupTM 2 . unRM -lkR Phantom = lookupTM 3 . unRM - -xtR :: Role -> XT a -> RoleMap a -> RoleMap a -xtR Nominal f = RM . alterTM 1 f . unRM -xtR Representational f = RM . alterTM 2 f . unRM -xtR Phantom f = RM . alterTM 3 f . unRM - -fdR :: (a -> b -> b) -> RoleMap a -> b -> b -fdR f (RM m) = foldTM f m - -mapR :: (a -> b) -> RoleMap a -> RoleMap b -mapR f = RM . mapTM f . unRM +xtC (D env co) f (CoercionMapX m) + = CoercionMapX (xtT (D env $ coercionType co) f m) {- ************************************************************************ @@ -877,49 +693,12 @@ mapR f = RM . mapTM f . unRM ************************************************************************ -} --- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this --- is the type you want. -newtype TypeMap a = TypeMap (TypeMapG a) - --- Below are some client-oriented functions which operate on 'TypeMap'. - -instance TrieMap TypeMap where - type Key TypeMap = Type - emptyTM = TypeMap emptyTM - lookupTM k (TypeMap m) = lookupTM (deBruijnize k) m - alterTM k f (TypeMap m) = TypeMap (alterTM (deBruijnize k) f m) - foldTM k (TypeMap m) = foldTM k m - mapTM f (TypeMap m) = TypeMap (mapTM f m) - -foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b -foldTypeMap k z m = foldTM k m z - -emptyTypeMap :: TypeMap a -emptyTypeMap = emptyTM - -lookupTypeMap :: TypeMap a -> Type -> Maybe a -lookupTypeMap cm t = lookupTM t cm - --- Returns the type map entries that have keys starting with the given tycon. --- This only considers saturated applications (i.e. TyConApp ones). -lookupTypeMapTyCon :: TypeMap a -> TyCon -> [a] -lookupTypeMapTyCon (TypeMap EmptyMap) _ = [] -lookupTypeMapTyCon (TypeMap (SingletonMap (D _ (TyConApp tc' _)) v)) tc - | tc' == tc = [v] - | otherwise = [] -lookupTypeMapTyCon (TypeMap SingletonMap{}) _ = [] -lookupTypeMapTyCon (TypeMap (MultiMap TM { tm_tc_app = cs })) tc = - case lookupUFM cs tc of - Nothing -> [] - Just xs -> foldTM (:) xs [] - -extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a -extendTypeMap m t v = alterTM t (const (Just v)) m - -- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended -- key makes it suitable for recursive traversal, since it can track binders, -- but it is strictly internal to this module. If you are including a 'TypeMap' --- inside another 'TrieMap', this is the type you want. +-- inside another 'TrieMap', this is the type you want. Note that this +-- lookup does not do a kind-check. Thus, all keys in this map must have +-- the same kind. type TypeMapG = GenMap TypeMapX -- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the @@ -927,11 +706,21 @@ type TypeMapG = GenMap TypeMapX data TypeMapX a = TM { tm_var :: VarMap a , tm_app :: TypeMapG (TypeMapG a) - , tm_fun :: TypeMapG (TypeMapG a) - , tm_tc_app :: NameEnv (ListMap TypeMapG a) + , tm_tycon :: NameEnv a , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] , tm_tylit :: TyLitMap a + , tm_coerce :: Maybe a } + -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type + +-- | squeeze out any synonyms, convert Constraint to *, and change TyConApps +-- 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 (ForAllTy (Anon arg) res) + = Just ((TyConApp funTyCon [] `AppTy` arg) `AppTy` res) +trieMapView _ = Nothing instance TrieMap TypeMapX where type Key TypeMapX = DeBruijn Type @@ -943,89 +732,99 @@ instance TrieMap TypeMapX where instance Eq (DeBruijn Type) where env_t@(D env t) == env_t'@(D env' t') - | Just new_t <- coreView t = D env new_t == env_t' - | Just new_t' <- coreView t' = env_t == D env' new_t' - | otherwise = - case (t, t') of + | Just new_t <- coreViewOneStarKind t = D env new_t == env_t' + | Just new_t' <- coreViewOneStarKind t' = env_t == D env' new_t' + | otherwise + = case (t, t') of + (CastTy t1 _, _) -> D env t1 == D env t' + (_, CastTy t1' _) -> D env t == D env t1' + (TyVarTy v, TyVarTy v') -> case (lookupCME env v, lookupCME env' v') of (Just bv, Just bv') -> bv == bv' (Nothing, Nothing) -> v == v' _ -> False - (AppTy t1 t2, AppTy t1' t2') + -- See Note [Equality on AppTys] in Type + (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' - (FunTy t1 t2, FunTy t1' t2') + (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (ForAllTy (Anon t1) t2, ForAllTy (Anon 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' (LitTy l, LitTy l') -> l == l' - (ForAllTy tv ty, ForAllTy tv' ty') + (ForAllTy (Named tv _) ty, ForAllTy (Named tv' _) ty') -> D env (tyVarKind tv) == D env' (tyVarKind tv') && D (extendCME env tv) ty == D (extendCME env' tv') ty' + (CoercionTy {}, CoercionTy {}) + -> True _ -> False -instance Outputable a => Outputable (TypeMap a) where +instance Outputable a => Outputable (TypeMapG a) where ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) emptyT :: TypeMapX a emptyT = TM { tm_var = emptyTM , tm_app = EmptyMap - , tm_fun = EmptyMap - , tm_tc_app = emptyNameEnv + , tm_tycon = emptyNameEnv , tm_forall = EmptyMap - , tm_tylit = emptyTyLitMap } + , tm_tylit = emptyTyLitMap + , tm_coerce = Nothing } mapT :: (a->b) -> TypeMapX a -> TypeMapX b -mapT f (TM { tm_var = tvar, tm_app = tapp, tm_fun = tfun - , tm_tc_app = ttcapp, tm_forall = tforall, tm_tylit = tlit }) +mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) = TM { tm_var = mapTM f tvar , tm_app = mapTM (mapTM f) tapp - , tm_fun = mapTM (mapTM f) tfun - , tm_tc_app = mapNameEnv (mapTM f) ttcapp + , tm_tycon = mapNameEnv f ttycon , tm_forall = mapTM (mapTM f) tforall - , tm_tylit = mapTM f tlit } + , tm_tylit = mapTM f tlit + , tm_coerce = fmap f tcoerce } ----------------- lkT :: DeBruijn Type -> TypeMapX a -> Maybe a lkT (D env ty) m = go ty m where - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy v) = tm_var >.> lkVar env v - go (AppTy t1 t2) = tm_app >.> lkG (D env t1) >=> lkG (D env t2) - go (FunTy t1 t2) = tm_fun >.> lkG (D env t1) >=> lkG (D env t2) - go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkG . D env) tys - go (LitTy l) = tm_tylit >.> lkTyLit l - go (ForAllTy tv ty) = tm_forall >.> lkG (D (extendCME env tv) ty) - >=> lkBndr env tv - + go ty | Just ty' <- trieMapView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkG (D env t1) + >=> lkG (D env t2) + go (TyConApp tc []) = tm_tycon >.> lkNamed tc + go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) + go (LitTy l) = tm_tylit >.> lkTyLit l + go (ForAllTy (Named tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) + >=> lkBndr env tv + go ty@(ForAllTy (Anon _) _) = pprPanic "lkT FunTy" (ppr ty) + go (CastTy t _) = go t + go (CoercionTy {}) = tm_coerce ----------------- xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a -xtT (D env ty) f m - | Just ty' <- coreView ty = xtT (D env ty') f m +xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) - |>> xtG (D env t2) f } -xtT (D env (FunTy t1 t2)) f m = m { tm_fun = tm_fun m |> xtG (D env t1) - |>> xtG (D env t2) f } -xtT (D env (ForAllTy tv ty)) f m = m { tm_forall = tm_forall m - |> xtG (D (extendCME env tv) ty) - |>> xtBndr env tv f } -xtT (D env (TyConApp tc tys)) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc - |>> xtList (xtG . D env) tys f } + |>> xtG (D env t2) f } +xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtNamed tc f } xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } +xtT (D env (CastTy t _)) f m = xtT (D env t) f m +xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } +xtT (D env (ForAllTy (Named tv _) ty)) f m + = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) + |>> xtBndr env tv f } +xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) +xtT (D _ ty@(ForAllTy (Anon _) _)) _ _ = pprPanic "xtT FunTy" (ppr ty) fdT :: (a -> b -> b) -> TypeMapX a -> b -> b fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_app m) - . foldTM (foldTM k) (tm_fun m) - . foldTM (foldTM k) (tm_tc_app m) + . foldTM k (tm_tycon m) . foldTM (foldTM k) (tm_forall m) . foldTyLit k (tm_tylit m) - - + . foldMaybe k (tm_coerce m) ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a @@ -1063,6 +862,55 @@ foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b foldTyLit l m = flip (Map.fold l) (tlm_string m) . flip (Map.fold l) (tlm_number m) +------------------------------------------------- +-- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this +-- is the type you want. The keys in this map may have different kinds. +newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) + +lkTT :: DeBruijn Type -> TypeMap a -> Maybe a +lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m + >>= lkG (D env ty) + +xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a +xtTT (D env ty) f (TypeMap m) + = TypeMap (m |> xtG (D env $ typeKind ty) + |>> xtG (D env ty) f) + +-- Below are some client-oriented functions which operate on 'TypeMap'. + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = TypeMap emptyTM + lookupTM k m = lkTT (deBruijnize k) m + alterTM k f m = xtTT (deBruijnize k) f m + foldTM k (TypeMap m) = foldTM (foldTM k) m + mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) + +foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b +foldTypeMap k z m = foldTM k m z + +emptyTypeMap :: TypeMap a +emptyTypeMap = emptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lookupTM t cm + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = alterTM t (const (Just v)) m + +-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), +-- you'll find entries inserted under (t), even if (g) is non-reflexive. +newtype LooseTypeMap a + = LooseTypeMap (TypeMapG a) + +instance TrieMap LooseTypeMap where + type Key LooseTypeMap = Type + emptyTM = LooseTypeMap emptyTM + lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m + alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) + foldTM f (LooseTypeMap m) = foldTM f m + mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) + {- ************************************************************************ * * diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 386652a5e4..d77d3786bb 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -657,7 +657,7 @@ mkOneConFull x usupply con = (con_abs, constraints) Just (tc, tys) -> ASSERT( tc == data_tc ) tys Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty) - subst1 = zipTopTvSubst univ_tvs tc_args + subst1 = zipTopTCvSubst univ_tvs tc_args (subst, ex_tvs') = cloneTyVarBndrs subst1 ex_tvs usupply1 diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 4235c5c3d1..e69cc6ef96 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -26,7 +26,6 @@ import Id import Name import Type import FamInstEnv -import Coercion import InstEnv import Class import Avail @@ -38,16 +37,20 @@ import DsMonad import DsExpr import DsBinds import DsForeign +import PrelNames ( coercibleTyConKey ) +import TysPrim ( eqReprPrimTyCon ) +import Unique ( hasKey ) +import Coercion ( mkCoVarCo ) +import TysWiredIn ( coercibleDataCon ) +import DataCon ( dataConWrapId ) +import MkCore ( mkCoreLet ) import Module import NameSet import NameEnv import Rules -import TysPrim (eqReprPrimTyCon) -import TysWiredIn (coercibleTyCon ) import BasicTypes ( Activation(.. ), competesWith, pprRuleName ) import CoreMonad ( CoreToDo(..) ) import CoreLint ( endPassIO ) -import MkCore import VarSet import FastString import ErrUtils @@ -325,7 +328,7 @@ deSugar hsc_env ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do + Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@ -629,13 +632,19 @@ unfold_coerce bndrs lhs rhs = do go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr) go [] = return ([], id) go (v:vs) - | Just (tc, args) <- splitTyConApp_maybe (idType v) - , tc == coercibleTyCon = do - let ty' = mkTyConApp eqReprPrimTyCon args - v' <- mkDerivedLocalM mkRepEqOcc v ty' + | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v) + , tc `hasKey` coercibleTyConKey = do + u <- newUnique + + let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2] + v' = mkLocalCoVar + (mkDerivedInternalName mkRepEqOcc u (getName v)) ty' + box = Var (dataConWrapId coercibleDataCon) `mkTyApps` + [k, t1, t2] `App` + Coercion (mkCoVarCo v') (bndrs, wrap) <- go vs - return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap) + return (v':bndrs, mkCoreLet (NonRec v box) . wrap) | otherwise = do (bndrs,wrap) <- go vs return (v:bndrs, wrap) @@ -650,8 +659,6 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList. That keeps the desugaring of list comprehensions simple too. - - Nor do we want to warn of conversion identities on the LHS; the rule is precisly to optimise them: {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} @@ -669,6 +676,7 @@ For that we replace any forall'ed `c :: Coercible a b` value in a RULE by corresponding `co :: a ~#R b` and wrap the LHS and the RHS in `let c = MkCoercible co in ...`. This is later simplified to the desired form by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). +See also Note [Getting the map/coerce RULE to work] in CoreSubst. Note [Rules and inlining/other rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 7735aa8e50..56c44c59d5 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -275,7 +275,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do var <- selectSimpleMatchVarL pat match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr let pat_ty = hsLPatType pat - proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty + let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) @@ -403,8 +403,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _ (GRHSs [L _ (GRHS [] body)] _ ))] })) env_ids = do + let pat_vars = mkVarSet (collectPatsBinders pats) let - pat_vars = mkVarSet (collectPatsBinders pats) local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body @@ -711,9 +711,8 @@ dsCmdDo ids local_vars res_ty [L _ (LastStmt body _ _)] env_ids = do env_ids') dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do - let - bound_vars = mkVarSet (collectLStmtBinders stmt) - local_vars' = bound_vars `unionVarSet` local_vars + let bound_vars = mkVarSet (collectLStmtBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids return (do_compose ids @@ -785,10 +784,10 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do -- but that's likely to be defined in terms of first. dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd + let pat_ty = hsLPatType pat + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd + let pat_vars = mkVarSet (collectPatBinders pat) let - pat_ty = hsLPatType pat - pat_vars = mkVarSet (collectPatBinders pat) env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars) env_ty2 = mkBigCoreVarTupTy env_ids2 @@ -1018,9 +1017,8 @@ dsCmdStmts ids local_vars out_ids [stmt] env_ids = dsCmdLStmt ids local_vars out_ids stmt env_ids dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do - let - bound_vars = mkVarSet (collectLStmtBinders stmt) - local_vars' = bound_vars `unionVarSet` local_vars + let bound_vars = mkVarSet (collectLStmtBinders stmt) + let local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids return (do_compose ids diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 724da24875..ca2d49d9e3 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -35,7 +35,6 @@ import CoreUtils import CoreArity ( etaExpand ) import CoreUnfold import CoreFVs -import UniqSupply import Digraph import PrelNames @@ -44,10 +43,8 @@ import TyCon import TcEvidence import TcType import Type -import Kind( isKind ) -import Coercion hiding (substCo) -import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy - , mkBoxedTupleTy, charTy +import Coercion +import TysWiredIn ( mkListTy, mkBoxedTupleTy, charTy , typeNatKind, typeSymbolKind ) import Id import MkId(proxyHashId) @@ -55,7 +52,6 @@ import Class import DataCon ( dataConTyCon ) import Name import IdInfo ( IdDetails(..) ) -import Var import VarSet import Rules import VarEnv @@ -70,7 +66,7 @@ import DynFlags import FastString import Util import MonadUtils -import Control.Monad(liftM,when,foldM) +import Control.Monad {-********************************************************************** * * @@ -182,7 +178,7 @@ dsHsBind dflags ; (spec_binds, rules) <- dsSpecs rhs prags - ; let global' = addIdSpecialisations global rules + ; let global' = addIdSpecialisations global rules main_bind = makeCorePair dflags global' (isDefaultMethod prags) (dictArity dicts) rhs @@ -243,12 +239,14 @@ dsHsBind dflags -- the inline pragma from the source -- The type checker put the inline pragma -- on the *global* Id, so we need to transfer it - inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) - | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports - , let prag = idInlinePragma gbl_id ] + inline_env + = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] add_inline :: Id -> Id -- tran - add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id + add_inline lcl_id = lookupVarEnv inline_env lcl_id + `orElse` lcl_id global_env :: IdEnv Id -- Maps local Id to its global exported Id global_env = @@ -797,18 +795,23 @@ decomposeRuleLhs orig_bndrs orig_lhs -- which in turn makes wrap_lets work right split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) - split_lets e - | Let (NonRec d r) body <- e - , isDictId d - , (bs, body') <- split_lets body + split_lets (Let (NonRec d r) body) + | isDictId d = ((d,r):bs, body') - | otherwise - = ([], e) + where (bs, body') = split_lets body + + -- handle "unlifted lets" too, needed for "map/coerce" + split_lets (Case r d _ [(DEFAULT, _, body)]) + | isCoVar d + = ((d,r):bs, body') + where (bs, body') = split_lets body + + split_lets e = ([], e) wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr wrap_lets _ [] body = body wrap_lets needed ((d, r) : bs) body - | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body) + | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) | otherwise = wrap_lets needed bs body where rhs_fvs = exprFreeVars r @@ -946,7 +949,6 @@ confused. Likewise it might have an InlineRule or something, which would be utterly bogus. So we really make a fresh Id, with the same unique and type as the old one, but with an Internal name and no IdInfo. - ************************************************************************ * * Desugaring evidence @@ -966,8 +968,8 @@ 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(tcCoercionRole co == Representational) - dsTcCoercion co (mkCastDs e) +dsHsWrapper (WpCast co) e = ASSERT(coercionRole co == Representational) + return $ mkCastDs e co dsHsWrapper (WpEvLam ev) e = return $ Lam ev e dsHsWrapper (WpTyLam tv) e = return $ Lam tv e dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm) @@ -985,22 +987,12 @@ dsTcEvBinds (EvBinds bs) = dsEvBinds bs dsEvBinds :: Bag EvBind -> DsM [CoreBind] dsEvBinds bs = mapM ds_scc (sccEvBinds bs) where - ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r })) + ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r})) = liftM (NonRec v) (dsEvTerm r) - ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs) - - ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) = liftM ((,) v) (dsEvTerm r) - -sccEvBinds :: Bag EvBind -> [SCC EvBind] -sccEvBinds bs = stronglyConnCompFromEdgedVertices edges - where - edges :: [(EvBind, EvVar, [EvVar])] - edges = foldrBag ((:) . mk_node) [] bs - - mk_node :: EvBind -> (EvBind, EvVar, [EvVar]) - mk_node b@(EvBind { eb_lhs = var, eb_rhs = term }) - = (b, var, varSetElems (evVarsOfTerm term)) + ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs) +dsEvBind :: EvBind -> DsM (Id, CoreExpr) +dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) {-********************************************************************** * * @@ -1017,24 +1009,24 @@ dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s dsEvTerm (EvCast tm co) = do { tm' <- dsEvTerm tm - ; dsTcCoercion co $ mkCastDs tm' } - -- 'v' is always a lifted evidence variable so it is - -- unnecessary to call varToCoreExpr v here. + ; return $ mkCastDs tm' co } dsEvTerm (EvDFunApp df tys tms) - = return (Var df `mkTyApps` tys `mkApps` (map Var tms)) - -dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions] -dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox + = do { tms' <- mapM dsEvTerm tms + ; return $ Var df `mkTyApps` tys `mkApps` tms' } +dsEvTerm (EvCoercion co) = return (Coercion co) dsEvTerm (EvSuperClass d n) = do { d' <- dsEvTerm d ; let (cls, tys) = getClassPredTys (exprType d') sc_sel_id = classSCSelId cls n -- Zero-indexed ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } -dsEvTerm (EvDelayedError ty msg) - = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] +dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg + +dsEvDelayedError :: Type -> FastString -> CoreExpr +dsEvDelayedError ty msg + = Var errorId `mkTyApps` [getLevity "dsEvTerm" ty, ty] `mkApps` [litMsg] where errorId = tYPE_ERROR_ID litMsg = Lit (MachStr (fastStringToByteString msg)) @@ -1071,10 +1063,9 @@ dsEvTypeable ty ev ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr -- Returns a CoreExpr :: TypeRep ty -ds_ev_typeable ty EvTypeableTyCon +ds_ev_typeable ty (EvTypeableTyCon evs) | Just (tc, ks) <- splitTyConApp_maybe ty - = ASSERT( all isKind ks ) - do { ctr <- dsLookupGlobalId mkPolyTyConAppName + = do { ctr <- dsLookupGlobalId mkPolyTyConAppName -- mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep ; tyRepTc <- dsLookupTyCon typeRepTyConName -- TypeRep (the TyCon) ; let tyRepType = mkTyConApp tyRepTc [] -- TypeRep (the Type) @@ -1083,15 +1074,9 @@ ds_ev_typeable ty EvTypeableTyCon , mkListExpr tyRepType kReps , mkListExpr tyRepType tReps ] - kindRep k -- Returns CoreExpr :: TypeRep for that kind k - = case splitTyConApp_maybe k of - Nothing -> panic "dsEvTypeable: not a kind constructor" - Just (kc,ks) -> do { kcRep <- tyConRep kc - ; reps <- mapM kindRep ks - ; return (mkRep kcRep [] reps) } ; tcRep <- tyConRep tc - ; kReps <- mapM kindRep ks + ; kReps <- zipWithM getRep evs ks ; return (mkRep tcRep kReps []) } ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) @@ -1213,119 +1198,3 @@ dsEvCallStack cs = do EvCsTop name loc tm -> mkPush name loc tm EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm EvCsEmpty -> panic "Cannot have an empty CallStack" - -{-********************************************************************** -* * - Desugaring Coercions -* * -**********************************************************************-} - -dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr --- This is the crucial function that moves --- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion --- e.g. dsTcCoercion (trans g1 g2) k --- = case g1 of EqBox g1# -> --- case g2 of EqBox g2# -> --- k (trans g1# g2#) --- thing_inside will get a coercion at the role requested -dsTcCoercion co thing_inside - = do { us <- newUniqueSupply - ; let eqvs_covs :: [(EqVar,CoVar)] - eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co)) - (uniqsFromSupply us) - - subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] - result_expr = thing_inside (ds_tc_coercion subst co) - result_ty = exprType result_expr - - ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) } - where - mk_co_var :: Id -> Unique -> (Id, Id) - mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc) - where - eq_nm = idName eqv - occ = nameOccName eq_nm - loc = nameSrcSpan eq_nm - ty = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2 - (ty1, ty2) = getEqPredTys (evVarPred eqv) - - wrap_in_case result_ty (eqv, cov) body - = case getEqPredRole (evVarPred eqv) of - Nominal -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)] - Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)] - Phantom -> panic "wrap_in_case/phantom" - -ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion --- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b) --- the result is of type (a ~# b) (reps. a ~# b) --- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on) --- No need for InScope set etc because the -ds_tc_coercion subst tc_co - = go tc_co - where - go (TcRefl r ty) = Refl r (Coercion.substTy subst ty) - go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos) - go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2) - go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co) - where - (subst', tv') = Coercion.substTyVarBndr subst tv - go (TcAxiomInstCo ax ind cos) - = AxiomInstCo ax ind (map go cos) - go (TcPhantomCo ty1 ty2) = UnivCo (fsLit "ds_tc_coercion") Phantom ty1 ty2 - go (TcSymCo co) = mkSymCo (go co) - go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2) - go (TcNthCo n co) = mkNthCo n (go co) - go (TcLRCo lr co) = mkLRCo lr (go co) - go (TcSubCo co) = mkSubCo (go co) - go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co - go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) - go (TcCoVarCo v) = ds_ev_id subst v - go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs) - go (TcCoercion co) = co - - ds_co_binds :: TcEvBinds -> CvSubst - ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs) - ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb) - - ds_scc :: CvSubst -> SCC EvBind -> CvSubst - ds_scc subst (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = ev_term })) - = extendCvSubstAndInScope subst v (ds_co_term subst ev_term) - ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co) - - ds_co_term :: CvSubst -> EvTerm -> Coercion - ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co - ds_co_term subst (EvId v) = ds_ev_id subst v - ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co) - ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co) - - ds_ev_id :: CvSubst -> EqVar -> Coercion - ds_ev_id subst v - | Just co <- Coercion.lookupCoVar subst v = co - | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co) - -{- -Note [Simple coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -We have a special case for coercions that are simple variables. -Suppose cv :: a ~ b is in scope -Lacking the special case, if we see - f a b cv -we'd desguar to - f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#) -which is a bit stupid. The special case does the obvious thing. - -This turns out to be important when desugaring the LHS of a RULE -(see Trac #7837). Suppose we have - normalise :: (a ~ Scalar a) => a -> a - normalise_Double :: Double -> Double - {-# RULES "normalise" normalise = normalise_Double #-} - -Then the RULE we want looks like - forall a, (cv:a~Scalar a). - normalise a cv = normalise_Double -But without the special case we generate the redundant box/unbox, -which simpleOpt (currently) doesn't remove. So the rule never matches. - -Maybe simpleOpt should be smarter. But it seems like a good plan -to simply never generate the redundant box/unbox in the first place. --} diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index f7bfa7b581..9a3fe5a220 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -21,16 +21,16 @@ module DsCCall import CoreSyn import DsMonad -import DsUtils( mkCastDs ) import CoreUtils import MkCore -import Var import MkId import ForeignCall import DataCon +import DsUtils import TcType import Type +import Id ( Id ) import Coercion import PrimOp import TysPrim @@ -101,8 +101,8 @@ dsCCall lbl args may_gc result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) mkFCall :: DynFlags -> Unique -> ForeignCall - -> [CoreExpr] -- Args - -> Type -- Result type + -> [CoreExpr] -- Args + -> Type -- Result type -> CoreExpr -- Construct the ccall. The only tricky bit is that the ccall Id should have -- no free vars, so if any of the arg tys do we must give it a polymorphic type. @@ -114,12 +114,13 @@ mkFCall :: DynFlags -> Unique -> ForeignCall -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) -- a b s x c mkFCall dflags uniq the_fcall val_args res_ty - = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args + = ASSERT( all isTyVar tyvars ) -- this must be true because the type is top-level + mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where arg_tys = map exprType val_args body_ty = (mkFunTys arg_tys res_ty) - tyvars = tyVarsOfTypeList body_ty - ty = mkForAllTys tyvars body_ty + tyvars = tyCoVarsOfTypeWellScoped body_ty + ty = mkInvForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty unboxArg :: CoreExpr -- The supplied argument @@ -226,9 +227,9 @@ boxResult result_ty _ -> [] return_result state anss - = mkCoreConApps (tupleDataCon Unboxed (2 + length extra_result_tys)) - (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) - ++ (state : anss)) + = mkCoreUbxTup + (realWorldStatePrimTy : io_res_ty : extra_result_tys) + (state : anss) ; (ccall_res_ty, the_alt) <- mk_alt return_result res @@ -274,8 +275,8 @@ mk_alt return_result (Nothing, wrap_result) the_rhs = return_result (Var state_id) [wrap_result (panic "boxResult")] - ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] - the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs) return (ccall_res_ty, the_alt) @@ -290,8 +291,7 @@ mk_alt return_result (Just prim_res_ty, wrap_result) let the_rhs = return_result (Var state_id) (wrap_result (Var result_id) : map Var as) - ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity) - (realWorldStatePrimTy : ls) + ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls) the_alt = ( DataAlt (tupleDataCon Unboxed arity) , (state_id : args_ids) , the_rhs @@ -304,8 +304,8 @@ mk_alt return_result (Just prim_res_ty, wrap_result) let the_rhs = return_result (Var state_id) [wrap_result (Var result_id)] - ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty] - the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs) return (ccall_res_ty, the_alt) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index e4c6ff8cfa..2fc3974a20 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -30,7 +30,6 @@ import Platform -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types import TcType -import Coercion ( Role(..) ) import TcEvidence import TcRnMonad import TcHsSyn @@ -45,13 +44,13 @@ import CostCentre import Id import Module import VarSet -import VarEnv import ConLike import DataCon import TysWiredIn import PrelNames import BasicTypes import Maybes +import VarEnv import SrcLoc import Util import Bag @@ -300,8 +299,7 @@ dsExpr (ExplicitTuple tup_args boxity) -- The reverse is because foldM goes left-to-right ; return $ mkCoreLams lam_vars $ - mkCoreConApps (tupleDataCon boxity (length tup_args)) - (map (Type . exprType) args ++ args) } + mkCoreTupBoxity boxity args } dsExpr (HsSCC _ cc expr@(L loc _)) = do dflags <- getDynFlags @@ -379,10 +377,10 @@ dsExpr (ExplicitPArr ty xs) = do singletonP <- dsDPHBuiltin singletonPVar appP <- dsDPHBuiltin appPVar xs' <- mapM dsLExpr xs + let unary fn x = mkApps (Var fn) [Type ty, x] + binary fn x y = mkApps (Var fn) [Type ty, x, y] + return . foldr1 (binary appP) $ map (unary singletonP) xs' - where - unary fn x = mkApps (Var fn) [Type ty, x] - binary fn x y = mkApps (Var fn) [Type ty, x, y] dsExpr (ArithSeq expr witness seq) = case witness of @@ -446,8 +444,9 @@ dsExpr (HsStatic expr@(L loc _)) = do , moduleNameFS $ moduleName $ nameModule n' , occNameFS $ nameOccName n' ] - let tvars = tyVarsOfTypeList ty - speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty] + let tvars = tyCoVarsOfTypeWellScoped ty + speTy = ASSERT( all isTyVar tvars ) -- ty is top-level, so this is OK + mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty] speId = mkExportedLocalId VanillaId n' speTy fp@(Fingerprint w0 w1) = fingerprintName $ idName speId fp_core = mkConApp fingerprintDataCon @@ -456,7 +455,7 @@ dsExpr (HsStatic expr@(L loc _)) = do ] sp = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds] liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :) - putSrcSpanDs loc $ return $ mkTyApps (Var speId) (map mkTyVarTy tvars) + putSrcSpanDs loc $ return $ mkTyApps (Var speId) (mkTyVarTys tvars) where @@ -547,13 +546,14 @@ Note [Update for GADTs] ~~~~~~~~~~~~~~~~~~~~~~~ Consider data T a b where - T1 { f1 :: a } :: T a Int + T1 :: { f1 :: a } -> T a Int Then the wrapper function for T1 has type $WT1 :: a -> T a Int But if x::T a b, then x { f1 = v } :: T a b (not T a Int!) So we need to cast (T a Int) to (T a b). Sigh. + -} dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields @@ -611,7 +611,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) + subst = mkTopTCvSubst (univ_tvs `zip` in_inst_tys) -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) @@ -628,12 +628,12 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id)) -- Reconstruct with the WrapId so that unpacking happens -- The order here is because of the order in `TcPatSyn`. - wrap = - dict_req_wrap <.> - mkWpEvVarApps theta_vars <.> - mkWpTyApps (mkTyVarTys ex_tvs) <.> - mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys - , not (tv `elemVarEnv` wrap_subst) ] + wrap = dict_req_wrap <.> + mkWpEvVarApps theta_vars <.> + mkWpTyApps (mkTyVarTys ex_tvs) <.> + mkWpTyApps [ ty + | (tv, ty) <- univ_tvs `zip` out_inst_tys + , not (tv `elemVarEnv` wrap_subst) ] rhs = foldl (\a b -> nlHsApp a b) inst_con val_args -- Tediously wrap the application in a cast @@ -659,9 +659,11 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) - | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] + | (spec, eq_var) <- eq_spec `zip` eqs_vars + , let tv = eqSpecTyVar spec ] req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys + pat = noLoc $ ConPatOut { pat_con = noLoc con , pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars @@ -669,8 +671,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields , pat_args = PrefixCon $ map nlVarPat arg_ids , pat_arg_tys = in_inst_tys , pat_wrap = req_wrap } - - ; return (mkSimpleMatch [pat] wrapped_rhs) } + ; return (mkSimpleMatch [pat] wrapped_rhs) } -- Here is where we desugar the Template Haskell brackets and escapes @@ -784,7 +785,7 @@ To test this I've added a (static) flag -fsimple-list-literals, which makes all list literals be generated via the simple route. -} -dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] +dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] dsExplicitList elt_ty Nothing xs diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 5893ae80f8..2ee93731c3 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -8,19 +8,11 @@ Desugaring foreign declarations (see also DsCCall). {-# LANGUAGE CPP #-} -module DsForeign ( dsForeigns - , dsForeigns' - , dsFImport, dsCImport, dsFCall, dsPrimCall - , dsFExport, dsFExportDynamic, mkFExportCBits - , toCType - , foreignExportInitialiser - ) where +module DsForeign ( dsForeigns ) where #include "HsVersions.h" import TcRnMonad -- temp -import TypeRep - import CoreSyn import DsCCall @@ -103,7 +95,8 @@ dsForeigns' fos = do do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) - (bs, h, c) <- dsFImport (unLoc id) co spec + let id' = unLoc id + (bs, h, c) <- dsFImport id' co spec traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) @@ -142,9 +135,8 @@ dsFImport :: Id -> Coercion -> ForeignImport -> DsM ([Binding], SDoc, SDoc) -dsFImport id co (CImport cconv safety mHeader spec _) = do - (ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader - return (ids, h, c) +dsFImport id co (CImport cconv safety mHeader spec _) = + dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader dsCImport :: Id -> Coercion @@ -155,7 +147,7 @@ dsCImport :: Id -> DsM ([Binding], SDoc, SDoc) dsCImport id co (CLabel cid) cconv _ _ = do dflags <- getDynFlags - let ty = pFst $ coercionKind co + let ty = pFst $ coercionKind co fod = case tyConAppTyCon_maybe (dropForAlls ty) of Just tycon | tyConUnique tycon == funPtrTyConKey -> @@ -185,8 +177,8 @@ fun_type_arg_stdcall_info dflags StdCallConv ty | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, tyConUnique tc == funPtrTyConKey = let - (_tvs,sans_foralls) = tcSplitForAllTys arg_ty - (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls + (bndrs, _) = tcSplitPiTys arg_ty + fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) fun_type_arg_stdcall_info _ _other_conv _ = Nothing @@ -203,9 +195,10 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) dsFCall fn_id co fcall mDeclHeader = do let - ty = pFst $ coercionKind co - (tvs, fun_ty) = tcSplitForAllTys ty - (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + ty = pFst $ coercionKind co + (all_bndrs, io_res_ty) = tcSplitPiTys ty + (named_bndrs, arg_tys) = partitionBindersIntoBinders all_bndrs + tvs = map (binderVar "dsFCall") named_bndrs -- Must use tcSplit* functions because we want to -- see that (IO t) in the corner @@ -270,7 +263,7 @@ dsFCall fn_id co fcall mDeclHeader = do return (fcall, empty) let -- Build the worker - worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) + worker_ty = mkForAllTys named_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty) the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty @@ -304,8 +297,8 @@ dsPrimCall :: Id -> Coercion -> ForeignCall dsPrimCall fn_id co fcall = do let ty = pFst $ coercionKind co - (tvs, fun_ty) = tcSplitForAllTys ty - (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + (bndrs, io_res_ty) = tcSplitPiTys ty + (tvs, arg_tys) = partitionBinders bndrs -- Must use tcSplit* functions because we want to -- see that (IO t) in the corner @@ -355,9 +348,9 @@ dsFExport :: Id -- Either the exported Id, dsFExport fn_id co ext_name cconv isDyn = do let - ty = pSnd $ coercionKind co - (_tvs,sans_foralls) = tcSplitForAllTys ty - (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls + ty = pSnd $ coercionKind co + (bndrs, orig_res_ty) = tcSplitPiTys ty + fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs -- We must use tcSplits here, because we want to see -- the (IO t) in the corner of the type! fe_arg_tys | isDyn = tail fe_arg_tys' @@ -437,7 +430,7 @@ dsFExportDynamic id co0 cconv = do export_ty = mkFunTy stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName stbl_value <- newSysLocalDs stable_ptr_ty - (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True + (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True let {- The arguments to the external function which will @@ -482,11 +475,12 @@ dsFExportDynamic id co0 cconv = do where ty = pFst (coercionKind co0) - (tvs,sans_foralls) = tcSplitForAllTys ty - ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + (bndrs, fn_res_ty) = tcSplitPiTys ty + (tvs, [arg_ty]) = partitionBinders bndrs Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty -- Must have an IO type; hence Just + toCName :: DynFlags -> Id -> String toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) @@ -717,7 +711,7 @@ toCType = f False -- see if there is a C type associated with that constructor. -- Note that we aren't looking through type synonyms or -- anything, as it may be the synonym that is annotated. - | TyConApp tycon _ <- t + | Just tycon <- tyConAppTyConPicky_maybe t , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon = (mHeader, ftext cType) -- If we don't know a C type for this type, then try looking diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 352534bb17..6b1b342058 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -19,12 +19,12 @@ import HsSyn import MkCore import CoreSyn import Var -import Type import DsMonad import DsUtils import TysWiredIn import PrelNames +import Type ( Type ) import Module import Name import Util @@ -140,7 +140,8 @@ isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey -- trueDataConId doesn't have the same unique as trueDataCon isTrueLHsExpr (L _ (HsTick tickish e)) | Just ticks <- isTrueLHsExpr e - = Just (\x -> ticks x >>= return . (Tick tickish)) + = Just (\x -> do wrapped <- ticks x + return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out. isTrueLHsExpr (L _ (HsBinTick ixT _ e)) diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 4d11fa21b8..d835995857 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -81,11 +81,13 @@ dsListComp lquals res_ty = do -- and the type of the elements that it outputs (tuples of binders) dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) dsInnerListComp (ParStmtBlock stmts bndrs _) - = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) + = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs + + -- really use original bndrs below! + ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) (mkListTy bndrs_tuple_type) + ; return (expr, bndrs_tuple_type) } - where - bndrs_tuple_type = mkBigCoreVarTupTy bndrs -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed @@ -94,47 +96,50 @@ dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id) dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap , trS_by = by, trS_using = using }) = do let (from_bndrs, to_bndrs) = unzip binderMap - from_bndrs_tys = map idType from_bndrs + + let from_bndrs_tys = map idType from_bndrs to_bndrs_tys = map idType to_bndrs + to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments usingExpr' <- dsLExpr using - usingArgs <- case by of - Nothing -> return [expr] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam <- matchTuple from_bndrs by_e' - ; return [lam, expr] } + usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } -- Create an unzip function for the appropriate arity and element types and find "map" - unzip_stuff <- mkUnzipBind form from_bndrs_tys + unzip_stuff' <- mkUnzipBind form from_bndrs_tys map_id <- dsLookupGlobalId mapName -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list - inner_list_expr = mkApps usingExpr' usingArgs + inner_list_expr' = mkApps usingExpr' usingArgs' -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and -- the "b" to be a tuple of "to" lists! -- Then finally we bind the unzip function around that expression - bound_unzipped_inner_list_expr - = case unzip_stuff of - Nothing -> inner_list_expr - Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $ - mkApps (Var map_id) $ - [ Type (mkListTy from_tup_ty) - , Type to_bndrs_tup_ty - , Var unzip_fn - , inner_list_expr] + bound_unzipped_inner_list_expr' + = case unzip_stuff' of + Nothing -> inner_list_expr' + Just (unzip_fn', unzip_rhs') -> + Let (Rec [(unzip_fn', unzip_rhs')]) $ + mkApps (Var map_id) $ + [ Type (mkListTy from_tup_ty) + , Type to_bndrs_tup_ty + , Var unzip_fn' + , inner_list_expr' ] -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold lists rather than single values - let pat = mkBigLHsVarPatTupId to_bndrs - return (bound_unzipped_inner_list_expr, pat) + let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! + return (bound_unzipped_inner_list_expr', pat) dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" @@ -260,13 +265,12 @@ deBindComp :: OutPat Id -> CoreExpr -> DsM (Expr Id) deBindComp pat core_list1 quals core_list2 = do - let - u3_ty@u1_ty = exprType core_list1 -- two names, same thing + let u3_ty@u1_ty = exprType core_list1 -- two names, same thing -- u1_ty is a [alpha] type, and u2_ty = alpha - u2_ty = hsLPatType pat + let u2_ty = hsLPatType pat - res_ty = exprType core_list2 + let res_ty = exprType core_list2 h_ty = u1_ty `mkFunTy` res_ty [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] @@ -309,9 +313,9 @@ TE[ e | p <- l , q ] c n = let \end{verbatim} -} -dfListComp :: Id -> Id -- 'c' and 'n' - -> [ExprStmt Id] -- the rest of the qual's - -> DsM CoreExpr +dfListComp :: Id -> Id -- 'c' and 'n' + -> [ExprStmt Id] -- the rest of the qual's + -> DsM CoreExpr dfListComp _ _ [] = panic "dfListComp" @@ -355,7 +359,7 @@ dfBindComp :: Id -> Id -- 'c' and 'n' dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type let x_ty = hsLPatType pat - b_ty = idType n_id + let b_ty = idType n_id -- create some new local id's [b, x] <- newSysLocalsDs [b_ty, x_ty] @@ -570,7 +574,7 @@ dePArrComp (BindStmt p e _ _ : qs) pa cea = do -- dePArrComp (LetStmt (L _ ds) : qs) pa cea = do mapP <- dsDPHBuiltin mapPVar - let xs = collectLocalBinders ds + let xs = collectLocalBinders ds ty'cea = parrElemType cea v <- newSysLocalDs ty'cea clet <- dsLocalBinds ds (mkCoreTup (map Var xs)) @@ -629,10 +633,10 @@ dePArrParComp qss quals = do -- generate Core corresponding to `\p -> e' -- -deLambda :: Type -- type of the argument - -> LPat Id -- argument pattern - -> LHsExpr Id -- body - -> DsM (CoreExpr, Type) +deLambda :: Type -- type of the argument + -> LPat Id -- argument pattern + -> LHsExpr Id -- body + -> DsM (CoreExpr, Type) deLambda ty p e = mkLambda ty p =<< dsLExpr e @@ -720,37 +724,39 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs , trS_ret = return_op, trS_bind = bind_op , trS_fmap = fmap_op, trS_form = form }) stmts_rest = do { let (from_bndrs, to_bndrs) = unzip bndrs - from_bndr_tys = map idType from_bndrs -- Types ty + + ; let from_bndr_tys = map idType from_bndrs -- Types ty + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - ; expr <- dsInnerMonadComp stmts from_bndrs return_op + ; expr' <- dsInnerMonadComp stmts from_bndrs return_op -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments ; usingExpr' <- dsLExpr using - ; usingArgs <- case by of - Nothing -> return [expr] - Just by_e -> do { by_e' <- dsLExpr by_e - ; lam <- matchTuple from_bndrs by_e' - ; return [lam, expr] } + ; usingArgs' <- case by of + Nothing -> return [expr'] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam' <- matchTuple from_bndrs by_e' + ; return [lam', expr'] } -- Generate the expressions to build the grouped list -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold monads rather than single values ; bind_op' <- dsExpr bind_op - ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2 - n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c) - tup_n_ty = mkBigCoreVarTupTy to_bndrs - - ; body <- dsMcStmts stmts_rest - ; n_tup_var <- newSysLocalDs n_tup_ty - ; tup_n_var <- newSysLocalDs tup_n_ty - ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys - ; us <- newUniqueSupply - ; let rhs' = mkApps usingExpr' usingArgs - body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr - - ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) } + ; let bind_ty' = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2 + n_tup_ty' = funArgTy $ funArgTy $ funResultTy bind_ty' -- n (a,b,c) + tup_n_ty' = mkBigCoreVarTupTy to_bndrs + + ; body <- dsMcStmts stmts_rest + ; n_tup_var' <- newSysLocalDs n_tup_ty' + ; tup_n_var' <- newSysLocalDs tup_n_ty' + ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys + ; us <- newUniqueSupply + ; let rhs' = mkApps usingExpr' usingArgs' + body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' + + ; return (mkApps bind_op' [rhs', Lam n_tup_var' body']) } -- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel -- statements, for example: diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d833baf1eb..ab8c227e5c 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -43,7 +43,6 @@ import NameEnv import TcType import TyCon import TysWiredIn -import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import CoreSyn import MkCore import CoreUtils @@ -187,10 +186,10 @@ hsSigTvBinders binds -- We need the implicit ones for f :: forall (a::k). blah -- here 'k' scopes too get_scoped_tvs (L _ (TypeSig _ sig)) - | HsIB { hsib_kvs = implicit_kvs, hsib_tvs = implicit_tvs + | HsIB { hsib_vars = implicit_vars , hsib_body = sig1 } <- sig - , (explicit_tvs, _) <- splitLHsForAllTy (hswc_body sig1) - = implicit_kvs ++ implicit_tvs ++ map hsLTyVarName explicit_tvs + , (explicit_vars, _) <- splitLHsForAllTy (hswc_body sig1) + = implicit_vars ++ map hsLTyVarName explicit_vars get_scoped_tvs _ = [] sigs = case binds of @@ -255,7 +254,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn } = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; tc_tvs <- mk_extra_tvs tc tvs defn ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> - repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn + repDataDefn tc1 bndrs Nothing (map hsLTyVarName $ hsQTvExplicit tc_tvs) defn ; return (Just (loc, dec)) } repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, @@ -323,7 +322,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name - mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } + mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs } resTyVar = case resultSig of TyVarSig bndr -> mkHsQTvs [bndr] _ -> mkHsQTvs [] @@ -408,7 +407,7 @@ mk_extra_tvs :: Located Name -> LHsQTyVars Name mk_extra_tvs tc tvs defn | HsDataDefn { dd_kindSig = Just hs_kind } <- defn = do { extra_tvs <- go hs_kind - ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) } + ; return (tvs { hsq_explicit = hsq_explicit tvs ++ extra_tvs }) } | otherwise = return tvs where @@ -422,7 +421,7 @@ mk_extra_tvs tc tvs defn ; return (hs_tv : hs_tvs) } go (L _ (HsTyVar (L _ n))) - | n == liftedTypeKindTyConName + | isLiftedTypeKindTyConName n = return [] go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc) @@ -495,12 +494,11 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ; repTySynInst tc eqn1 } repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsIB { hsib_body = tys - , hsib_kvs = kv_names - , hsib_tvs = tv_names } - , tfe_rhs = rhs })) - = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names - , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk +repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys + , hsib_vars = var_names } + , tfe_rhs = rhs })) + = do { let hs_tvs = HsQTvs { hsq_implicit = var_names + , hsq_explicit = [] } -- Yuk ; addTyClTyVarBinds hs_tvs $ \ _ -> do { tys1 <- repLTys tys ; tys2 <- coreList typeQTyConName tys1 @@ -509,14 +507,14 @@ repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsIB { hsib_body = tys repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name - , dfid_pats = HsIB { hsib_body = tys, hsib_kvs = kv_names, hsib_tvs = tv_names } + , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names } , dfid_defn = defn }) = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let loc = getLoc tc_name - hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk + ; let hs_tvs = HsQTvs { hsq_implicit = var_names + , hsq_explicit = [] } -- Yuk ; addTyClTyVarBinds hs_tvs $ \ bndrs -> do { tys1 <- repList typeQTyConName repLTy tys - ; repDataDefn tc bndrs (Just tys1) tv_names defn } } + ; repDataDefn tc bndrs (Just tys1) var_names defn } } repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ @@ -589,8 +587,8 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ruleBndrNames :: LRuleBndr Name -> [Name] ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] ruleBndrNames (L _ (RuleBndrSig n sig)) - | HsIB { hsib_kvs = kvs, hsib_tvs = tvs } <- sig - = unLoc n : kvs ++ tvs + | HsIB { hsib_vars = vars } <- sig + = unLoc n : vars repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) repRuleBndr (L _ (RuleBndr n)) @@ -636,8 +634,8 @@ repC _ (L _ (ConDeclH98 { con_name = con = do { let (eq_ctxt, con_tv_subst) = ([], []) ; let con_tvs = fromMaybe (HsQTvs [] []) mcon_tvs ; let ctxt = unLoc $ fromMaybe (noLoc []) mcxt - ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs) - , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) } + ; let ex_tvs = HsQTvs { hsq_implicit = filterOut (in_subst con_tv_subst) (hsq_implicit con_tvs) + , hsq_explicit = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_explicit con_tvs) } ; let binds = [] ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs @@ -645,22 +643,21 @@ repC _ (L _ (ConDeclH98 { con_name = con do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] ; c' <- repConstr con1 details ; ctxt' <- repContext (eq_ctxt ++ ctxt) - ; if (null (hsq_kvs ex_tvs) && null (hsq_tvs ex_tvs) + ; if (null (hsq_implicit ex_tvs) && null (hsq_explicit ex_tvs) && null (eq_ctxt ++ ctxt)) then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ [unC c']) } ; return [b] } repC tvs (L _ (ConDeclGADT { con_names = cons - , con_type = res_ty@(HsIB { hsib_kvs = con_kvs - , hsib_tvs = con_tvns })})) + , con_type = res_ty@(HsIB { hsib_vars = con_vars })})) = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty - ; let con_tvs = map (noLoc . UserTyVar . noLoc) con_tvns ; let ex_tvs - = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) con_kvs - , hsq_tvs = filterOut - (in_subst con_tv_subst . hsLTyVarName) - con_tvs } + = HsQTvs { hsq_implicit = [] + , hsq_explicit = map (noLoc . UserTyVar . noLoc) $ + filterOut + (in_subst con_tv_subst) + con_vars } ; binds <- mapM dupBinder con_tv_subst ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs @@ -774,7 +771,7 @@ repDerivs (Just (L _ ctxt)) rep_deriv :: LHsType Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form rep_deriv ty - | Just (L _ cls, []) <- splitLHsClassTy_maybe ty + | Just (L _ cls, []) <- hsTyGetAppHead_maybe ty = lookupOcc cls | otherwise = notHandled "Non-H98 deriving clause" (ppr ty) @@ -820,7 +817,7 @@ rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name -- We must special-case the top-level explicit for-all of a TypeSig -- See Note [Scoped type variables in bindings] rep_wc_ty_sig mk_sig loc sig_ty nm - | HsIB { hsib_tvs = implicit_tvs, hsib_body = sig1 } <- sig_ty + | HsIB { hsib_vars = implicit_tvs, hsib_body = sig1 } <- sig_ty , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1) = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) @@ -906,7 +903,7 @@ addTyVarBinds :: LHsQTyVars Name -- the binders to be -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m +addTyVarBinds (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) m = do { fresh_kv_names <- mkGenSyms kvs ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs) ; let fresh_names = fresh_kv_names ++ fresh_tv_names @@ -927,14 +924,14 @@ addTyClTyVarBinds :: LHsQTyVars Name -- type W (T a) = blah -- The 'a' in the type instance is the one bound by the instance decl addTyClTyVarBinds tvs m - = do { let tv_names = hsLKiTyVarNames tvs + = do { let tv_names = hsAllLTyVarNames tvs ; env <- dsGetMetaEnv ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) -- Make fresh names for the ones that are not already in scope -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs) + do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs) ; m kbs } ; wrapGenSyms freshNames term } @@ -972,17 +969,16 @@ repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) repHsSigType ty = repLTy (hsSigType ty) repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) -repHsSigWcType (HsIB { hsib_kvs = implicit_kvs - , hsib_tvs = implicit_tvs +repHsSigWcType (HsIB { hsib_vars = vars , hsib_body = sig1 }) | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1) - = addTyVarBinds (HsQTvs { hsq_kvs = implicit_kvs - , hsq_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs - ++ explicit_tvs }) + = addTyVarBinds (HsQTvs { hsq_implicit = [] + , hsq_explicit = map (noLoc . UserTyVar . noLoc) vars ++ + explicit_tvs }) $ \ th_tvs -> do { th_ctxt <- repLContext ctxt ; th_ty <- repLTy ty - ; if null implicit_tvs && null explicit_tvs && null (unLoc ctxt) + ; if null vars && null explicit_tvs && null (unLoc ctxt) then return th_ty else repTForall th_tvs th_ctxt th_ty } @@ -1000,7 +996,7 @@ repForall :: HsType Name -> DsM (Core TH.TypeQ) -- Arg of repForall is always HsForAllTy or HsQualTy repForall ty | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) - = addTyVarBinds (HsQTvs { hsq_kvs = [], hsq_tvs = tvs}) $ \bndrs -> + = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs}) $ \bndrs -> do { ctxt1 <- repLContext ctxt ; ty1 <- repLTy tau ; repTForall bndrs ctxt1 ty1 } @@ -1013,7 +1009,8 @@ repTy (HsTyVar (L _ n)) | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n - repPromotedTyCon tc1 + repPromotedDataCon tc1 + | n == eqTyConName = repTequality | otherwise = do tc1 <- lookupOcc n repNamedTyCon tc1 where @@ -1043,7 +1040,7 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) +repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy t) = repLTy t repTy (HsEqTy t1 t2) = do @@ -1097,8 +1094,8 @@ repNonArrowLKind (L _ ki) = repNonArrowKind ki repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) repNonArrowKind (HsTyVar (L _ name)) - | name == liftedTypeKindTyConName = repKStar - | name == constraintKindTyConName = repKConstraint + | isLiftedTypeKindTyConName name = repKStar + | name `hasKey` constraintKindTyConKey = repKConstraint | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar | otherwise = lookupOcc name >>= repKCon repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f @@ -2124,8 +2121,8 @@ repArrowTyCon = rep2 arrowTName [] repListTyCon :: DsM (Core TH.TypeQ) repListTyCon = rep2 listTName [] -repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) -repPromotedTyCon (MkC s) = rep2 promotedTName [s] +repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ) +repPromotedDataCon (MkC s) = rep2 promotedTName [s] repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) repPromotedTupleTyCon i = do dflags <- getDynFlags diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index e33af7ce2c..20bae1fa05 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -310,7 +310,7 @@ it easier to read debugging output. -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Id -> Type -> DsM Id -newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id))) +newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local @@ -322,8 +322,8 @@ newPredVarDs pred = newSysLocalDs pred newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDs = mkSysLocalM (fsLit "ds") -newFailLocalDs = mkSysLocalM (fsLit "fail") +newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") +newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail") newSysLocalsDs :: [Type] -> DsM [Id] newSysLocalsDs tys = mapM newSysLocalDs tys diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 6bc750e97c..053fc13207 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -44,7 +44,6 @@ import {-# SOURCE #-} Match ( matchSimply ) import HsSyn import TcHsSyn -import Coercion( Coercion, isReflCo ) import TcType( tcSplitTyConApp ) import CoreSyn import DsMonad @@ -60,6 +59,7 @@ import ConLike import DataCon import PatSyn import Type +import Coercion import TysPrim import TysWiredIn import BasicTypes @@ -253,10 +253,10 @@ mkGuardedMatchResult pred_expr (MatchResult _ body_fn) = MatchResult CanFail (\fail -> do body <- body_fn fail return (mkIfThenElse pred_expr body fail)) -mkCoPrimCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of the case - -> [(Literal, MatchResult)] -- Alternatives - -> MatchResult -- Literals are all unlifted +mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of the case + -> [(Literal, MatchResult)] -- Alternatives + -> MatchResult -- Literals are all unlifted mkCoPrimCaseMatchResult var ty match_alts = MatchResult CanFail mk_case where @@ -271,7 +271,7 @@ mkCoPrimCaseMatchResult var ty match_alts return (LitAlt lit, [], body) data CaseAlt a = MkCaseAlt{ alt_pat :: a, - alt_bndrs :: [CoreBndr], + alt_bndrs :: [Var], alt_wrapper :: HsWrapper, alt_result :: MatchResult } @@ -341,7 +341,8 @@ sort_alts = sortWith (dataConTag . alt_pat) mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do - matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty] + matcher <- dsLExpr $ mkLHsWrap wrapper $ + nlHsTyApp matcher [getLevity "mkPatSynCase" ty, ty] let MatchResult _ mkCont = match_result cont <- mkCoreLams bndrs <$> mkCont fail return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] @@ -467,7 +468,7 @@ mkErrorAppDs err_id ty msg = do full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# - return (mkApps (Var err_id) [Type ty, core_msg]) + return (mkApps (Var err_id) [Type (getLevity "mkErrorAppDs" ty), Type ty, core_msg]) {- 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. @@ -633,7 +634,8 @@ mkSelectorBinds is_strict ticks pat val_expr = return (Nothing, []) | isSingleton binders || is_simple_lpat pat -- See Note [mkSelectorBinds] - = do { val_var <- newSysLocalDs (hsLPatType pat) + = do { let pat_ty = hsLPatType pat + ; val_var <- newSysLocalDs pat_ty -- Make up 'v' in Note [mkSelectorBinds] -- NB: give it the type of *pattern* p, not the type of the *rhs* e. -- This does not matter after desugaring, but there's a subtle @@ -651,7 +653,7 @@ mkSelectorBinds is_strict ticks pat val_expr -- But we need it at different types, so we make it polymorphic: -- err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah" ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat) - ; err_var <- newSysLocalDs (mkForAllTy alphaTyVar alphaTy) + ; err_var <- newSysLocalDs (mkInvForAllTys [alphaTyVar] alphaTy) ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders ; return (Just val_var ,(val_var, val_expr) : diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 3910250bc7..6ffa25dbc9 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -35,6 +35,7 @@ import PatSyn import MatchCon import MatchLit import Type +import Coercion ( eqCoercion ) import TcType ( toTcTypeBag ) import TyCon( isNewTyCon ) import TysWiredIn @@ -246,7 +247,8 @@ matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) = do { let CoPat co pat _ = firstPat eqn1 - ; var' <- newUniqueId var (hsPatType pat) + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var pat_ty' ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getCoPat) eqns ; rhs' <- dsHsWrapper co (Var var) @@ -261,7 +263,8 @@ matchView (var:vars) ty (eqns@(eqn1:_)) -- to figure out the type of the fresh variable let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 -- do the rest of the compilation - ; var' <- newUniqueId var (hsPatType pat) + ; let pat_ty' = hsPatType pat + ; var' <- newUniqueId var pat_ty' ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getViewPat) eqns -- compile the view expressions @@ -930,7 +933,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 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 (WpCast co) (WpCast co') = co `eq_co` co' + 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' -- Enhancement: could implement equality for more wrappers @@ -940,7 +943,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 --------- ev_term :: EvTerm -> EvTerm -> Bool ev_term (EvId a) (EvId b) = a==b - ev_term (EvCoercion a) (EvCoercion b) = a `eq_co` b + ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b ev_term _ _ = False --------- @@ -950,15 +953,6 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list _ (_:_) [] = False eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys - --------- - eq_co :: TcCoercion -> TcCoercion -> Bool - -- Just some simple cases (should the r1 == r2 rather be an ASSERT?) - eq_co (TcRefl r1 t1) (TcRefl r2 t2) = r1 == r2 && eqType t1 t2 - eq_co (TcCoVarCo v1) (TcCoVarCo v2) = v1==v2 - eq_co (TcSymCo co1) (TcSymCo co2) = co1 `eq_co` co2 - eq_co (TcTyConAppCo r1 tc1 cos1) (TcTyConAppCo r2 tc2 cos2) = r1 == r2 && tc1==tc2 && eq_list eq_co cos1 cos2 - eq_co _ _ = False - patGroup :: DynFlags -> Pat Id -> PatGroup patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 30f1347e25..73b6ec300b 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -119,7 +119,35 @@ matchOneConLike :: [Id] -> [EquationInfo] -> DsM (CaseAlt ConLike) matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { arg_vars <- selectConMatchVars val_arg_tys args1 + = do { let inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) + arg_tys ++ mkTyVarTys tvs1 + + val_arg_tys = conLikeInstOrigArgTys con1 inst_tys + -- dataConInstOrigArgTys takes the univ and existential tyvars + -- and returns the types of the *value* args, which is what we want + + match_group :: [Id] + -> [(ConArgPats, EquationInfo)] -> DsM MatchResult + -- All members of the group have compatible ConArgPats + match_group arg_vars arg_eqn_prs + = ASSERT( notNull arg_eqn_prs ) + do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) + ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs + ; match_result <- match (group_arg_vars ++ vars) ty eqns' + ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } + + shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, + pat_binds = bind, pat_args = args + } : pats })) + = do ds_bind <- dsTcEvBinds bind + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats } + ) + shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) + + ; arg_vars <- selectConMatchVars val_arg_tys args1 -- Use the first equation as a source of -- suggestions for the new variables @@ -140,36 +168,11 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = firstPat eqn1 fields1 = map flSelector (conLikeFieldLabels con1) - val_arg_tys = conLikeInstOrigArgTys con1 inst_tys - inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) - arg_tys ++ mkTyVarTys tvs1 - -- dataConInstOrigArgTys takes the univ and existential tyvars - -- and returns the types of the *value* args, which is what we want - ex_tvs = conLikeExTyVars con1 - match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult - -- All members of the group have compatible ConArgPats - match_group arg_vars arg_eqn_prs - = ASSERT( notNull arg_eqn_prs ) - do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) - ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs - ; match_result <- match (group_arg_vars ++ vars) ty eqns' - ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } - - shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, - pat_binds = bind, pat_args = args - } : pats })) - = do ds_bind <- dsTcEvBinds bind - return ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets ds_bind - , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats } - ) - shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) - -- Choose the right arg_vars in the right order for this group -- Note [Record patterns] + select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id] select_arg_vars arg_vars ((arg_pats, _) : _) | RecCon flds <- arg_pats , let rpats = rec_flds flds @@ -208,9 +211,9 @@ selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDs arg_tys selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] -conArgPats :: [Type] -- Instantiated argument types - -- Used only to fill in the types of WildPats, which - -- are probably never looked at anyway +conArgPats :: [Type] -- Instantiated argument types + -- Used only to fill in the types of WildPats, which + -- are probably never looked at anyway -> ConArgPats -> [Pat Id] conArgPats _arg_tys (PrefixCon ps) = map unLoc ps @@ -280,4 +283,5 @@ Originally I tried to use (\b -> let e = d in expr2) a to do this substitution. While this is "correct" in a way, it fails Lint, because e::Ord b but d::Ord a. + -} diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 16528d4de5..243665b43e 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -25,7 +25,9 @@ import SrcLoc import FastString -- sLit import VarSet +#if __GLASGOW_HASKELL__ < 709 import Data.Functor ((<$>)) +#endif import Data.Maybe (mapMaybe) import Data.List (groupBy, sortBy, nubBy) import Control.Monad.Trans.State.Lazy diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 1710321fd4..f053f79421 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -439,7 +439,7 @@ Library CoAxiom Kind Type - TypeRep + TyCoRep Unify Bag Binary diff --git a/compiler/ghc.mk b/compiler/ghc.mk index bcf45281ac..dc22eb6ac5 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -590,7 +590,7 @@ compiler_stage2_dll0_MODULES = \ TrieMap \ TyCon \ Type \ - TypeRep \ + TyCoRep \ TysPrim \ TysWiredIn \ Unify \ diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 3091a453cd..f331214892 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -57,6 +57,7 @@ import UniqSupply import BreakArray import Data.Maybe import Module +import Control.Arrow ( second ) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS @@ -77,7 +78,7 @@ byteCodeGen :: DynFlags byteCodeGen dflags this_mod binds tycs modBreaks = do showPass dflags "ByteCodeGen" - let flatBinds = [ (bndr, freeVars rhs) + let flatBinds = [ (bndr, simpleFreeVars rhs) | (bndr, rhs) <- flattenBinds binds] us <- mkSplitUniqSupply 'y' @@ -91,6 +92,7 @@ byteCodeGen dflags this_mod binds tycs modBreaks "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) assembleBCOs dflags proto_bcos tycs + where -- ----------------------------------------------------------------------------- -- Generating byte code for an expression @@ -114,7 +116,7 @@ coreExprToBCOs dflags this_mod expr us <- mkSplitUniqSupply 'y' (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco) <- runBc dflags us this_mod emptyModBreaks $ - schemeTopBind (invented_id, freeVars expr) + schemeTopBind (invented_id, simpleFreeVars expr) when (notNull mallocd) (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") @@ -124,6 +126,31 @@ coreExprToBCOs dflags this_mod expr assembleBCO dflags proto_bco +-- The regular freeVars function gives more information than is useful to +-- us here. simpleFreeVars does the impedence matching. +simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet +simpleFreeVars = go . freeVars + where + go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet + go (ann, e) = (freeVarsOfAnn ann, go' e) + + go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet + go' (AnnVar id) = AnnVar id + go' (AnnLit lit) = AnnLit lit + go' (AnnLam bndr body) = AnnLam bndr (go body) + go' (AnnApp fun arg) = AnnApp (go fun) (go arg) + go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts) + go' (AnnLet bind body) = AnnLet (go_bind bind) (go body) + go' (AnnCast expr (ann, co)) = AnnCast (go expr) (freeVarsOfAnn ann, co) + go' (AnnTick tick body) = AnnTick tick (go body) + go' (AnnType ty) = AnnType ty + go' (AnnCoercion co) = AnnCoercion co + + go_alt (con, args, expr) = (con, args, go expr) + + go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs) + go_bind (AnnRec pairs) = AnnRec (map (second go) pairs) + -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index ccd7f16e0e..2b9e732c4b 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -53,7 +53,7 @@ pprintClosureCommand bindThings force str = do let ids = [id | AnId id <- tythings] -- Obtain the terms and the recovered type information - (subst, terms) <- mapAccumLM go emptyTvSubst ids + (subst, terms) <- mapAccumLM go emptyTCvSubst ids -- Apply the substitutions obtained after recovering the types modifySession $ \hsc_env -> @@ -69,7 +69,7 @@ pprintClosureCommand bindThings force str = do docterms) where -- Do the obtainTerm--bindSuspensions-computeSubstitution dance - go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term) + go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) go subst id = do let id' = id `setIdType` substTy subst (idType id) term_ <- GHC.obtainTermFromId maxBound force id' @@ -88,13 +88,13 @@ pprintClosureCommand bindThings force str = do Just subst' -> do { traceOptIf Opt_D_dump_rtti (fsep $ [text "RTTI Improvement for", ppr id, text "is the substitution:" , ppr subst']) - ; return (subst `unionTvSubst` subst', term')} + ; return (subst `unionTCvSubst` subst', term')} tidyTermTyVars :: GhcMonad m => Term -> m Term tidyTermTyVars t = withSession $ \hsc_env -> do - let env_tvs = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env - my_tvs = termTyVars t + let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env + my_tvs = termTyCoVars t tvs = env_tvs `minusVarSet` my_tvs tyvarOccName = nameOccName . tyVarName tidyEnv = (initTidyOccEnv (map tyvarOccName (varSetElems tvs)) diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index a7695fe537..d1ff9134ec 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -31,16 +31,16 @@ import Data.List -- > Package:Module.Name -- -- We use this string to lookup the interpreter's internal representation of the name --- using the lookupOrig. +-- using the lookupOrig. -- dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) -dataConInfoPtrToName x = do +dataConInfoPtrToName x = do dflags <- getDynFlags theString <- liftIO $ do let ptr = castPtr x :: Ptr StgInfoTable conDescAddress <- getConDescAddress dflags ptr - peekArray0 0 conDescAddress - let (pkg, mod, occ) = parse theString + peekArray0 0 conDescAddress + let (pkg, mod, occ) = parse theString pkgFS = mkFastStringByteList pkg modFS = mkFastStringByteList mod occFS = mkFastStringByteList occ @@ -51,14 +51,14 @@ dataConInfoPtrToName x = do where - {- To find the string in the constructor's info table we need to consider + {- To find the string in the constructor's info table we need to consider the layout of info tables relative to the entry code for a closure. An info table can be next to the entry code for the closure, or it can - be separate. The former (faster) is used in registerised versions of ghc, - and the latter (portable) is for non-registerised versions. + be separate. The former (faster) is used in registerised versions of ghc, + and the latter (portable) is for non-registerised versions. - The diagrams below show where the string is to be found relative to + The diagrams below show where the string is to be found relative to the normal info table of the closure. 1) Code next to table: @@ -70,11 +70,11 @@ dataConInfoPtrToName x = do | | | | -------------- - | entry code | + | entry code | | .... | In this case the pointer to the start of the string can be found in - the memory location _one word before_ the first entry in the normal info + the memory location _one word before_ the first entry in the normal info table. 2) Code NOT next to table: @@ -82,9 +82,9 @@ dataConInfoPtrToName x = do -------------- info table structure -> | *------------------> -------------- | | | entry code | - | | | .... | + | | | .... | -------------- - ptr to start of str -> | | + ptr to start of str -> | | -------------- In this case the pointer to the start of the string can be found @@ -101,7 +101,7 @@ dataConInfoPtrToName x = do return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString | otherwise = peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) - -- parsing names is a little bit fiddly because we have a string in the form: + -- parsing names is a little bit fiddly because we have a string in the form: -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas @@ -109,12 +109,12 @@ dataConInfoPtrToName x = do -- convention, even though it makes the parsing code more troublesome. -- Warning: this code assumes that the string is well formed. parse :: [Word8] -> ([Word8], [Word8], [Word8]) - parse input + parse input = ASSERT(all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) where dot = fromIntegral (ord '.') - (pkg, rest1) = break (== fromIntegral (ord ':')) input - (mod, occ) + (pkg, rest1) = break (== fromIntegral (ord ':')) input + (mod, occ) = (concat $ intersperse [dot] $ reverse modWords, occWord) where (modWords, occWord) = ASSERT(length rest1 > 0) (parseModOcc [] (tail rest1)) diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 1ec127e35b..015126fae9 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -15,7 +15,7 @@ module RtClosureInspect( Term(..), isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap, isFullyEvaluated, isFullyEvaluatedTerm, - termType, mapTermType, termTyVars, + termType, mapTermType, termTyCoVars, foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold, pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter, @@ -311,14 +311,14 @@ mapTermTypeM f = foldTermM TermFoldM { fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} -termTyVars :: Term -> TyVarSet -termTyVars = foldTerm TermFold { +termTyCoVars :: Term -> TyCoVarSet +termTyCoVars = foldTerm TermFold { fTerm = \ty _ _ tt -> - tyVarsOfType ty `plusVarEnv` concatVarEnv tt, - fSuspension = \_ ty _ _ -> tyVarsOfType ty, + tyCoVarsOfType ty `plusVarEnv` concatVarEnv tt, + fSuspension = \_ ty _ _ -> tyCoVarsOfType ty, fPrim = \ _ _ -> emptyVarEnv, - fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t, - fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t} + fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `plusVarEnv` t, + fRefWrap = \ty t -> tyCoVarsOfType ty `plusVarEnv` t} where concatVarEnv = foldr plusVarEnv emptyVarEnv ---------------------------------- @@ -599,10 +599,14 @@ liftTcM = id newVar :: Kind -> TR TcType newVar = liftTcM . newFlexiTyVarTy -instTyVars :: [TyVar] -> TR (TvSubst, [TcTyVar]) +newOpenVar :: TR TcType +newOpenVar = liftTcM newOpenFlexiTyVarTy + +instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) -- Instantiate fresh mutable type variables from some TyVars -- This function preserves the print-name, which helps error messages -instTyVars = liftTcM . tcInstTyVars +instTyVars tvs + = liftTcM $ fst <$> captureConstraints (tcInstTyVars tvs) type RttiInstantiation = [(TcTyVar, TyVar)] -- Associates the typechecker-world meta type variables @@ -616,9 +620,9 @@ type RttiInstantiation = [(TcTyVar, TyVar)] -- mapping from new (instantiated) -to- old (skolem) type variables instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) instScheme (tvs, ty) - = liftTcM $ do { (subst, tvs') <- tcInstTyVars tvs - ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] - ; return (substTy subst ty, rtti_inst) } + = do { (subst, tvs') <- instTyVars tvs + ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] + ; return (substTy subst ty, rtti_inst) } applyRevSubst :: RttiInstantiation -> TR () -- Apply the *reverse* substitution in-place to any un-filled-in @@ -642,13 +646,13 @@ addConstraint actual expected = do traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, text "with", ppr expected]) $ + discardResult $ + captureConstraints $ do { (ty1, ty2) <- congruenceNewtypes actual expected - ; _ <- captureConstraints $ unifyType ty1 ty2 - ; return () } + ; unifyType noThing ty1 ty2 } -- TOMDO: what about the coercion? -- we should consider family instances - -- Type & Term reconstruction ------------------------------ cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term @@ -657,7 +661,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- as this is needed to be able to manipulate -- them properly let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty - sigma_old_ty = mkForAllTys old_tvs old_tau + sigma_old_ty = mkInvForAllTys old_tvs old_tau traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) term <- if null old_tvs @@ -667,7 +671,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do return $ fixFunDictionaries $ expandNewtypes term' else do (old_ty', rev_subst) <- instScheme quant_old_ty - my_ty <- newVar openTypeKind + my_ty <- newOpenVar when (check1 quant_old_ty) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') term <- go max_depth my_ty sigma_old_ty hval @@ -687,7 +691,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do zterm' <- mapTermTypeM (\ty -> case tcSplitTyConApp_maybe ty of Just (tc, _:_) | tc /= funTyCon - -> newVar openTypeKind + -> newOpenVar _ -> return ty) term zonkTerm zterm' @@ -797,13 +801,14 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do extractSubTerms :: (Type -> HValue -> TcM Term) -> Closure -> [Type] -> TcM [Term] -extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos) +extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos) where go ptr_i ws [] = return (ptr_i, ws, []) go ptr_i ws (ty:tys) | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty , isUnboxedTupleTyCon tc - = do (ptr_i, ws, terms0) <- go ptr_i ws elem_tys + -- See Note [Unboxed tuple levity vars] in TyCon + = do (ptr_i, ws, terms0) <- go ptr_i ws (drop (length elem_tys `div` 2) elem_tys) (ptr_i, ws, terms1) <- go ptr_i ws tys return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1) | otherwise @@ -849,7 +854,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do then return old_ty else do (old_ty', rev_subst) <- instScheme sigma_old_ty - my_ty <- newVar openTypeKind + my_ty <- newOpenVar when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') search (isMonomorphic `fmap` zonkTcType my_ty) @@ -941,7 +946,7 @@ findPtrTyss i tys = foldM step (i, []) tys -- improveType <base_type> <rtti_type> -- The types can contain skolem type variables, which need to be treated as normal vars. -- In particular, we want them to unify with things. -improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst improveRTTIType _ base_ty new_ty = U.tcUnifyTy base_ty new_ty getDataConArgTys :: DataCon -> Type -> TR [Type] @@ -1109,7 +1114,7 @@ If that is not the case, then we consider two conditions. check1 :: QuantifiedType -> Bool check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) where - isHigherKind = not . null . fst . splitKindFunTys + isHigherKind = not . null . fst . splitPiTys check2 :: QuantifiedType -> QuantifiedType -> Bool check2 (_, rtti_ty) (_, old_ty) @@ -1191,7 +1196,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') (_, vars) <- instTyVars (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon (mkTyVarTys vars) UnaryRep rep_ty = repType ty' - _ <- liftTcM (unifyType ty rep_ty) + _ <- liftTcM (unifyType noThing ty rep_ty) -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' @@ -1232,7 +1237,7 @@ dictsView ty = ty isMonomorphic :: RttiType -> Bool isMonomorphic ty = noExistentials && noUniversals where (tvs, _, ty') = tcSplitSigmaTy ty - noExistentials = isEmptyVarSet (tyVarsOfType ty') + noExistentials = isEmptyVarSet (tyCoVarsOfType ty') noUniversals = null tvs -- Use only for RTTI types @@ -1268,7 +1273,9 @@ quantifyType :: Type -> QuantifiedType -- Thus (quantifyType (forall a. a->[b])) -- returns ([a,b], a -> [b]) -quantifyType ty = (tyVarsOfTypeList rho, rho) +quantifyType ty = ( filter isTyVar $ + tyCoVarsOfTypeWellScoped rho + , rho) where (_tvs, rho) = tcSplitForAllTys ty diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 4decbe12bb..342bc35679 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -446,9 +446,9 @@ cvtConstr (ForallC tvs ctxt con) ; let qvars = case (tvs,con_qvars con') of ([],Nothing) -> Nothing _ -> - Just $ mkHsQTvs (hsQTvBndrs tvs' ++ - hsQTvBndrs (fromMaybe (HsQTvs PlaceHolder []) - (con_qvars con'))) + Just $ mkHsQTvs (hsQTvExplicit tvs' ++ + hsQTvExplicit (fromMaybe (HsQTvs PlaceHolder []) + (con_qvars con'))) ; returnL $ con' { con_qvars = qvars , con_cxt = Just $ L loc (ctxt' ++ @@ -482,9 +482,9 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (mkLHsSigType ty) } cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) -cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs - ; ys' <- mapM tName ys - ; returnL (map noLoc xs', map noLoc ys') } +cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs + ; ys' <- mapM tNameL ys + ; returnL (xs', ys') } ------------------------------------------ @@ -785,7 +785,7 @@ the trees to reflect the fixities of the underlying operators: This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely right-biased for types and left-biased for everything else. So we left-bias the -trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. +trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT. Sample input: @@ -1004,12 +1004,12 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv (TH.PlainTV nm) - = do { nm' <- tName nm - ; returnL $ UserTyVar (noLoc nm') } + = do { nm' <- tNameL nm + ; returnL $ UserTyVar nm' } cvt_tv (TH.KindedTV nm ki) - = do { nm' <- tName nm + = do { nm' <- tNameL nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar (noLoc nm') ki' } + ; returnL $ KindedTyVar nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1054,8 +1054,8 @@ cvtTypeKind ty_str ty | [x'] <- tys' -> returnL (HsListTy x') | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys' - VarT nm -> do { nm' <- tName nm - ; mk_apps (HsTyVar (noLoc nm')) tys' } + VarT nm -> do { nm' <- tNameL nm + ; mk_apps (HsTyVar nm') tys' } ConT nm -> do { nm' <- tconName nm ; mk_apps (HsTyVar (noLoc nm')) tys' } @@ -1066,7 +1066,7 @@ cvtTypeKind ty_str ty ; ty' <- cvtType ty ; loc <- getL ; let hs_ty | null tvs = rho_ty - | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvBndrs tvs' + | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs' , hst_body = rho_ty }) rho_ty | null cxt = ty' | otherwise = L loc (HsQualTy { hst_ctxt = cxt' @@ -1087,8 +1087,8 @@ cvtTypeKind ty_str ty -> mk_apps mkAnonWildCardTy tys' WildCardT (Just nm) - -> do { nm' <- tName nm - ; mk_apps (mkNamedWildCardTy (noLoc nm')) tys' } + -> do { nm' <- tNameL nm + ; mk_apps (mkNamedWildCardTy nm') tys' } InfixT t1 s t2 -> do { s' <- tconName s @@ -1098,8 +1098,10 @@ cvtTypeKind ty_str ty } UInfixT t1 s t2 - -> do { t2' <- cvtType t2 - ; cvtOpAppT t1 s t2' + -> do { t1' <- cvtType t1 + ; t2' <- cvtType t2 + ; s' <- tconName s + ; return $ cvtOpAppT t1' s' t2' } -- Note [Converting UInfix] ParensT t @@ -1157,23 +1159,26 @@ split_ty_app ty = go ty [] go f as = return (f,as) cvtTyLit :: TH.TyLit -> HsTyLit -cvtTyLit (NumTyLit i) = HsNumTy (show i) i -cvtTyLit (StrTyLit s) = HsStrTy s (fsLit s) - -{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator -application @x `op` y@. The produced tree of infix types will be right-biased, -provided @y@ is. +cvtTyLit (TH.NumTyLit i) = HsNumTy (show i) i +cvtTyLit (TH.StrTyLit s) = HsStrTy s (fsLit s) -See the @cvtOpApp@ documentation for how this function works. +{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy + structure in them. -} -cvtOpAppT :: TH.Type -> TH.Name -> LHsType RdrName -> CvtM (LHsType RdrName) -cvtOpAppT (UInfixT x op2 y) op1 z - = do { l <- cvtOpAppT y op1 z - ; cvtOpAppT x op2 l } -cvtOpAppT x op y - = do { op' <- tconNameL op - ; x' <- cvtType x - ; returnL (mkHsOpTy x' op' y) } +cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName +cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) + = L (combineSrcSpans loc1 loc2) $ + HsAppsTy (t1' ++ [HsAppInfix (noLoc op)] ++ t2') + where + t1' | L _ (HsAppsTy t1s) <- t1 + = t1s + | otherwise + = [HsAppPrefix t1] + + t2' | L _ (HsAppsTy t2s) <- t2 + = t2s + | otherwise + = [HsAppPrefix t2] cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) cvtKind = cvtTypeKind "kind" diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 48348cc2e1..3f49f42a0e 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -46,7 +46,7 @@ module HsDecls ( -- ** @RULE@ declarations LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, - flattenRuleDecls, + flattenRuleDecls, pprFullRuleName, -- ** @VECTORISE@ declarations VectDecl(..), LVectDecl, lvectDeclName, lvectInstDecl, @@ -638,7 +638,7 @@ countTyClDecls decls -- | Does this declaration have a complete, user-supplied kind signature? -- See Note [Complete user-supplied kind signatures] -hsDeclHasCusk :: TyClDecl name -> Bool +hsDeclHasCusk :: TyClDecl Name -> Bool hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) = hsTvbAllKinded tyvars && rhs_annotated rhs @@ -1060,14 +1060,19 @@ getConNames :: ConDecl name -> [Located name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names +-- don't call with RdrNames, because it can't deal with HsAppsTy getConDetails :: ConDecl name -> HsConDeclDetails name getConDetails ConDeclH98 {con_details = details} = details getConDetails ConDeclGADT {con_type = ty } = details where (details,_,_,_) = gadtDeclDetails ty +-- don't call with RdrNames, because it can't deal with HsAppsTy gadtDeclDetails :: LHsSigType name - -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name]) + -> ( HsConDeclDetails name + , LHsType name + , LHsContext name + , [LHsTyVarBndr name] ) gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) where (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty @@ -1635,12 +1640,15 @@ deriving instance (DataId name) => Data (RuleBndr name) collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] +pprFullRuleName :: Located (SourceText, RuleName) -> SDoc +pprFullRuleName (L _ (_, n)) = doubleQuotes $ ftext n + instance OutputableBndr name => Outputable (RuleDecls name) where ppr (HsRules _ rules) = ppr rules instance OutputableBndr name => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) - = sep [text "{-# RULES" <+> doubleQuotes (ftext $ snd $ unLoc name) + = sep [text "{-# RULES" <+> pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index c5afa7410f..6e02df7438 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -594,7 +594,6 @@ in the ParsedSource. There are unfortunately enough differences between the ParsedSource and the RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. ->>>>>>> origin/master -} instance OutputableBndr id => Outputable (HsExpr id) where diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 91e5973ece..0f65e4b297 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -153,10 +153,11 @@ data Pat id -- Use (conLikeResTy pat_con pat_arg_tys) to get -- the type of the pattern - pat_tvs :: [TyVar], -- Existentially bound type variables (tyvars only) + pat_tvs :: [TyVar], -- Existentially bound type variables pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* -- One reason for putting coercion variable here, I think, -- is to ensure their kinds are zonked + pat_binds :: TcEvBinds, -- Bindings involving those dictionaries pat_args :: HsConPatDetails id, pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher @@ -236,6 +237,12 @@ hsConPatArgs (PrefixCon ps) = ps hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] +instance (Outputable arg, Outputable rec) + => Outputable (HsConDetails arg rec) where + ppr (PrefixCon args) = text "PrefixCon" <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + {- However HsRecFields is used only for patterns and expressions (not data type declarations) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 8bcdc6aac1..df2f0f36f3 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -18,7 +18,6 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, - HsTyOp,LHsTyOp, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsImplicitBndrs(..), @@ -26,9 +25,9 @@ module HsTypes ( LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, - HsTyWrapper(..), HsTyLit(..), HsIPName(..), hsIPNameFS, + HsAppType(..), LBangType, BangType, HsSrcBang(..), HsImplBang(..), @@ -48,18 +47,17 @@ module HsTypes ( mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, - mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, + mkHsQTvs, hsQTvExplicit, isHsKindedTyVar, hsTvbAllKinded, hsScopedTvs, hsWcScopedTvs, dropWildCards, - hsTyVarName, hsLKiTyVarNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, - splitLHsInstDeclTy, getLHsInstDeclClass_maybe, + hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames, + splitLHsInstDeclTy, splitLHsPatSynTy, splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, - splitLHsClassTy_maybe, - splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe, - mkHsAppTys, mkHsOpTy, + splitHsFunType, splitHsAppTys, + mkHsOpTy, ignoreParens, hsSigType, hsSigWcType, - hsLTyVarBndrsToTypes, + hsLTyVarBndrToType, hsLTyVarBndrsToTypes, -- Printing pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra, @@ -70,9 +68,9 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) ) -import Id( Id ) +import Id ( Id ) import Name( Name ) -import RdrName( RdrName ) +import RdrName ( RdrName ) import DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) import TysPrim( funTyConName ) @@ -87,10 +85,6 @@ import Maybes( isJust ) import Data.Data hiding ( Fixity ) import Data.Maybe ( fromMaybe ) -#if __GLASGOW_HASKELL__ < 709 --- SPJ temp --- import Data.Monoid hiding((<>)) -#endif #if __GLASGOW_HASKELL > 710 import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup @@ -208,8 +202,8 @@ type LHsTyVarBndr name = Located (HsTyVarBndr name) -- See Note [HsType binders] data LHsQTyVars name -- See Note [HsType binders] - = HsQTvs { hsq_kvs :: PostRn name [Name] -- Kind variables - , hsq_tvs :: [LHsTyVarBndr name] -- Type variables + = HsQTvs { hsq_implicit :: PostRn name [Name] -- implicit (dependent) variables + , hsq_explicit :: [LHsTyVarBndr name] -- explicit variables -- See Note [HsForAllTy tyvar binders] } deriving( Typeable ) @@ -217,23 +211,10 @@ data LHsQTyVars name -- See Note [HsType binders] deriving instance (DataId name) => Data (LHsQTyVars name) mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName -mkHsQTvs tvs = HsQTvs { hsq_kvs = PlaceHolder, hsq_tvs = tvs } - -hsQTvBndrs :: LHsQTyVars name -> [LHsTyVarBndr name] -hsQTvBndrs = hsq_tvs - -{- -#if __GLASGOW_HASKELL__ > 710 -instance Semigroup (LHsTyVarBndrs name) where - HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2 - = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) -#endif +mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs } -instance Monoid (LHsQTyVars name) where - mempty = mkHsQTvs [] - mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2) - = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) --} +hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name] +hsQTvExplicit = hsq_explicit ------------------------------------------------ -- HsImplicitBndrs @@ -245,8 +226,7 @@ instance Monoid (LHsQTyVars name) where -- In the last of these, wildcards can happen, so we must accommodate them data HsImplicitBndrs name thing -- See Note [HsType binders] - = HsIB { hsib_kvs :: PostRn name [Name] -- Implicitly-bound kind vars - , hsib_tvs :: PostRn name [Name] -- Implicitly-bound type vars + = HsIB { hsib_vars :: PostRn name [Name] -- Implicitly-bound kind & type vars , hsib_body :: thing -- Main payload (type or list of types) } deriving (Typeable) @@ -305,8 +285,7 @@ A HsSigType is just a HsImplicitBndrs wrapping a LHsType. E.g. For a signature like f :: forall (a::k). blah we get - HsIB { hsib_kvs = [k] - , hsib_tvs = [] + HsIB { hsib_vars = [k] , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] , hst_body = blah } The implicit kind variable 'k' is bound by the HsIB; @@ -315,8 +294,7 @@ the explictly forall'd tyvar 'a' is bounnd by the HsForAllTy mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing mkHsImplicitBndrs x = HsIB { hsib_body = x - , hsib_kvs = PlaceHolder - , hsib_tvs = PlaceHolder } + , hsib_vars = PlaceHolder } mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing mkHsWildCardBndrs x = HsWC { hswc_body = x @@ -327,8 +305,7 @@ mkHsWildCardBndrs x = HsWC { hswc_body = x -- the wrapped thing had free type variables? mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing mkEmptyImplicitBndrs x = HsIB { hsib_body = x - , hsib_kvs = [] - , hsib_tvs = [] } + , hsib_vars = [] } mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x @@ -374,9 +351,9 @@ isHsKindedTyVar :: HsTyVarBndr name -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True --- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations? +-- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars name -> Bool -hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit data HsType name = HsForAllTy -- See Note [HsType binders] @@ -399,6 +376,10 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation + | HsAppsTy [HsAppType name] -- Used only before renaming, + -- Note [HsAppsTy] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + | HsAppTy (LHsType name) (LHsType name) -- ^ - 'ApiAnnotation.AnnKeywordId' : None @@ -430,7 +411,7 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) + | HsOpTy (LHsType name) (Located name) (LHsType name) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation @@ -524,11 +505,6 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsWildCardTy (HsWildCardInfo name) -- A type wildcard -- ^ - 'ApiAnnotation.AnnKeywordId' : None @@ -543,15 +519,8 @@ data HsTyLit | HsStrTy SourceText FastString deriving (Data, Typeable) -data HsTyWrapper - = WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn - deriving (Data, Typeable) - -type LHsTyOp name = HsTyOp (Located name) -type HsTyOp name = (HsTyWrapper, name) - mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name -mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 +mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2 data HsWildCardInfo name = AnonWildCard (PostRn name (Located Name)) @@ -562,6 +531,15 @@ data HsWildCardInfo name deriving (Typeable) deriving instance (DataId name) => Data (HsWildCardInfo name) +data HsAppType name + = HsAppInfix (Located name) -- either a symbol or an id in backticks + | HsAppPrefix (LHsType name) -- anything else, including things like (+) + deriving (Typeable) +deriving instance (DataId name) => Data (HsAppType name) + +instance OutputableBndr name => Outputable (HsAppType name) where + ppr = ppr_app_ty TopPrec + {- Note [HsForAllTy tyvar binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -580,7 +558,7 @@ Note [Context quantification] in RnTypes, and Trac #4426. In GHC 7.12, Qualified will no longer bind variables and this will become an error. -The kind variables bound in the hsq_kvs field come both +The kind variables bound in the hsq_implicit field come both a) from the kind signatures on the kind vars (eg k1) b) from the scope of the forall (eg k2) Example: f :: forall (a::k1) b. T a (b::k2) @@ -614,6 +592,16 @@ HsTyVar: A name in a type or kind. Tv: kind variable TcCls: kind constructor or promoted type constructor +Note [HsAppsTy] +~~~~~~~~~~~~~~~ +How to parse + + Foo * Int + +? Is it `(*) Foo Int` or `Foo GHC.Types.* Int`? There's no way to know until renaming. +So we just take type expressions like this and put each component in a list, so be +sorted out in the renamer. The sorting out is done by RnTypes.mkHsOpTyRn. This means +that the parser should never produce HsAppTy or HsOpTy. Note [Promoted lists and tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -777,17 +765,23 @@ hsWcScopedTvs :: LHsSigWcType Name -> [Name] -- - the named wildcars; see Note [Scoping of named wildcards] -- because they scope in the same way hsWcScopedTvs sig_ty - | HsIB { hsib_kvs = kvs, hsib_body = sig_ty1 } <- sig_ty + | HsIB { hsib_vars = vars, hsib_body = sig_ty1 } <- sig_ty , HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1 - , (tvs, _) <- splitLHsForAllTy sig_ty2 - = kvs ++ nwcs ++ map hsLTyVarName tvs + = case sig_ty2 of + L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ + map hsLTyVarName tvs + -- include kind variables only if the type is headed by forall + -- (this is consistent with GHC 7 behaviour) + _ -> nwcs hsScopedTvs :: LHsSigType Name -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType hsScopedTvs sig_ty - | HsIB { hsib_kvs = kvs, hsib_body = sig_ty2 } <- sig_ty - , (tvs, _) <- splitLHsForAllTy sig_ty2 - = kvs ++ map hsLTyVarName tvs + | HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty + , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2 + = vars ++ map hsLTyVarName tvs + | otherwise + = [] {- Note [Scoping of named wildcards] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -810,31 +804,32 @@ hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc -hsLTyVarNames :: LHsQTyVars name -> [name] --- Type variables only -hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) +hsExplicitLTyVarNames :: LHsQTyVars name -> [name] +-- Explicit variables only +hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) -hsLKiTyVarNames :: LHsQTyVars Name -> [Name] --- Kind and type variables -hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) +hsAllLTyVarNames :: LHsQTyVars Name -> [Name] +-- All variables +hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) = kvs ++ map hsLTyVarName tvs hsLTyVarLocName :: LHsTyVarBndr name -> Located name hsLTyVarLocName = fmap hsTyVarName --- | Convert a LHsTyVarBndr to an equivalent LHsType. Used in Template Haskell --- quoting for type family equations. +hsLTyVarLocNames :: LHsQTyVars name -> [Located name] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) + +-- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name hsLTyVarBndrToType = fmap cvt where cvt (UserTyVar n) = HsTyVar n cvt (KindedTyVar (L name_loc n) kind) = HsKindSig (L name_loc (HsTyVar (L name_loc n))) kind --- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell --- quoting for type family equations. Works on *type* variable only, no kind --- vars. +-- | Convert a LHsTyVarBndrs to a list of types. +-- Works on *type* variable only, no kind vars. hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name] -hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs +hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- mkAnonWildCardTy :: HsType RdrName @@ -871,34 +866,12 @@ sameNamedWildCard (L _ (NamedWildCard (L _ n1))) (L _ (NamedWildCard (L _ n2))) = n1 == n2 sameNamedWildCard _ _ = False -splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) +splitHsAppTys :: LHsType Name -> [LHsType Name] -> (LHsType Name, [LHsType Name]) + -- no need to worry about HsAppsTy here splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as splitHsAppTys f as = (f,as) --- retrieve the name of the "head" of a nested type application --- somewhat like splitHsAppTys, but a little more thorough --- used to examine the result of a GADT-like datacon, so it doesn't handle --- *all* cases (like lists, tuples, (~), etc.) -hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n]) -hsTyGetAppHead_maybe = go [] - where - go tys (L _ (HsTyVar (L _ n))) = Just (n, tys) - go tys (L _ (HsAppTy l r)) = go (r : tys) l - go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys) - go tys (L _ (HsParTy t)) = go tys t - go tys (L _ (HsKindSig t _)) = go tys t - go _ _ = Nothing - -mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n -mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) -mkHsAppTys fun_ty (arg_ty:arg_tys) - = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys - where - mk_app fun arg = HsAppTy (noLoc fun) arg - -- Add noLocs for inner nodes of the application; - -- they are never used - splitLHsPatSynTy :: LHsType name -> ( [LHsTyVarBndr name] , LHsContext name -- Required @@ -935,39 +908,14 @@ splitLHsInstDeclTy :: LHsSigType Name -> ([Name], LHsContext Name, LHsType Name) -- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy (HsIB { hsib_kvs = ikvs, hsib_tvs = itvs +splitLHsInstDeclTy (HsIB { hsib_vars = itkvs , hsib_body = inst_ty }) - = (ikvs ++ itvs, cxt, body_ty) + = (itkvs, cxt, body_ty) -- Return implicitly bound type and kind vars -- For an instance decl, all of them are in scope where (cxt, body_ty) = splitLHsQualTy inst_ty -getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) --- Works on (HsSigType RdrName) -getLHsInstDeclClass_maybe inst_ty - = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty) - ; (cls, _) <- splitLHsClassTy_maybe tau - ; return cls } - -splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) --- Watch out.. in ...deriving( Show )... we use this on --- the list of partially applied predicates in the deriving, --- so there can be zero args. --- --- In TcDeriv we also use this to figure out what data type is being --- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo"). -splitLHsClassTy_maybe ty - = checkl ty [] - where - checkl (L _ ty) args = case ty of - HsTyVar (L lt t) -> Just (L lt t, args) - HsAppTy l r -> checkl l (r:args) - HsOpTy l (_,L lt tc) r -> checkl (L lt (HsTyVar (L lt tc))) (l:r:args) - HsParTy t -> checkl t args - HsKindSig ty _ -> checkl ty args - _ -> Nothing - -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c) @@ -994,10 +942,10 @@ splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) splitHsFunType other = ([], other) - ignoreParens :: LHsType name -> LHsType name -ignoreParens (L _ (HsParTy ty)) = ignoreParens ty -ignoreParens ty = ty +ignoreParens (L _ (HsParTy ty)) = ignoreParens ty +ignoreParens (L _ (HsAppsTy [HsAppPrefix ty])) = ignoreParens ty +ignoreParens ty = ty {- ************************************************************************ @@ -1013,9 +961,8 @@ instance (OutputableBndr name) => Outputable (HsType name) where instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndr name) - => Outputable (LHsQTyVars name) where - ppr (HsQTvs { hsq_tvs = tvs }) = interppSP tvs +instance (OutputableBndr name) => Outputable (LHsQTyVars name) where + ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n @@ -1103,16 +1050,14 @@ seems like the Right Thing anyway.) pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc -pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty) +pprHsType ty = ppr_mono_ty TopPrec (prepare ty) pprParendHsType ty = ppr_mono_ty TyConPrec ty --- Before printing a type --- (a) Remove outermost HsParTy parens --- (b) Drop top-level for-all type variables in user style --- since they are implicit in Haskell -prepare :: PprStyle -> HsType name -> HsType name -prepare sty (HsParTy ty) = prepare sty (unLoc ty) -prepare _ ty = ty +-- Before printing a type, remove outermost HsParTy parens +prepare :: HsType name -> HsType name +prepare (HsParTy ty) = prepare (unLoc ty) +prepare (HsAppsTy [HsAppPrefix (L _ ty)]) = prepare ty +prepare ty = ty ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) @@ -1146,34 +1091,22 @@ ppr_mono_ty _ (HsTyLit t) = ppr_tylit t ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) = char '_' ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) = ppr name -ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) - = ppr_mono_ty ctxt_prec ty --- We are not printing kind applications. If we wanted to do so, we should do --- something like this: -{- - = go ctxt_prec kis ty - where - go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty - go ctxt_prec (ki:kis) ty - = maybeParen ctxt_prec TyConPrec $ - hsep [ go FunPrec kis ty - , ptext (sLit "@") <> pprParendKind ki ] --} - ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) = maybeParen ctxt_prec TyOpPrec $ ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2 +ppr_mono_ty ctxt_prec (HsAppsTy tys) + = maybeParen ctxt_prec TyConPrec $ + hsep (map (ppr_app_ty TopPrec) tys) + ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec TyConPrec $ hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2) +ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2) = maybeParen ctxt_prec TyOpPrec $ sep [ ppr_mono_lty TyOpPrec ty1 , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ] - -- Don't print the wrapper (= kind applications) - -- c.f. HsWrapTy ppr_mono_ty _ (HsParTy ty) = parens (ppr_mono_lty TopPrec ty) @@ -1197,6 +1130,12 @@ ppr_fun_ty ctxt_prec ty1 ty2 sep [p1, ptext (sLit "->") <+> p2] -------------------------- +ppr_app_ty :: OutputableBndr name => TyPrec -> HsAppType name -> SDoc +ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n +ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar (L _ n)))) = pprPrefixOcc n +ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty ctxt ty + +-------------------------- ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy _ i) = integer i ppr_tylit (HsStrTy _ s) = text (show s) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index ca3cae5260..fb969ebff1 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -51,9 +51,11 @@ module HsUtils( mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types - mkHsAppTy, userHsTyVarBndrs, + mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs, mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, + getAppsTyHead_maybe, hsTyGetAppHead_maybe, splitHsAppsTy, + getLHsInstDeclClass_maybe, -- Stmts mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, @@ -92,13 +94,12 @@ import HsTypes import HsLit import PlaceHolder -import TcType( tcSplitForAllTys, tcSplitPhiTy ) import TcEvidence import RdrName import Var -import Type( isPredTy ) -import Kind( isKind ) -import TypeRep +import TyCoRep +import Type ( filterOutInvisibleTypes ) +import TcType import DataCon import Name import NameSet @@ -171,6 +172,9 @@ mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) +mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name +mkHsAppTys = foldl mkHsAppTy + mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) @@ -335,10 +339,15 @@ mkHsStringPrimLit fs = HsStringPrim (unpackFS fs) (fastStringToByteString fs) ------------- -userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] +userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name] +-- Caller sets location +userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] + +userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name] -- Caller sets location userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] + {- ************************************************************************ * * @@ -548,24 +557,27 @@ toLHsSigWcType ty = mkLHsSigWcType (go ty) where go :: Type -> LHsType RdrName - go ty@(ForAllTy {}) - | (tvs, tau) <- tcSplitForAllTys ty - = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs - , hst_body = go tau }) - go ty@(FunTy arg _) + go ty@(ForAllTy (Anon arg) _) | isPredTy arg , (theta, tau) <- tcSplitPhiTy ty = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) , hst_body = go tau }) - go (FunTy arg res) = nlHsFunTy (go arg) (go res) + go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res) + go ty@(ForAllTy {}) + | (tvs, tau) <- tcSplitForAllTys ty + = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs + , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where - args' = filterOut isKind args - -- Source-language types have _implicit_ kind arguments, + args' = filterOutInvisibleTypes tc args + go (CastTy ty _) = go ty + go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) + + -- Source-language types have _invisible_ kind arguments, -- so we must remove them here (Trac #8563) go_tv :: TyVar -> LHsTyVarBndr RdrName @@ -956,20 +968,23 @@ hsConDeclsBinders cons = go id cons L loc (ConDeclGADT { con_names = names , con_type = HsIB { hsib_body = res_ty}}) -> case tau of + L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _res_ty) + -> record_gadt flds L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) - -> (map (L loc . unLoc) names ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) - flds) - remSeen' - = foldr (.) remSeen - [deleteBy ((==) `on` - rdrNameFieldOcc . unLoc) v - | v <- r'] - (ns, fs) = go remSeen' rs + -> record_gadt flds + _other -> (map (L loc . unLoc) names ++ ns, fs) where (ns, fs) = go remSeen rs - where - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + where + (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) + where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) + remSeen' = foldr (.) remSeen + [deleteBy ((==) `on` + rdrNameFieldOcc . unLoc) v + | v <- r'] + (ns, fs) = go remSeen' rs + L loc (ConDeclH98 { con_name = name , con_details = RecCon flds }) -> ([L loc (unLoc name)] ++ ns, r' ++ fs) @@ -1080,3 +1095,61 @@ lPatImplicits = hs_lpat (unLoc fld) pat_explicit = maybe True (i<) (rec_dotdot fs)] details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2 + +{- +************************************************************************ +* * + Dealing with HsAppsTy +* * +************************************************************************ +-} + +-- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, +-- without consulting fixities. +getAppsTyHead_maybe :: [HsAppType name] -> Maybe (LHsType name, [LHsType name]) +getAppsTyHead_maybe tys = case splitHsAppsTy tys of + ([app1:apps], []) -> -- no symbols, some normal types + Just (mkHsAppTys app1 apps, []) + ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator + Just (L loc (HsTyVar (L loc op)), [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr]) + _ -> -- can't figure it out + Nothing + +-- | Splits a [HsAppType name] (the payload of an HsAppsTy) into regions of prefix +-- types (normal types) and infix operators. +-- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first +-- element of @non_syms@ followed by the first element of @syms@ followed by +-- the next element of @non_syms@, etc. It is guaranteed that the non_syms list +-- has one more element than the syms list. +splitHsAppsTy :: [HsAppType name] -> ([[LHsType name]], [Located name]) +splitHsAppsTy = go [] [] [] + where + go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) + go acc acc_non acc_sym (HsAppPrefix ty : rest) + = go (ty : acc) acc_non acc_sym rest + go acc acc_non acc_sym (HsAppInfix op : rest) + = go [] (reverse acc : acc_non) (op : acc_sym) rest + +-- retrieve the name of the "head" of a nested type application +-- somewhat like splitHsAppTys, but a little more thorough +-- used to examine the result of a GADT-like datacon, so it doesn't handle +-- *all* cases (like lists, tuples, (~), etc.) +hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) +hsTyGetAppHead_maybe = go [] + where + go tys (L _ (HsTyVar ln)) = Just (ln, tys) + go tys (L _ (HsAppsTy apps)) + | Just (head, args) <- getAppsTyHead_maybe apps + = go (args ++ tys) head + go tys (L _ (HsAppTy l r)) = go (r : tys) l + go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys) + go tys (L _ (HsParTy t)) = go tys t + go tys (L _ (HsKindSig t _)) = go tys t + go _ _ = Nothing + +getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) +-- Works on (HsSigType RdrName) +getLHsInstDeclClass_maybe inst_ty + = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty) + ; (cls, _) <- hsTyGetAppHead_maybe tau + ; return cls } diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 13a6649140..c0926fc22e 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -146,7 +146,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do seekBin bh symtab_p symtab <- getSymbolTable bh ncu seekBin bh data_p -- Back to where we were before - + -- It is only now that we know how to get a Name return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab) (getDictFastString dict) @@ -194,8 +194,8 @@ writeBinIface dflags hi_path mod_iface = do let bin_dict = BinDictionary { bin_dict_next = dict_next_ref, bin_dict_map = dict_map_ref } - - -- Put the main thing, + + -- Put the main thing, bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) (putFastString bin_dict) put_ bh mod_iface @@ -209,7 +209,7 @@ writeBinIface dflags hi_path mod_iface = do symtab_next <- readFastMutInt symtab_next symtab_map <- readIORef symtab_map putSymbolTable bh symtab_next symtab_map - debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next + debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next <+> text "Names") -- NB. write the dictionary after the symbol table, because @@ -256,7 +256,7 @@ getSymbolTable bh ncu = do od_names <- sequence (replicate sz (get bh)) updateNameCache ncu $ \namecache -> let arr = listArray (0,sz-1) names - (namecache', names) = + (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names in (namecache', arr) @@ -341,11 +341,11 @@ putTupleName_ bh tc tup_sort thing_tag = -- ASSERT(arity < 2^(30 :: Int)) put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity) where - arity = fromIntegral (tyConArity tc) - sort_tag = case tup_sort of - BoxedTuple -> 0 - UnboxedTuple -> 1 - ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc) + (sort_tag, arity) = case tup_sort of + BoxedTuple -> (0, fromIntegral (tyConArity tc)) + UnboxedTuple -> (1, fromIntegral (tyConArity tc `div` 2)) + -- See Note [Unboxed tuple levity vars] in TyCon + ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc) -- See Note [Symbol table representation of names] getSymtabName :: NameCacheUpdater diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 0b8680d164..7c62bc2be5 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -6,9 +6,6 @@ {-# LANGUAGE CPP #-} module BuildTyCl ( - buildSynonymTyCon, - buildFamilyTyCon, - buildAlgTyCon, buildDataCon, buildPatSyn, TcMethInfo, buildClass, @@ -44,32 +41,6 @@ import UniqSupply import Util import Outputable ------------------------------------------------------- -buildSynonymTyCon :: Name -> [TyVar] -> [Role] - -> Type - -> Kind -- ^ Kind of the RHS - -> TyCon -buildSynonymTyCon tc_name tvs roles rhs rhs_kind - = mkSynonymTyCon tc_name kind tvs roles rhs - where - kind = mkPiKinds tvs rhs_kind - - -buildFamilyTyCon :: Name -- ^ Type family name - -> [TyVar] -- ^ Type variables - -> Maybe Name -- ^ Result variable name - -> FamTyConFlav -- ^ Open, closed or in a boot file? - -> Kind -- ^ Kind of the RHS - -> Maybe Class -- ^ Parent, if exists - -> Injectivity -- ^ Injectivity annotation - -- See [Injectivity annotation] in HsDecls - -> TyCon -buildFamilyTyCon tc_name tvs res_tv rhs rhs_kind parent injectivity - = mkFamilyTyCon tc_name kind tvs res_tv rhs parent injectivity - where kind = mkPiKinds tvs rhs_kind - - ------------------------------------------------------- distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs distinctAbstractTyConRhs = AbstractTyCon True totallyAbstractTyConRhs = AbstractTyCon False @@ -83,8 +54,9 @@ mkDataTyConRhs cons } where is_enum_con con - | (_tvs, theta, arg_tys, _res) <- dataConSig con - = null theta && null arg_tys + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs @@ -128,22 +100,21 @@ mkNewTyConRhs tycon_name tycon con eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, Just tv <- getTyVar_maybe arg, tv == a, - not (a `elemVarSet` tyVarsOfType fun) + not (a `elemVarSet` tyCoVarsOfType fun) = eta_reduce as rs fun eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) - ------------------------------------------------------ buildDataCon :: FamInstEnvs -> Name -> Bool -- Declared infix - -> Promoted TyConRepName -- Promotable + -> TyConRepName -> [HsSrcBang] -> Maybe [HsImplBang] -- See Note [Bangs on imported data constructors] in MkId -> [FieldLabel] -- Field labels -> [TyVar] -> [TyVar] -- Univ and ext - -> [(TyVar,Type)] -- Equality spec + -> [EqSpec] -- Equality spec -> ThetaType -- Does not include the "stupid theta" -- or the GADT equalities -> [Type] -> Type -- Argument and result types @@ -188,14 +159,14 @@ mkDataConStupidTheta tycon arg_tys univ_tvs | null stupid_theta = [] -- The common case | otherwise = filter in_arg_tys stupid_theta where - tc_subst = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs) + tc_subst = zipTopTCvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs) stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) -- Start by instantiating the master copy of the -- stupid theta, taken from the TyCon - arg_tyvars = tyVarsOfTypes arg_tys + arg_tyvars = tyCoVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ - tyVarsOfType pred `intersectVarSet` arg_tyvars + tyCoVarsOfType pred `intersectVarSet` arg_tyvars ------------------------------------------------------ @@ -211,31 +182,38 @@ buildPatSyn :: Name -> Bool buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty field_labels - = ASSERT((and [ univ_tvs == univ_tvs' - , ex_tvs == ex_tvs' - , pat_ty `eqType` pat_ty' - , prov_theta `eqTypes` prov_theta' - , req_theta `eqTypes` req_theta' - , arg_tys `eqTypes` arg_tys' - ])) + = ASSERT2((and [ univ_tvs == univ_tvs1 + , ex_tvs == ex_tvs1 + , pat_ty `eqType` pat_ty1 + , prov_theta `eqTypes` prov_theta1 + , req_theta `eqTypes` req_theta1 + , arg_tys `eqTypes` arg_tys1 + ]) + , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1 + , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1 + , ppr pat_ty <+> twiddle <+> ppr pat_ty1 + , ppr prov_theta <+> twiddle <+> ppr prov_theta1 + , ppr req_theta <+> twiddle <+> ppr req_theta1 + , ppr arg_tys <+> twiddle <+> ppr arg_tys1])) mkPatSyn src_name declared_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty matcher builder field_labels where - ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id - ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau - (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma - (arg_tys', _) = tcSplitFunTys cont_tau - --- ------------------------------------------------------ + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id + ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma + (arg_tys1, _) = tcSplitFunTys cont_tau + twiddle = char '~' +------------------------------------------------------ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type)) -- A temporary intermediate, to communicate between -- tcClassSigs and buildClass. -buildClass :: Name -- Name of the class/tycon (they have the same Name) +buildClass :: Name -- Name of the class/tycon (they have the same Name) -> [TyVar] -> [Role] -> ThetaType + -> Kind -> [FunDep TyVar] -- Functional dependencies -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info @@ -243,7 +221,7 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name) -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec +buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_isrec = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") @@ -284,10 +262,11 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec arg_tys = sc_theta ++ op_tys rec_tycon = classTyCon rec_clas + ; rep_nm <- newTyConRepName datacon_name ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") datacon_name False -- Not declared infix - NotPromoted -- Class tycons are not promoted + rep_nm (map (const no_bang) args) (Just (map (const HsLazy) args)) [{- No fields -}] @@ -305,9 +284,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec , tup_sort = ConstraintTuple }) else return (mkDataTyConRhs [dict_con]) - ; let { clas_kind = mkPiKinds tvs constraintKind - ; tycon = mkClassTyCon tycon_name clas_kind tvs roles - rhs rec_clas tc_isrec tc_rep_name + ; let { tycon = mkClassTyCon tycon_name kind tvs roles + rhs rec_clas tc_isrec tc_rep_name -- A class can be recursive, and in the case of newtypes -- this matters. For example -- class C a where { op :: C b => a -> b -> Int } diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index 645ceda5c0..43094f94aa 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -9,7 +9,8 @@ module IfaceEnv ( lookupOrig, lookupOrigNameCache, extendNameCache, newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, - tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar, + tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, + lookupIfaceTyVar, extendIfaceEnvs, ifaceExportNames, @@ -31,11 +32,13 @@ import Avail import Module import UniqFM import FastString +import IfaceType import UniqSupply import SrcLoc import Util import Outputable +import Data.List ( partition ) {- ********************************************************* @@ -277,8 +280,16 @@ tcIfaceTyVar occ Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) } -lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar) -lookupIfaceTyVar occ +lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) +lookupIfaceTyVar (occ, _) + = do { lcl <- getLclEnv + ; return (lookupUFM (if_tv_env lcl) occ) } + +lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) +lookupIfaceVar (IfaceIdBndr (occ, _)) + = do { lcl <- getLclEnv + ; return (lookupUFM (if_id_env lcl) occ) } +lookupIfaceVar (IfaceTvBndr (occ, _)) = do { lcl <- getLclEnv ; return (lookupUFM (if_tv_env lcl) occ) } @@ -289,6 +300,14 @@ extendIfaceTyVarEnv tyvars thing_inside ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } +extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a +extendIfaceEnvs tcvs thing_inside + = extendIfaceTyVarEnv tvs $ + extendIfaceIdEnv cvs $ + thing_inside + where + (tvs, cvs) = partition isTyVar tcvs + {- ************************************************************************ * * diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 307a448ec9..247566cebc 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -94,14 +94,14 @@ data IfaceDecl ifIdDetails :: IfaceIdDetails, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifName :: IfaceTopBndr, -- Type constructor + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor + ifKind :: IfaceType, -- Kind of type constructor ifCType :: Maybe CType, -- C type for CAPI FFI ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info ifRec :: RecFlag, -- Recursive or not? - ifPromotable :: Bool, -- Promotable to kind level? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax ifParent :: IfaceTyConParent -- The axiom, for a newtype, @@ -111,8 +111,7 @@ data IfaceDecl | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles - ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of - -- the tycon) + ifSynKind :: IfaceKind, -- Kind of the *tycon* ifSynRhs :: IfaceType } | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor @@ -120,8 +119,7 @@ data IfaceDecl ifResVar :: Maybe IfLclName, -- Result variable name, used -- only for pretty-printing -- with --show-iface - ifFamKind :: IfaceKind, -- Kind of the *rhs* (not of - -- the tycon) + ifFamKind :: IfaceKind, -- Kind of the *tycon* ifFamFlav :: IfaceFamTyConFlav, ifFamInj :: Injectivity } -- injectivity information @@ -129,6 +127,7 @@ data IfaceDecl ifName :: IfaceTopBndr, -- Name of the class TyCon ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles + ifKind :: IfaceType, -- Kind of TyCon ifFDs :: [FunDep FastString], -- Functional dependencies ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures @@ -187,11 +186,12 @@ data IfaceAT = IfaceAT -- See Class.ClassATItem -- This is just like CoAxBranch -data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbLHS :: IfaceTcArgs - , ifaxbRoles :: [Role] - , ifaxbRHS :: IfaceType - , ifaxbIncomps :: [BranchIndex] } +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbCoVars :: [IfaceIdBndr] + , ifaxbLHS :: IfaceTcArgs + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } -- See Note [Storing compatibility] in CoAxiom data IfaceConDecls @@ -511,14 +511,20 @@ pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc -- be a branch for an imported TyCon, so it would be an ExtName -- So it's easier to take an SDoc here pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs - , ifaxbLHS = pat_tys - , ifaxbRHS = rhs - , ifaxbIncomps = incomps }) - = hang (pprUserIfaceForAll tvs) - 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + , ifaxbCoVars = cvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) $+$ nest 2 maybe_incomps where + ppr_binders + | null tvs && null cvs = empty + | null cvs = brackets (pprWithCommas pprIfaceTvBndr tvs) + | otherwise + = brackets (pprWithCommas pprIfaceTvBndr tvs <> semi <+> + pprWithCommas pprIfaceIdBndr cvs) pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) maybe_incomps = ppUnless (null incomps) $ parens $ ptext (sLit "incompatible indices:") <+> ppr incomps @@ -617,7 +623,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ifRoles = roles, ifCons = condecls, ifParent = parent, ifRec = isrec, ifGadtSyntax = gadt, - ifPromotable = is_prom }) + ifKind = kind }) | gadt_style = vcat [ pp_roles , pp_nd <+> pp_lhs <+> pp_where @@ -635,13 +641,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pp_cons = ppr_trim (map show_con cons) :: [SDoc] pp_lhs = case parent of - IfNoParent -> pprIfaceDeclHead context ss tycon tc_tyvars + IfNoParent -> pprIfaceDeclHead context ss tycon kind tc_tyvars _ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent pp_roles - | is_data_instance = Outputable.empty - | otherwise = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon) - tc_tyvars roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) + (pprPrefixIfDeclBndr ss tycon) + tc_bndrs roles -- Don't display roles for data family instances (yet) -- See discussion on Trac #8672. @@ -670,29 +677,31 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ppr_tc_app gadt_subst dflags = pprPrefixIfDeclBndr ss tycon <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) - | (tv,_kind) <- stripIfaceKindVars dflags tc_tyvars ] + | (tv,_kind) + <- suppressIfaceInvisibles dflags tc_bndrs tc_tyvars ] + (tc_bndrs, _, _) = splitIfaceSigmaTy kind pp_nd = case condecls of IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) IfDataTyCon{} -> ptext (sLit "data") IfNewTyCon{} -> ptext (sLit "newtype") - pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom] - - pp_prom | is_prom = ptext (sLit "Promotable") - | otherwise = Outputable.empty + pp_extra = vcat [pprCType ctype, pprRec isrec, text "Kind:" <+> ppr kind] pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec , ifCtxt = context, ifName = clas , ifTyVars = tyvars, ifRoles = roles - , ifFDs = fds, ifMinDef = minDef }) - = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles - , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars + , ifFDs = fds, ifMinDef = minDef + , ifKind = kind }) + = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) bndrs roles + , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas kind tyvars <+> pprFundeps fds <+> pp_where , nest 2 (vcat [ vcat asocs, vcat dsigs, pprec , ppShowAllSubs ss (pprMinDef minDef)])] where + (bndrs, _, _) = splitIfaceSigmaTy kind + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where")) asocs = ppr_trim $ map maybeShowAssoc ats @@ -716,10 +725,11 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> ptext (sLit "#-}") -pprIfaceDecl ss (IfaceSynonym { ifName = tc - , ifTyVars = tv - , ifSynRhs = mono_ty }) - = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals) +pprIfaceDecl ss (IfaceSynonym { ifName = tc + , ifTyVars = tv + , ifSynRhs = mono_ty + , ifSynKind = kind}) + = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc kind tv <+> equals) 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau]) where (tvs, theta, tau) = splitIfaceSigmaTy mono_ty @@ -728,19 +738,20 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars , ifFamFlav = rhs, ifFamKind = kind , ifResVar = res_var, ifFamInj = inj }) | IfaceDataFamilyTyCon <- rhs - = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon tyvars + = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon kind tyvars | otherwise - = vcat [ hang (ptext (sLit "type family") - <+> pprIfaceDeclHead [] ss tycon tyvars) - 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) - , ppShowRhs ss (nest 2 (pp_branches rhs)) ] + = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon kind tyvars) + 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) + $$ + nest 2 ( vcat [ text "Kind:" <+> ppr kind + , ppShowRhs ss (pp_branches rhs) ] ) where - pp_inj Nothing _ = dcolon <+> ppr kind + pp_inj Nothing _ = empty pp_inj (Just res) inj - | Injective injectivity <- inj = hsep [ equals, ppr res, dcolon, ppr kind + | Injective injectivity <- inj = hsep [ equals, ppr res , pp_inj_cond res injectivity] - | otherwise = hsep [ equals, ppr res, dcolon, ppr kind ] + | otherwise = hsep [ equals, ppr res ] pp_inj_cond res inj = case filterByList inj tyvars of [] -> empty @@ -753,13 +764,14 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract")) pp_rhs (IfaceClosedSynFamilyTyCon {}) - = ptext (sLit "where") + = empty -- see pp_branches pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in")) pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) - = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) - $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) + = hang (text "where") + 2 (vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) + $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)) pp_branches _ = Outputable.empty pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder, @@ -768,7 +780,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder, ifPatArgs = arg_tys, ifPatTy = pat_ty} ) = pprPatSynSig name is_bidirectional - (pprUserIfaceForAll tvs) + (pprUserIfaceForAll (map tv_to_forall_bndr tvs)) (pprIfaceContextMaybe req_ctxt) (pprIfaceContextMaybe prov_ctxt) (pprIfaceType ty) @@ -796,10 +808,11 @@ pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType -- if, for each role, suppress_if role is True, then suppress the role -- output -pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTvBndr] -> [Role] -> SDoc -pprRoles suppress_if tyCon tyvars roles +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceForAllBndr] + -> [Role] -> SDoc +pprRoles suppress_if tyCon bndrs roles = sdocWithDynFlags $ \dflags -> - let froles = suppressIfaceKinds dflags tyvars roles + let froles = suppressIfaceInvisibles dflags bndrs roles in ppUnless (all suppress_if roles || null froles) $ ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles) @@ -845,15 +858,19 @@ pprIfaceTyConParent IfNoParent = Outputable.empty pprIfaceTyConParent (IfDataInstance _ tc tys) = sdocWithDynFlags $ \dflags -> - let ftys = stripKindArgs dflags tys + let ftys = stripInvisArgs dflags tys in pprIfaceTypeApp tc ftys -pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc -pprIfaceDeclHead context ss tc_occ tv_bndrs +pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName + -> IfaceType -- of the tycon, for invisible-suppression + -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context ss tc_occ kind tyvars = sdocWithDynFlags $ \ dflags -> sep [ pprIfaceContextArr context , pprPrefixIfDeclBndr ss tc_occ - <+> pprIfaceTvBndrs (stripIfaceKindVars dflags tv_bndrs) ] + <+> pprIfaceTvBndrs (suppressIfaceInvisibles dflags bndrs tyvars) ] + where + (bndrs, _, _) = splitIfaceSigmaTy kind isVanillaIfaceConDecl :: IfaceConDecl -> Bool isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs @@ -881,7 +898,8 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls pp_prefix_con = pprPrefixIfDeclBndr ss name (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec - ppr_ty = pprIfaceForAllPart (univ_tvs ++ ex_tvs) ctxt pp_tau + ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr (univ_tvs ++ ex_tvs)) + ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName @@ -944,6 +962,9 @@ ppr_rough :: Maybe IfaceTyCon -> SDoc ppr_rough Nothing = dot ppr_rough (Just tc) = ppr tc +tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr +tv_to_forall_bndr tv = IfaceTv tv Invisible + {- Note [Result type of a data family GADT] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1128,6 +1149,7 @@ freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfIdInfo i &&& freeNamesIfIdDetails d freeNamesIfDecl d@IfaceData{} = + freeNamesIfType (ifKind d) &&& freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfaceTyConParent (ifParent d) &&& freeNamesIfContext (ifCtxt d) &&& @@ -1135,16 +1157,15 @@ freeNamesIfDecl d@IfaceData{} = freeNamesIfDecl d@IfaceSynonym{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfType (ifSynRhs d) &&& - freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we - -- return names in the kind signature + freeNamesIfKind (ifSynKind d) freeNamesIfDecl d@IfaceFamily{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfFamFlav (ifFamFlav d) &&& - freeNamesIfKind (ifFamKind d) -- IA0_NOTE: because of promotion, we - -- return names in the kind signature + freeNamesIfKind (ifFamKind d) freeNamesIfDecl d@IfaceClass{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfContext (ifCtxt d) &&& + freeNamesIfType (ifKind d) &&& fnList freeNamesIfAT (ifATs d) &&& fnList freeNamesIfClsSig (ifSigs d) freeNamesIfDecl d@IfaceAxiom{} = @@ -1162,10 +1183,12 @@ freeNamesIfDecl d@IfacePatSyn{} = mkNameSet (map flSelector (ifFieldLabels d)) freeNamesIfAxBranch :: IfaceAxBranch -> NameSet -freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars - , ifaxbLHS = lhs - , ifaxbRHS = rhs }) = +freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars + , ifaxbCoVars = covars + , ifaxbLHS = lhs + , ifaxbRHS = rhs }) = freeNamesIfTvBndrs tyvars &&& + fnList freeNamesIfIdBndr covars &&& freeNamesIfTcArgs lhs &&& freeNamesIfType rhs @@ -1217,9 +1240,9 @@ freeNamesIfKind :: IfaceType -> NameSet freeNamesIfKind = freeNamesIfType freeNamesIfTcArgs :: IfaceTcArgs -> NameSet -freeNamesIfTcArgs (ITC_Type t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts -freeNamesIfTcArgs (ITC_Kind k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks -freeNamesIfTcArgs ITC_Nil = emptyNameSet +freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts +freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks +freeNamesIfTcArgs ITC_Nil = emptyNameSet freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet @@ -1227,9 +1250,12 @@ freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet -freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceForAllTy tv t) = + freeNamesIfForAllBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c +freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t @@ -1239,14 +1265,14 @@ freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceAppCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceForAllCo tv co) - = freeNamesIfTvBndr tv &&& freeNamesIfCoercion co +freeNamesIfCoercion (IfaceForAllCo _ kind_co co) + = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) = unitNameSet ax &&& fnList freeNamesIfCoercion cos -freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2) - = freeNamesIfType t1 &&& freeNamesIfType t2 +freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) + = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 freeNamesIfCoercion (IfaceSymCo c) = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2) @@ -1255,22 +1281,37 @@ freeNamesIfCoercion (IfaceNthCo _ co) = freeNamesIfCoercion co freeNamesIfCoercion (IfaceLRCo _ co) = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceInstCo co ty) - = freeNamesIfCoercion co &&& freeNamesIfType ty +freeNamesIfCoercion (IfaceInstCo co co2) + = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 +freeNamesIfCoercion (IfaceCoherenceCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceKindCo c) + = freeNamesIfCoercion c freeNamesIfCoercion (IfaceSubCo co) = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceAxiomRuleCo _ax tys cos) +freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) -- the axiom is just a string, so we don't count it as a name. - = fnList freeNamesIfType tys &&& - fnList freeNamesIfCoercion cos + = fnList freeNamesIfCoercion cos + +freeNamesIfProv :: IfaceUnivCoProv -> NameSet +freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet +freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfacePluginProv _) = emptyNameSet freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet freeNamesIfTvBndrs = fnList freeNamesIfTvBndr +freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet +freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv + freeNamesIfBndr :: IfaceBndr -> NameSet freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b +freeNamesIfBndrs :: [IfaceBndr] -> NameSet +freeNamesIfBndrs = fnList freeNamesIfBndr + freeNamesIfLetBndr :: IfaceLetBndr -> NameSet -- Remember IfaceLetBndr is used only for *nested* bindings -- The IdInfo can contain an unfolding (in the case of @@ -1283,7 +1324,7 @@ freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k -- kinds can have Names inside, because of promotion freeNamesIfIdBndr :: IfaceIdBndr -> NameSet -freeNamesIfIdBndr = freeNamesIfTvBndr +freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k freeNamesIfIdInfo :: IfaceIdInfo -> NameSet freeNamesIfIdInfo NoInfo = emptyNameSet @@ -1297,7 +1338,7 @@ freeNamesIfUnfold :: IfaceUnfolding -> NameSet freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfDFunUnfold bs es) = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es +freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v @@ -1434,7 +1475,7 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do putByte bh 5 put_ bh a1 put_ bh (occNameFS a2) @@ -1445,6 +1486,7 @@ instance Binary IfaceDecl where put_ bh a7 put_ bh a8 put_ bh a9 + put_ bh a10 put_ bh (IfaceAxiom a1 a2 a3 a4) = do putByte bh 6 @@ -1513,8 +1555,9 @@ instance Binary IfaceDecl where a7 <- get bh a8 <- get bh a9 <- get bh + a10 <- get bh occ <- return $! mkClsOccFS a2 - return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) + return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9 a10) 6 -> do a1 <- get bh a2 <- get bh a3 <- get bh @@ -1576,19 +1619,21 @@ instance Binary IfaceAT where return (IfaceAT dec defs) instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 + put_ bh a6 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh - return (IfaceAxBranch a1 a2 a3 a4 a5) + a6 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5 a6) instance Binary IfaceConDecls where put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 7bf949e24f..f744f812a7 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -13,19 +13,22 @@ module IfaceType ( IfExtName, IfLclName, IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), + IfaceUnivCoProv(..), IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyLit(..), IfaceTcArgs(..), - IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, + IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, + IfaceTvBndr, IfaceIdBndr, + IfaceForAllBndr(..), VisibilityFlag(..), -- Equality testing IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes, - eqIfaceTcArgs, eqIfaceTvBndrs, eqIfaceCoercion, + eqIfaceTcArgs, eqIfaceTvBndrs, -- Conversion from Type -> IfaceType toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar, toIfaceContext, toIfaceBndr, toIfaceIdBndr, - toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, - toIfaceTcArgs, + toIfaceTyCon, toIfaceTyCon_name, + toIfaceTcArgs, toIfaceTvBndrs, -- Conversion from IfaceTcArgs -> IfaceType tcArgsIfaceTypes, @@ -42,10 +45,11 @@ module IfaceType ( pprIfaceCoercion, pprParendIfaceCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, - suppressIfaceKinds, - stripIfaceKindVars, - stripKindArgs, - substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst + suppressIfaceInvisibles, + stripIfaceInvisVars, + stripInvisArgs, + substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst, + eqIfaceTvBndr ) where #include "HsVersions.h" @@ -54,7 +58,7 @@ import Coercion import DataCon ( isTupleDataCon ) import TcType import DynFlags -import TypeRep +import TyCoRep -- needs to convert core types to iface types import Unique( hasKey ) import TyCon hiding ( pprPromotionQuote ) import CoAxiom @@ -70,9 +74,10 @@ import Binary import Outputable import FastString import UniqSet +import VarEnv +import Data.Maybe import UniqFM import Util -import Data.Maybe( fromMaybe ) {- ************************************************************************ @@ -102,6 +107,14 @@ data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy type IfaceLamBndr = (IfaceBndr, IfaceOneShot) +{- +%************************************************************************ +%* * + IfaceType +%* * +%************************************************************************ +-} + ------------------------------- type IfaceKind = IfaceType @@ -111,11 +124,11 @@ data IfaceType -- A kind of universal type, used for types and kinds | IfaceAppTy IfaceType IfaceType | IfaceFunTy IfaceType IfaceType | IfaceDFunTy IfaceType IfaceType - | IfaceForAllTy IfaceTvBndr IfaceType - + | IfaceForAllTy IfaceForAllBndr IfaceType | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated - -- Includes newtypes, synonyms - + -- Includes newtypes, synonyms, tuples + | IfaceCastTy IfaceType IfaceCoercion + | IfaceCoercionTy IfaceCoercion | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) TupleSort IfaceTyConInfo -- A bit like IfaceTyCon IfaceTcArgs -- arity = length args @@ -129,15 +142,18 @@ data IfaceTyLit | IfaceStrTyLit FastString deriving (Eq) --- See Note [Suppressing kinds] +data IfaceForAllBndr + = IfaceTv IfaceTvBndr VisibilityFlag + +-- See Note [Suppressing invisible arguments] -- We use a new list type (rather than [(IfaceType,Bool)], because -- it'll be more compact and faster to parse in interface -- files. Rather than two bytes and two decisions (nil/cons, and -- type/kind) there'll just be one. data IfaceTcArgs = ITC_Nil - | ITC_Type IfaceType IfaceTcArgs - | ITC_Kind IfaceKind IfaceTcArgs + | ITC_Vis IfaceType IfaceTcArgs + | ITC_Invis IfaceKind IfaceTcArgs -- Encodes type constructors, kind constructors, -- coercion constructors, the lot. @@ -151,69 +167,79 @@ data IfaceTyConInfo -- Used to guide pretty-printing -- and to disambiguate D from 'D (they share a name) = NoIfaceTyConInfo | IfacePromotedDataCon - | IfacePromotedTyCon deriving (Eq) data IfaceCoercion - = IfaceReflCo Role IfaceType - | IfaceFunCo Role IfaceCoercion IfaceCoercion - | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] - | IfaceAppCo IfaceCoercion IfaceCoercion - | IfaceForAllCo IfaceTvBndr IfaceCoercion - | IfaceCoVarCo IfLclName - | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] - | IfaceUnivCo FastString Role IfaceType IfaceType - | IfaceSymCo IfaceCoercion - | IfaceTransCo IfaceCoercion IfaceCoercion - | IfaceNthCo Int IfaceCoercion - | IfaceLRCo LeftOrRight IfaceCoercion - | IfaceInstCo IfaceCoercion IfaceType - | IfaceSubCo IfaceCoercion - | IfaceAxiomRuleCo IfLclName [IfaceType] [IfaceCoercion] + = IfaceReflCo Role IfaceType + | IfaceFunCo Role IfaceCoercion IfaceCoercion + | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] + | IfaceAppCo IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion + | IfaceCoVarCo IfLclName + | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] + | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType + | IfaceSymCo IfaceCoercion + | IfaceTransCo IfaceCoercion IfaceCoercion + | IfaceNthCo Int IfaceCoercion + | IfaceLRCo LeftOrRight IfaceCoercion + | IfaceInstCo IfaceCoercion IfaceCoercion + | IfaceCoherenceCo IfaceCoercion IfaceCoercion + | IfaceKindCo IfaceCoercion + | IfaceSubCo IfaceCoercion + | IfaceAxiomRuleCo IfLclName [IfaceCoercion] + +data IfaceUnivCoProv + = IfaceUnsafeCoerceProv + | IfacePhantomProv IfaceCoercion + | IfaceProofIrrelProv IfaceCoercion + | IfacePluginProv String {- -************************************************************************ -* * +%************************************************************************ +%* * Functions over IFaceTypes * * ************************************************************************ -} -splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], [IfacePredType], IfaceType) +eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool +eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2 + +splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes splitIfaceSigmaTy ty - = (tvs, theta, tau) + = (bndrs, theta, tau) where - (tvs, rho) = split_foralls ty + (bndrs, rho) = split_foralls ty (theta, tau) = split_rho rho - split_foralls (IfaceForAllTy tv ty) - = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) } + split_foralls (IfaceForAllTy bndr ty) + = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } split_foralls rho = ([], rho) split_rho (IfaceDFunTy ty1 ty2) = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) -suppressIfaceKinds :: DynFlags -> [IfaceTvBndr] -> [a] -> [a] -suppressIfaceKinds dflags tys xs +suppressIfaceInvisibles :: DynFlags -> [IfaceForAllBndr] -> [a] -> [a] +suppressIfaceInvisibles dflags tys xs | gopt Opt_PrintExplicitKinds dflags = xs | otherwise = suppress tys xs where suppress _ [] = [] suppress [] a = a suppress (k:ks) a@(_:xs) - | isIfaceKindVar k = suppress ks xs - | otherwise = a + | isIfaceInvisBndr k = suppress ks xs + | otherwise = a -stripIfaceKindVars :: DynFlags -> [IfaceTvBndr] -> [IfaceTvBndr] -stripIfaceKindVars dflags tyvars +stripIfaceInvisVars :: DynFlags -> [IfaceForAllBndr] -> [IfaceForAllBndr] +stripIfaceInvisVars dflags tyvars | gopt Opt_PrintExplicitKinds dflags = tyvars - | otherwise = filterOut isIfaceKindVar tyvars + | otherwise = filterOut isIfaceInvisBndr tyvars -isIfaceKindVar :: IfaceTvBndr -> Bool -isIfaceKindVar (_, IfaceTyConApp tc _) = ifaceTyConName tc == superKindTyConName -isIfaceKindVar _ = False +isIfaceInvisBndr :: IfaceForAllBndr -> Bool +isIfaceInvisBndr (IfaceTv _ Visible) = False +isIfaceInvisBndr _ = True ifTyVarsOfType :: IfaceType -> UniqSet IfLclName ifTyVarsOfType ty @@ -225,19 +251,62 @@ ifTyVarsOfType ty -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res IfaceDFunTy arg res -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res - IfaceForAllTy (var,t) ty - -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets` - ifTyVarsOfType t - IfaceTyConApp _ args -> ifTyVarsOfArgs args + IfaceForAllTy bndr ty + -> let (free, bound) = ifTyVarsOfForAllBndr bndr in + delListFromUniqSet (ifTyVarsOfType ty) bound `unionUniqSets` free + IfaceTyConApp _ args -> ifTyVarsOfArgs args + IfaceLitTy _ -> emptyUniqSet + IfaceCastTy ty co + -> ifTyVarsOfType ty `unionUniqSets` ifTyVarsOfCoercion co + IfaceCoercionTy co -> ifTyVarsOfCoercion co IfaceTupleTy _ _ args -> ifTyVarsOfArgs args - IfaceLitTy _ -> emptyUniqSet + +ifTyVarsOfForAllBndr :: IfaceForAllBndr + -> ( UniqSet IfLclName -- names used free in the binder + , [IfLclName] ) -- names bound by this binder +ifTyVarsOfForAllBndr (IfaceTv (name, kind) _) = (ifTyVarsOfType kind, [name]) ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName ifTyVarsOfArgs args = argv emptyUniqSet args where - argv vs (ITC_Type t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts - argv vs (ITC_Kind k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks - argv vs ITC_Nil = vs + argv vs (ITC_Vis t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts + argv vs (ITC_Invis k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks + argv vs ITC_Nil = vs + +ifTyVarsOfCoercion :: IfaceCoercion -> UniqSet IfLclName +ifTyVarsOfCoercion = go + where + go (IfaceReflCo _ ty) = ifTyVarsOfType ty + go (IfaceFunCo _ c1 c2) = go c1 `unionUniqSets` go c2 + go (IfaceTyConAppCo _ _ cos) = ifTyVarsOfCoercions cos + go (IfaceAppCo c1 c2) = go c1 `unionUniqSets` go c2 + go (IfaceForAllCo (bound, _) kind_co co) + = go co `delOneFromUniqSet` bound `unionUniqSets` go kind_co + go (IfaceCoVarCo cv) = unitUniqSet cv + go (IfaceAxiomInstCo _ _ cos) = ifTyVarsOfCoercions cos + go (IfaceUnivCo p _ ty1 ty2) = go_prov p `unionUniqSets` + ifTyVarsOfType ty1 `unionUniqSets` + ifTyVarsOfType ty2 + go (IfaceSymCo co) = go co + go (IfaceTransCo c1 c2) = go c1 `unionUniqSets` go c2 + go (IfaceNthCo _ co) = go co + go (IfaceLRCo _ co) = go co + go (IfaceInstCo c1 c2) = go c1 `unionUniqSets` go c2 + go (IfaceCoherenceCo c1 c2) = go c1 `unionUniqSets` go c2 + go (IfaceKindCo co) = go co + go (IfaceSubCo co) = go co + go (IfaceAxiomRuleCo rule cos) + = unionManyUniqSets + [ unitUniqSet rule + , ifTyVarsOfCoercions cos ] + + go_prov IfaceUnsafeCoerceProv = emptyUniqSet + go_prov (IfacePhantomProv co) = go co + go_prov (IfaceProofIrrelProv co) = go co + go_prov (IfacePluginProv _) = emptyUniqSet + +ifTyVarsOfCoercions :: [IfaceCoercion] -> UniqSet IfLclName +ifTyVarsOfCoercions = foldr (unionUniqSets . ifTyVarsOfCoercion) emptyUniqSet {- Substitutions on IfaceType. This is only used during pretty-printing to construct @@ -262,14 +331,41 @@ substIfaceType env ty go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys) go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys) go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) + go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) + + go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty) + go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) + go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) + go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) + go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) + go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv + go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) + go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) + go_co (IfaceSymCo co) = IfaceSymCo (go_co co) + go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) + go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) + go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) + go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) + go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2) + go_co (IfaceKindCo co) = IfaceKindCo (go_co co) + go_co (IfaceSubCo co) = IfaceSubCo (go_co co) + go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) + + go_cos = map go_co + + go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv + go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) + go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) + go_prov (IfacePluginProv str) = IfacePluginProv str substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs substIfaceTcArgs env args = go args where - go ITC_Nil = ITC_Nil - go (ITC_Type ty tys) = ITC_Type (substIfaceType env ty) (go tys) - go (ITC_Kind ty tys) = ITC_Kind (substIfaceType env ty) (go tys) + go ITC_Nil = ITC_Nil + go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys) + go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys) substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType substIfaceTyVar env tv @@ -282,6 +378,14 @@ substIfaceTyVar env tv Equality over IfaceTypes * * ************************************************************************ + +Note [No kind check in ifaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We check iface types for equality only when checking the consistency +between two user-written signatures. In these cases, there is no possibility +for a kind mismatch. So we omit the kind check (which would be impossible to +write, anyway.) + -} -- Like an RnEnv2, but mapping from FastString to deBruijn index @@ -313,6 +417,7 @@ extendIfRnEnv2 IRV2 { ifenvL = lenv , ifenv_next = n + 1 } +-- See Note [No kind check in ifaces] eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) = case (rnIfOccL env tv1, rnIfOccR env tv2) of @@ -326,22 +431,33 @@ eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22) = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22) = eqIfaceType env t11 t21 && eqIfaceType env t12 t22 -eqIfaceType env (IfaceForAllTy (tv1, k1) t1) (IfaceForAllTy (tv2, k2) t2) - = eqIfaceType env k1 k2 && eqIfaceType (extendIfRnEnv2 env tv1 tv2) t1 t2 +eqIfaceType env (IfaceForAllTy bndr1 t1) (IfaceForAllTy bndr2 t2) + = eqIfaceForAllBndr env bndr1 bndr2 (\env' -> eqIfaceType env' t1 t2) eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2) = tc1 == tc2 && eqIfaceTcArgs env tys1 tys2 eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2) = s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2 +eqIfaceType env (IfaceCastTy t1 _) (IfaceCastTy t2 _) + = eqIfaceType env t1 t2 +eqIfaceType _ (IfaceCoercionTy {}) (IfaceCoercionTy {}) + = True eqIfaceType _ _ _ = False eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2) +eqIfaceForAllBndr :: IfRnEnv2 -> IfaceForAllBndr -> IfaceForAllBndr + -> (IfRnEnv2 -> Bool) -- continuation + -> Bool +eqIfaceForAllBndr env (IfaceTv (tv1, k1) vis1) (IfaceTv (tv2, k2) vis2) k + = eqIfaceType env k1 k2 && vis1 == vis2 && + k (extendIfRnEnv2 env tv1 tv2) + eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool eqIfaceTcArgs _ ITC_Nil ITC_Nil = True -eqIfaceTcArgs env (ITC_Type ty1 tys1) (ITC_Type ty2 tys2) +eqIfaceTcArgs env (ITC_Vis ty1 tys1) (ITC_Vis ty2 tys2) = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2 -eqIfaceTcArgs env (ITC_Kind ty1 tys1) (ITC_Kind ty2 tys2) +eqIfaceTcArgs env (ITC_Invis ty1 tys1) (ITC_Invis ty2 tys2) = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2 eqIfaceTcArgs _ _ _ = False @@ -355,57 +471,6 @@ eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2) = eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2 eqIfaceTvBndrs _ _ _ = Nothing --- coreEqCoercion2 -eqIfaceCoercion :: IfRnEnv2 -> IfaceCoercion -> IfaceCoercion -> Bool -eqIfaceCoercion env (IfaceReflCo eq1 ty1) (IfaceReflCo eq2 ty2) - = eq1 == eq2 && eqIfaceType env ty1 ty2 -eqIfaceCoercion env (IfaceFunCo eq1 co11 co12) (IfaceFunCo eq2 co21 co22) - = eq1 == eq2 && eqIfaceCoercion env co11 co21 - && eqIfaceCoercion env co12 co22 -eqIfaceCoercion env (IfaceTyConAppCo eq1 tc1 cos1) (IfaceTyConAppCo eq2 tc2 cos2) - = eq1 == eq2 && tc1 == tc2 && all2 (eqIfaceCoercion env) cos1 cos2 -eqIfaceCoercion env (IfaceAppCo co11 co12) (IfaceAppCo co21 co22) - = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22 - -eqIfaceCoercion env (IfaceForAllCo (v1,k1) co1) (IfaceForAllCo (v2,k2) co2) - = eqIfaceType env k1 k2 && - eqIfaceCoercion (extendIfRnEnv2 env v1 v2) co1 co2 - -eqIfaceCoercion env (IfaceCoVarCo cv1) (IfaceCoVarCo cv2) - = rnIfOccL env cv1 == rnIfOccR env cv2 - -eqIfaceCoercion env (IfaceAxiomInstCo con1 ind1 cos1) - (IfaceAxiomInstCo con2 ind2 cos2) - = con1 == con2 - && ind1 == ind2 - && all2 (eqIfaceCoercion env) cos1 cos2 - --- the provenance string is just a note, so don't use in comparisons -eqIfaceCoercion env (IfaceUnivCo _ r1 ty11 ty12) (IfaceUnivCo _ r2 ty21 ty22) - = r1 == r2 && eqIfaceType env ty11 ty21 && eqIfaceType env ty12 ty22 - -eqIfaceCoercion env (IfaceSymCo co1) (IfaceSymCo co2) - = eqIfaceCoercion env co1 co2 - -eqIfaceCoercion env (IfaceTransCo co11 co12) (IfaceTransCo co21 co22) - = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22 - -eqIfaceCoercion env (IfaceNthCo d1 co1) (IfaceNthCo d2 co2) - = d1 == d2 && eqIfaceCoercion env co1 co2 -eqIfaceCoercion env (IfaceLRCo d1 co1) (IfaceLRCo d2 co2) - = d1 == d2 && eqIfaceCoercion env co1 co2 - -eqIfaceCoercion env (IfaceInstCo co1 ty1) (IfaceInstCo co2 ty2) - = eqIfaceCoercion env co1 co2 && eqIfaceType env ty1 ty2 - -eqIfaceCoercion env (IfaceSubCo co1) (IfaceSubCo co2) - = eqIfaceCoercion env co1 co2 - -eqIfaceCoercion env (IfaceAxiomRuleCo a1 ts1 cs1) (IfaceAxiomRuleCo a2 ts2 cs2) - = a1 == a2 && all2 (eqIfaceType env) ts1 ts2 && all2 (eqIfaceCoercion env) cs1 cs2 - -eqIfaceCoercion _ _ _ = False - {- ************************************************************************ * * @@ -414,39 +479,52 @@ eqIfaceCoercion _ _ _ = False ************************************************************************ -} -stripKindArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs -stripKindArgs dflags tys +stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs +stripInvisArgs dflags tys | gopt Opt_PrintExplicitKinds dflags = tys - | otherwise = suppressKinds tys + | otherwise = suppress_invis tys where - suppressKinds c + suppress_invis c = case c of - ITC_Kind _ ts -> suppressKinds ts + ITC_Invis _ ts -> suppress_invis ts _ -> c toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs --- See Note [Suppressing kinds] +-- See Note [Suppressing invisible arguments] toIfaceTcArgs tc ty_args - = go (tyConKind tc) ty_args + = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args where - go _ [] = ITC_Nil - go (ForAllTy _ res) (t:ts) = ITC_Kind (toIfaceKind t) (go res ts) - go (FunTy _ res) (t:ts) = ITC_Type (toIfaceType t) (go res ts) - go kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) - ITC_Type (toIfaceType t) (go kind ts) -- Ill-kinded + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = ITC_Nil + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy bndr res) (t:ts) + | isVisibleBinder bndr = ITC_Vis t' ts' + | otherwise = ITC_Invis t' ts' + where + t' = toIfaceType t + ts' = go (extendTCvSubstBinder env bndr t) res ts + + go env (TyVarTy tv) ts + | Just ki <- lookupTyVar env tv = go env ki ts + go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) + ITC_Vis (toIfaceType t) (go env kind ts) -- Ill-kinded tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType] tcArgsIfaceTypes ITC_Nil = [] -tcArgsIfaceTypes (ITC_Kind t ts) = t : tcArgsIfaceTypes ts -tcArgsIfaceTypes (ITC_Type t ts) = t : tcArgsIfaceTypes ts +tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts +tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts {- -Note [Suppressing kinds] -~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Suppressing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use the IfaceTcArgs to specify which of the arguments to a type -constructor instantiate a for-all, and which are regular kind args. -This in turn used to control kind-suppression when printing types, -under the control of -fprint-explicit-kinds. See also TypeRep.suppressKinds. +constructor should be visible. +This in turn used to control suppression when printing types, +under the control of -fprint-explicit-kinds. +See also Type.filterOutInvisibleTypes. For example, given T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism 'Just :: forall k. k -> 'Maybe k -- Promoted @@ -491,7 +569,11 @@ pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil) - | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv + | isLiftedTypeKindTyConName (ifaceTyConName tc) = ppr tv +pprIfaceTvBndr (tv, IfaceTyConApp tc (ITC_Vis (IfaceTyConApp lifted ITC_Nil) ITC_Nil)) + | ifaceTyConName tc == tYPETyConName + , ifaceTyConName lifted == liftedDataConName + = ppr tv pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc @@ -553,6 +635,13 @@ ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) = maybeParen ctxt_prec TyConPrec $ ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2 +ppr_ty ctxt_prec (IfaceCastTy ty co) + = maybeParen ctxt_prec FunPrec $ + sep [ppr_ty FunPrec ty, ptext (sLit "`cast`"), ppr_co FunPrec co] + +ppr_ty ctxt_prec (IfaceCoercionTy co) + = ppr_co ctxt_prec co + ppr_ty ctxt_prec ty = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty) @@ -567,9 +656,9 @@ ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc ppr_tc_args ctx_prec args = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts in case args of - ITC_Nil -> empty - ITC_Type t ts -> pprTys t ts - ITC_Kind t ts -> pprTys t ts + ITC_Nil -> empty + ITC_Vis t ts -> pprTys t ts + ITC_Invis t ts -> pprTys t ts ------------------- ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc @@ -578,11 +667,19 @@ ppr_iface_sigma_type show_foralls_unconditionally ty where (tvs, theta, tau) = splitIfaceSigmaTy ty -pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc +------------------- +instance Outputable IfaceForAllBndr where + ppr = pprIfaceForAllBndr + +pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfaceType] -> SDoc -> SDoc pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc +pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc +pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs + , sdoc ] + ppr_iface_forall_part :: Outputable a - => Bool -> [IfaceTvBndr] -> [a] -> SDoc -> SDoc + => Bool -> [IfaceForAllBndr] -> [a] -> SDoc -> SDoc ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc = sep [ if show_foralls_unconditionally then pprIfaceForAll tvs @@ -590,23 +687,59 @@ ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc , pprIfaceContextArr ctxt , sdoc] -pprIfaceForAll :: [IfaceTvBndr] -> SDoc -pprIfaceForAll [] = empty -pprIfaceForAll tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +pprIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll bndrs@(IfaceTv _ vis : _) + = add_separator (text "forall" <+> doc) <+> pprIfaceForAll bndrs' + where + (bndrs', doc) = ppr_itv_bndrs bndrs vis + + add_separator stuff = case vis of + Invisible -> stuff <> dot + Visible -> stuff <+> arrow + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +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) + | otherwise = (all_bndrs, empty) +ppr_itv_bndrs [] _ = ([], empty) + +pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCo [] = empty +pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot + +pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs + +pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc +pprIfaceForAllBndr (IfaceTv tv _) = pprIfaceTvBndr tv + +pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc +pprIfaceForAllCoBndr (tv, kind_co) + = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) pprIfaceSigmaType :: IfaceType -> SDoc pprIfaceSigmaType ty = ppr_iface_sigma_type False ty -pprUserIfaceForAll :: [IfaceTvBndr] -> SDoc +pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs = sdocWithDynFlags $ \dflags -> ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ pprIfaceForAll tvs where - tv_has_kind_var (_,t) = not (isEmptyUniqSet (ifTyVarsOfType t)) + tv_has_kind_var bndr + = not (isEmptyUniqSet (fst (ifTyVarsOfForAllBndr bndr))) + ------------------- --- See equivalent function in TypeRep.hs +-- See equivalent function in TyCoRep.hs pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print -- it in list notation [t1, ...]. @@ -625,7 +758,7 @@ pprIfaceTyList ctxt_prec ty1 ty2 -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl gather (IfaceTyConApp tc tys) | tcname == consDataConName - , (ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil))) <- tys + , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys , (args, tl) <- gather ty2 = (ty1:args, tl) | tcname == nilDataConName @@ -639,18 +772,25 @@ pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args) pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc pprTyTcApp ctxt_prec tc tys dflags | ifaceTyConName tc == getName ipTyCon - , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys + , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty | ifaceTyConName tc == consDataConName , not (gopt Opt_PrintExplicitKinds dflags) - , ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil)) <- tys + , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys = pprIfaceTyList ctxt_prec ty1 ty2 + | ifaceTyConName tc == tYPETyConName + , ITC_Vis (IfaceTyConApp lev_tc ITC_Nil) ITC_Nil <- tys + = let n = ifaceTyConName lev_tc in + if n == liftedDataConName then char '*' + else if n == unliftedDataConName then char '#' + else pprPanic "IfaceType.pprTyTcApp" (ppr lev_tc) + | otherwise = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds where - tys_wo_kinds = tcArgsIfaceTypes $ stripKindArgs dflags tys + tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys @@ -670,7 +810,8 @@ ppr_iface_tc_app pp ctxt_prec tc tys -- we know nothing of precedence though = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2 - | tc_name == liftedTypeKindTyConName || tc_name == unliftedTypeKindTyConName + | tc_name == starKindTyConName || tc_name == unliftedTypeKindTyConName + || tc_name == unicodeStarKindTyConName = ppr tc -- Do not wrap *, # in parens | otherwise @@ -680,8 +821,15 @@ ppr_iface_tc_app pp ctxt_prec tc tys pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc pprTuple sort info args - = pprPromotionQuoteI info <> - tupleParens sort (pprWithCommas pprIfaceType (tcArgsIfaceTypes args)) + = -- drop the levity vars. + -- See Note [Unboxed tuple levity vars] in TyCon + let tys = tcArgsIfaceTypes args + args' = case sort of + UnboxedTuple -> drop (length tys `div` 2) tys + _ -> tys + in + pprPromotionQuoteI info <> + tupleParens sort (pprWithCommas pprIfaceType args') ppr_tylit :: IfaceTyLit -> SDoc ppr_tylit (IfaceNumTyLit n) = integer n @@ -707,30 +855,32 @@ ppr_co _ (IfaceTyConAppCo r tc cos) ppr_co ctxt_prec (IfaceAppCo co1 co2) = maybeParen ctxt_prec TyConPrec $ ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2 -ppr_co ctxt_prec co@(IfaceForAllCo _ _) - = maybeParen ctxt_prec FunPrec (sep [ppr_tvs, pprIfaceCoercion inner_co]) +ppr_co ctxt_prec co@(IfaceForAllCo {}) + = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)) where (tvs, inner_co) = split_co co - ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot - split_co (IfaceForAllCo tv co') - = let (tvs, co'') = split_co co' in (tv:tvs,co'') + split_co (IfaceForAllCo (name, _) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') split_co co' = ([], co') ppr_co _ (IfaceCoVarCo covar) = ppr covar -ppr_co ctxt_prec (IfaceUnivCo s r ty1 ty2) +ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) = maybeParen ctxt_prec TyConPrec $ - ptext (sLit "UnivCo") <+> ftext s <+> ppr r <+> + ptext (sLit "UnsafeCo") <+> ppr r <+> pprParendIfaceType ty1 <+> pprParendIfaceType ty2 +ppr_co _ (IfaceUnivCo _ _ ty1 ty2) + = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 ) + ppr_co ctxt_prec (IfaceInstCo co ty) = maybeParen ctxt_prec TyConPrec $ - ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty + ptext (sLit "Inst") <+> pprParendIfaceCoercion co + <+> pprParendIfaceCoercion ty -ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos) - = maybeParen ctxt_prec TyConPrec - (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))]) +ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) + = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos) ppr_co ctxt_prec co = ppr_special_co ctxt_prec doc cos @@ -766,7 +916,6 @@ pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc) pprPromotionQuoteI :: IfaceTyConInfo -> SDoc pprPromotionQuoteI NoIfaceTyConInfo = empty pprPromotionQuoteI IfacePromotedDataCon = char '\'' -pprPromotionQuoteI IfacePromotedTyCon = ifPprDebug (char '\'') instance Outputable IfaceCoercion where ppr = pprIfaceCoercion @@ -781,14 +930,12 @@ instance Binary IfaceTyCon where instance Binary IfaceTyConInfo where put_ bh NoIfaceTyConInfo = putByte bh 0 put_ bh IfacePromotedDataCon = putByte bh 1 - put_ bh IfacePromotedTyCon = putByte bh 2 get bh = do i <- getByte bh case i of 0 -> return NoIfaceTyConInfo - 1 -> return IfacePromotedDataCon - _ -> return IfacePromotedTyCon + _ -> return IfacePromotedDataCon instance Outputable IfaceTyLit where ppr = ppr_tylit @@ -806,12 +953,22 @@ instance Binary IfaceTyLit where ; return (IfaceStrTyLit n) } _ -> panic ("get IfaceTyLit " ++ show tag) +instance Binary IfaceForAllBndr where + put_ bh (IfaceTv tv vis) = do + put_ bh tv + put_ bh vis + + get bh = do + tv <- get bh + vis <- get bh + return (IfaceTv tv vis) + instance Binary IfaceTcArgs where put_ bh tk = case tk of - ITC_Type t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts - ITC_Kind t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts - ITC_Nil -> putByte bh 2 + ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts + ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts + ITC_Nil -> putByte bh 2 get bh = do c <- getByte bh @@ -819,11 +976,11 @@ instance Binary IfaceTcArgs where 0 -> do t <- get bh ts <- get bh - return $! ITC_Type t ts + return $! ITC_Vis t ts 1 -> do t <- get bh ts <- get bh - return $! ITC_Kind t ts + return $! ITC_Invis t ts 2 -> return ITC_Nil _ -> panic ("get IfaceTcArgs " ++ show c) @@ -862,10 +1019,14 @@ instance Binary IfaceType where put_ bh ah put_ bh (IfaceTyConApp tc tys) = do { putByte bh 5; put_ bh tc; put_ bh tys } + put_ bh (IfaceCastTy a b) + = do { putByte bh 6; put_ bh a; put_ bh b } + put_ bh (IfaceCoercionTy a) + = do { putByte bh 7; put_ bh a } put_ bh (IfaceTupleTy s i tys) - = do { putByte bh 6; put_ bh s; put_ bh i; put_ bh tys } + = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } put_ bh (IfaceLitTy n) - = do { putByte bh 7; put_ bh n } + = do { putByte bh 9; put_ bh n } get bh = do h <- getByte bh @@ -886,7 +1047,12 @@ instance Binary IfaceType where return (IfaceDFunTy ag ah) 5 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } - 6 -> do { s <- get bh; i <- get bh; tys <- get bh + 6 -> do { a <- get bh; b <- get bh + ; return (IfaceCastTy a b) } + 7 -> do { a <- get bh + ; return (IfaceCoercionTy a) } + + 8 -> do { s <- get bh; i <- get bh; tys <- get bh ; return (IfaceTupleTy s i tys) } _ -> do n <- get bh return (IfaceLitTy n) @@ -910,10 +1076,11 @@ instance Binary IfaceCoercion where putByte bh 4 put_ bh a put_ bh b - put_ bh (IfaceForAllCo a b) = do + put_ bh (IfaceForAllCo a b c) = do putByte bh 5 put_ bh a put_ bh b + put_ bh c put_ bh (IfaceCoVarCo a) = do putByte bh 6 put_ bh a @@ -947,14 +1114,20 @@ instance Binary IfaceCoercion where putByte bh 13 put_ bh a put_ bh b - put_ bh (IfaceSubCo a) = do + put_ bh (IfaceCoherenceCo a b) = do putByte bh 14 put_ bh a - put_ bh (IfaceAxiomRuleCo a b c) = do + put_ bh b + put_ bh (IfaceKindCo a) = do putByte bh 15 put_ bh a + put_ bh (IfaceSubCo a) = do + putByte bh 16 + put_ bh a + put_ bh (IfaceAxiomRuleCo a b) = do + putByte bh 17 + put_ bh a put_ bh b - put_ bh c get bh = do tag <- getByte bh @@ -975,7 +1148,8 @@ instance Binary IfaceCoercion where return $ IfaceAppCo a b 5 -> do a <- get bh b <- get bh - return $ IfaceForAllCo a b + c <- get bh + return $ IfaceForAllCo a b c 6 -> do a <- get bh return $ IfaceCoVarCo a 7 -> do a <- get bh @@ -1002,13 +1176,42 @@ instance Binary IfaceCoercion where b <- get bh return $ IfaceInstCo a b 14-> do a <- get bh - return $ IfaceSubCo a + b <- get bh + return $ IfaceCoherenceCo a b 15-> do a <- get bh + return $ IfaceKindCo a + 16-> do a <- get bh + return $ IfaceSubCo a + 17-> do a <- get bh b <- get bh - c <- get bh - return $ IfaceAxiomRuleCo a b c + return $ IfaceAxiomRuleCo a b _ -> panic ("get IfaceCoercion " ++ show tag) +instance Binary IfaceUnivCoProv where + put_ bh IfaceUnsafeCoerceProv = putByte bh 1 + put_ bh (IfacePhantomProv a) = do + putByte bh 2 + put_ bh a + put_ bh (IfaceProofIrrelProv a) = do + putByte bh 3 + put_ bh a + put_ bh (IfacePluginProv a) = do + putByte bh 4 + put_ bh a + + get bh = do + tag <- getByte bh + case tag of + 1 -> return $ IfaceUnsafeCoerceProv + 2 -> do a <- get bh + return $ IfacePhantomProv a + 3 -> do a <- get bh + return $ IfaceProofIrrelProv a + 4 -> do a <- get bh + return $ IfacePluginProv a + _ -> panic ("get IfaceUnivCoProv " ++ show tag) + + instance Binary (DefMethSpec IfaceType) where put_ bh VanillaDM = putByte bh 0 put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t @@ -1027,12 +1230,16 @@ instance Binary (DefMethSpec IfaceType) where -} ---------------- -toIfaceTvBndr :: TyVar -> (IfLclName, IfaceType) -toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar)) +toIfaceTvBndr :: TyVar -> (IfLclName, IfaceKind) +toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar) + , toIfaceKind (tyVarKind tyvar) + ) + toIfaceIdBndr :: Id -> (IfLclName, IfaceType) toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) -toIfaceTvBndrs :: [TyVar] -> [(IfLclName, IfaceType)] -toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars + +toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] +toIfaceTvBndrs = map toIfaceTvBndr toIfaceBndr :: Var -> IfaceBndr toIfaceBndr var @@ -1048,21 +1255,19 @@ toIfaceType :: Type -> IfaceType toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) -toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) -toIfaceType (FunTy t1 t2) +toIfaceType (ForAllTy (Named tv vis) t) + = IfaceForAllTy (varToIfaceForAllBndr tv vis) (toIfaceType t) +toIfaceType (ForAllTy (Anon t1) t2) | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (CastTy ty co) = IfaceCastTy (toIfaceType ty) (toIfaceCoercion co) +toIfaceType (CoercionTy co) = IfaceCoercionTy (toIfaceCoercion co) -toIfaceType (TyConApp tc tys) -- Look for the three sorts of saturated tuple +toIfaceType (TyConApp tc tys) -- Look for the two sorts of saturated tuple | Just sort <- tyConTuple_maybe tc , n_tys == arity = IfaceTupleTy sort NoIfaceTyConInfo (toIfaceTcArgs tc tys) - | Just tc' <- isPromotedTyCon_maybe tc - , Just sort <- tyConTuple_maybe tc' - , n_tys == arity - = IfaceTupleTy sort IfacePromotedTyCon (toIfaceTcArgs tc tys) - | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , n_tys == 2*arity @@ -1080,6 +1285,10 @@ toIfaceTyVar = occNameFS . getOccName toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName +varToIfaceForAllBndr :: TyVar -> VisibilityFlag -> IfaceForAllBndr +varToIfaceForAllBndr v vis + = IfaceTv (toIfaceTvBndr v) vis + ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc @@ -1087,7 +1296,6 @@ toIfaceTyCon tc where tc_name = tyConName tc info | isPromotedDataCon tc = IfacePromotedDataCon - | isPromotedTyCon tc = IfacePromotedTyCon | otherwise = NoIfaceTyConInfo toIfaceTyCon_name :: Name -> IfaceTyCon @@ -1114,27 +1322,36 @@ toIfaceCoercion (TyConAppCo r tc cos) | tc `hasKey` funTyConKey , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res) | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) - (map toIfaceCoercion cos) + (map toIfaceCoercion cos) toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1) (toIfaceCoercion co2) -toIfaceCoercion (ForAllCo v co) = IfaceForAllCo (toIfaceTvBndr v) +toIfaceCoercion (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv) + (toIfaceCoercion k) (toIfaceCoercion co) toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv) toIfaceCoercion (AxiomInstCo con ind cos) = IfaceAxiomInstCo (coAxiomName con) ind (map toIfaceCoercion cos) -toIfaceCoercion (UnivCo s r ty1 ty2)= IfaceUnivCo s r (toIfaceType ty1) - (toIfaceType ty2) +toIfaceCoercion (UnivCo p r t1 t2) = IfaceUnivCo (toIfaceUnivCoProv p) r + (toIfaceType t1) + (toIfaceType t2) toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co) toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1) (toIfaceCoercion co2) toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co) toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co) -toIfaceCoercion (InstCo co ty) = IfaceInstCo (toIfaceCoercion co) - (toIfaceType ty) +toIfaceCoercion (InstCo co arg) = IfaceInstCo (toIfaceCoercion co) + (toIfaceCoercion arg) +toIfaceCoercion (CoherenceCo c1 c2) = IfaceCoherenceCo (toIfaceCoercion c1) + (toIfaceCoercion c2) +toIfaceCoercion (KindCo c) = IfaceKindCo (toIfaceCoercion c) toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co) - -toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo - (coaxrName co) - (map toIfaceType ts) +toIfaceCoercion (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map toIfaceCoercion cs) + +toIfaceUnivCoProv :: UnivCoProvenance -> IfaceUnivCoProv +toIfaceUnivCoProv UnsafeCoerceProv = IfaceUnsafeCoerceProv +toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co) +toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co) +toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str +toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h) diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index e428b58e35..644bea9691 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -69,7 +69,6 @@ import Coercion( tidyCo ) import Annotations import CoreSyn import Class -import Kind import TyCon import CoAxiom import ConLike @@ -1315,8 +1314,8 @@ patSynToIfaceDecl ps } where (univ_tvs, req_theta, ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps - (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs - (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs + (env1, univ_tvs') = tidyTyCoVarBndrs emptyTidyEnv univ_tvs + (env2, ex_tvs') = tidyTyCoVarBndrs env1 ex_tvs to_if_pr (id, needs_dummy) = (idName id, needs_dummy) -------------------------- @@ -1350,15 +1349,18 @@ coAxBranchToIfaceBranch tc lhs_s -- use this one for standalone branches without incompatibles coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs +coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs , cab_roles = roles, cab_rhs = rhs }) - = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs - , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs - , ifaxbRoles = roles - , ifaxbRHS = tidyToIfaceType env1 rhs + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs + , ifaxbCoVars = map toIfaceIdBndr cvs + , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs + , ifaxbRoles = roles + , ifaxbRHS = tidyToIfaceType env1 rhs , ifaxbIncomps = [] } where - (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs + + (env1, tv_bndrs) = tidyTyClTyCoVarBndrs emptyTidyEnv tvs -- Don't re-bind in-scope tyvars -- See Note [CoAxBranch type variables] in CoAxiom @@ -1377,7 +1379,7 @@ tyConToIfaceDecl env tycon ifTyVars = if_tc_tyvars, ifRoles = tyConRoles tycon, ifSynRhs = if_syn_type syn_rhs, - ifSynKind = tidyToIfaceType tc_env1 (tyConResKind tycon) + ifSynKind = if_kind }) | Just fam_flav <- famTyConFlav_maybe tycon @@ -1386,13 +1388,14 @@ tyConToIfaceDecl env tycon ifTyVars = if_tc_tyvars, ifResVar = if_res_var, ifFamFlav = to_if_fam_flav fam_flav, - ifFamKind = tidyToIfaceType tc_env1 (tyConResKind tycon), + ifFamKind = if_kind, ifFamInj = familyTyConInjectivityInfo tycon }) | isAlgTyCon tycon = ( tc_env1 , IfaceData { ifName = getOccName tycon, + ifKind = if_kind, ifCType = tyConCType tycon, ifTyVars = if_tc_tyvars, ifRoles = tyConRoles tycon, @@ -1400,7 +1403,6 @@ tyConToIfaceDecl env tycon ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifPromotable = isPromotableTyCon tycon, ifParent = parent }) | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon @@ -1410,15 +1412,16 @@ tyConToIfaceDecl env tycon ifCType = Nothing, ifTyVars = funAndPrimTyVars, ifRoles = tyConRoles tycon, + ifKind = if_kind, ifCtxt = [], ifCons = IfDataTyCon [] False [], ifRec = boolToRecFlag False, ifGadtSyntax = False, - ifPromotable = False, ifParent = IfNoParent }) where - (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) - if_tc_tyvars = toIfaceTvBndrs tc_tyvars + (tc_env1, tc_tyvars) = tidyTyClTyCoVarBndrs env (tyConTyVars tycon) + if_tc_tyvars = toIfaceTvBndrs tc_tyvars + if_kind = tidyToIfaceType tc_env1 (tyConKind tycon) if_syn_type ty = tidyToIfaceType tc_env1 ty if_res_var = getFS `fmap` tyConFamilyResVar_maybe tycon @@ -1460,7 +1463,7 @@ tyConToIfaceDecl env tycon ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConExTvs = toIfaceTvBndrs ex_tvs', - ifConEqSpec = map to_eq_spec eq_spec, + ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, ifConFields = map (nameOccName . flSelector) @@ -1470,7 +1473,8 @@ tyConToIfaceDecl env tycon ifConSrcStricts = map toIfaceSrcBang (dataConSrcBangs data_con)} where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con -- Tidy the univ_tvs of the data constructor to be identical -- to the tyConTyVars of the type constructor. This means @@ -1482,7 +1486,7 @@ tyConToIfaceDecl env tycon con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) -- A bit grimy, perhaps, but it's simple! - (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs + (con_env2, ex_tvs') = tidyTyCoVarBndrs con_env1 ex_tvs to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty) ifaceOverloaded flds = case fsEnvElts flds of @@ -1510,9 +1514,10 @@ classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) classToIfaceDecl env clas = ( env1 , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, - ifName = getOccName (classTyCon clas), + ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs clas_tyvars', ifRoles = tyConRoles (classTyCon clas), + ifKind = tidyToIfaceType env1 (tyConKind tycon), ifFDs = map toIfaceFD clas_fds, ifATs = map toIfaceAT clas_ats, ifSigs = map toIfaceClassOp op_stuff, @@ -1523,7 +1528,7 @@ classToIfaceDecl env clas = classExtraBigSig clas tycon = classTyCon clas - (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars + (env1, clas_tyvars') = tidyTyCoVarBndrs env clas_tyvars toIfaceAT :: ClassATItem -> IfaceAT toIfaceAT (ATI tc def) @@ -1562,16 +1567,16 @@ tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext tidyToIfaceContext env theta = map (tidyToIfaceType env) theta -tidyTyClTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyTyClTyVarBndrs env tvs = mapAccumL tidyTyClTyVarBndr env tvs +tidyTyClTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyTyClTyCoVarBndrs env tvs = mapAccumL tidyTyClTyCoVarBndr env tvs -tidyTyClTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) +tidyTyClTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -- If the type variable "binder" is in scope, don't re-bind it -- In a class decl, for example, the ATD binders mention -- (amd must mention) the class tyvars -tidyTyClTyVarBndr env@(_, subst) tv +tidyTyClTyCoVarBndr env@(_, subst) tv | Just tv' <- lookupVarEnv subst tv = (env, tv') - | otherwise = tidyTyVarBndr env tv + | otherwise = tidyTyCoVarBndr env tv tidyTyVar :: TidyEnv -> TyVar -> TyVar tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv @@ -1647,7 +1652,6 @@ toIfaceIdDetails (RecSelId { sel_naughty = n -- through interface files. We easily could if it mattered toIfaceIdDetails PatSynId = IfVanillaId toIfaceIdDetails ReflectionId = IfVanillaId -toIfaceIdDetails DefMethId = IfVanillaId -- The remaining cases are all "implicit Ids" which don't -- appear in interface files at all diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index da94136218..3931b18237 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -27,8 +27,9 @@ import BuildTyCl import TcRnMonad import TcType import Type -import Coercion hiding (substTy) -import TypeRep +import Coercion +import CoAxiom +import TyCoRep -- needs to build types & coercions in a knot import HscTypes import Annotations import InstEnv @@ -43,14 +44,10 @@ import MkId import IdInfo import Class import TyCon -import CoAxiom import ConLike import DataCon import PrelNames import TysWiredIn -import TysPrim ( superKindTyConName ) -import BasicTypes ( strongLoopBreaker, Arity, TupleSort(..) - , Boxity(..), DefMethSpec(..), pprRuleName ) import Literal import qualified Var import VarEnv @@ -69,6 +66,8 @@ import SrcLoc import DynFlags import Util import FastString +import BasicTypes hiding ( SuccessFlag(..) ) +import ListSetOps import Data.List import Control.Monad @@ -316,20 +315,21 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, tc_iface_decl _ _ (IfaceData {ifName = occ_name, ifCType = cType, + ifKind = kind, ifTyVars = tv_bndrs, ifRoles = roles, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, - ifRec = is_rec, ifPromotable = is_prom, - ifParent = mb_parent }) + ifRec = is_rec, ifParent = mb_parent }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name + ; kind' <- tcIfaceType kind ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt ; parent' <- tc_parent tc_name mb_parent - ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons is_prom - ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta - cons is_rec is_prom gadt_syn parent') } + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons + ; return (mkAlgTyCon tc_name kind' tyvars roles cType stupid_theta + cons parent' is_rec gadt_syn) } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } where @@ -350,10 +350,10 @@ tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs, ifSynKind = kind }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] + ; kind <- tcIfaceType kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tcIfaceType rhs_ty - ; let tycon = buildSynonymTyCon tc_name tyvars roles rhs rhs_kind + ; let tycon = mkSynonymTyCon tc_name kind tyvars roles rhs ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type synonym") <+> ppr n @@ -364,12 +364,11 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, ifResVar = res, ifFamInj = inj }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] + ; kind <- tcIfaceType kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_fam_flav tc_name fam_flav ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res - ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind - parent inj + ; let tycon = mkFamilyTyCon tc_name kind tyvars res_name rhs parent inj ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type synonym") <+> ppr n @@ -390,13 +389,15 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, - ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds, + ifTyVars = tv_bndrs, ifRoles = roles, ifKind = kind, + ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, ifMinDef = mindef_occ, ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons - = bindIfaceTyVars tv_bndrs $ \ tyvars -> do + = bindIfaceTvBndrs tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop tc_occ + ; kind' <- tcIfaceType kind ; traceIf (text "tc-iface-class1" <+> ppr tc_occ) ; ctxt <- mapM tc_sc rdr_ctxt ; traceIf (text "tc-iface-class2" <+> ppr tc_occ) @@ -407,7 +408,7 @@ tc_iface_decl _parent ignore_prags ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) - ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec } + ; buildClass tc_name tyvars roles ctxt kind' fds ats sigs mindef tc_isrec } ; return (ATyCon (classTyCon cls)) } where tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) @@ -486,8 +487,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) ; matcher <- tc_pr if_matcher ; builder <- fmapMaybeM tc_pr if_builder - ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do - { bindIfaceTyVars ex_tvs $ \ex_tvs -> do + ; bindIfaceTvBndrs univ_tvs $ \univ_tvs -> do + { bindIfaceTvBndrs ex_tvs $ \ex_tvs -> do { patsyn <- forkM (mk_doc name) $ do { prov_theta <- tcIfaceCtxt prov_ctxt ; req_theta <- tcIfaceCtxt req_ctxt @@ -508,22 +509,25 @@ tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] tc_ax_branch prev_branches - (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs + (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs + , ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) - = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do + = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom - { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds] + bindIfaceIds cv_bndrs $ \ cvs -> do + { tc_lhs <- tcIfaceTcArgs lhs ; tc_rhs <- tcIfaceType rhs ; let br = CoAxBranch { cab_loc = noSrcSpan , cab_tvs = tvs + , cab_cvs = cvs , cab_lhs = tc_lhs , cab_roles = roles , cab_rhs = tc_rhs - , cab_incomps = map (prev_branches !!) incomps } + , cab_incomps = map (prev_branches `getNth`) incomps } ; return (prev_branches ++ [br]) } -tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> Bool -> IfL AlgTyConRhs -tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom +tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons) @@ -541,7 +545,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom ifConSrcStricts = if_src_stricts}) = -- Universally-quantified tyvars are shared with -- parent TyCon, and are alrady in scope - bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do + bindIfaceTvBndrs ex_tvs $ \ ex_tyvars -> do { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) ; dc_name <- lookupIfaceTop occ @@ -568,14 +572,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom -- Remember, tycon is the representation tycon ; let orig_res_ty = mkFamilyTyConApp tycon - (substTyVars (mkTopTvSubst eq_spec) tc_tyvars) + (substTyVars (mkTopTCvSubst (map eqSpecPair eq_spec)) + tc_tyvars) - ; prom_info <- if is_prom then do { n <- newTyConRepName dc_name - ; return (Promoted n) } - else return NotPromoted + ; prom_rep_name <- newTyConRepName dc_name ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) - dc_name is_infix prom_info + dc_name is_infix prom_rep_name (map src_strict if_src_stricts) (Just stricts) -- Pass the HsImplBangs (i.e. final @@ -601,13 +604,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom src_strict :: IfaceSrcBang -> HsSrcBang src_strict (IfSrcBang unpk bang) = HsSrcBang Nothing unpk bang -tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)] +tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] tcIfaceEqSpec spec = mapM do_item spec where do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ ; ty <- tcIfaceType if_ty - ; return (tv,ty) } + ; return (mkEqSpec tv ty) } {- Note [Synonym kind loop] @@ -874,70 +877,55 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo -} tcIfaceType :: IfaceType -> IfL Type -tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } -tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } -tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } -tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2 -tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2 -tcIfaceType (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks -tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc - ; tks' <- tcIfaceTcArgs tks - ; return (mkTyConApp tc' tks') } -tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } - -tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type -tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } - -tcIfaceKind :: IfaceKind -> IfL Type -tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } -tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2 -tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2 -tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l) -tcIfaceKind k = tcIfaceType k - -tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type -tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } +tcIfaceType = go + where + go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n + go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2 + go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l + go (IfaceFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2 + go (IfaceDFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2 + go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks + go (IfaceTyConApp tc tks) + = do { tc' <- tcIfaceTyCon tc + ; tks' <- mapM go (tcArgsIfaceTypes tks) + ; return (mkTyConApp tc' tks') } + go (IfaceForAllTy bndr t) + = bindIfaceBndrTy bndr $ \ tv' vis -> mkNamedForAllTy tv' vis <$> go t + go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co + go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co tcIfaceTupleTy :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> IfL Type tcIfaceTupleTy sort info args = do { args' <- tcIfaceTcArgs args ; let arity = length args' - ; base_tc <- tcTupleTyCon sort arity + ; base_tc <- tcTupleTyCon True sort arity ; case info of NoIfaceTyConInfo -> return (mkTyConApp base_tc args') - IfacePromotedTyCon - | Promoted tc <- promotableTyCon_maybe base_tc - -> return (mkTyConApp tc args') - | otherwise - -> panic "tcIfaceTupleTy" (ppr base_tc) - IfacePromotedDataCon -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) kind_args = map typeKind args' ; return (mkTyConApp tc (kind_args ++ args')) } } -tcTupleTyCon :: TupleSort -> Arity -> IfL TyCon -tcTupleTyCon sort arity +-- See Note [Unboxed tuple levity vars] in TyCon +tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) + -> TupleSort + -> Arity -- the number of args. *not* the tuple arity. + -> IfL TyCon +tcTupleTyCon in_type sort arity = case sort of ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity) ; return (tyThingTyCon thing) } BoxedTuple -> return (tupleTyCon Boxed arity) - UnboxedTuple -> return (tupleTyCon Unboxed arity) + UnboxedTuple -> return (tupleTyCon Unboxed arity') + where arity' | in_type = arity `div` 2 + | otherwise = arity + -- in expressions, we only have term args tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type] -tcIfaceTcArgs args - = case args of - ITC_Type t ts -> - do { t' <- tcIfaceType t - ; ts' <- tcIfaceTcArgs ts - ; return (t':ts') } - ITC_Kind k ks -> - do { k' <- tcIfaceKind k - ; ks' <- tcIfaceTcArgs ks - ; return (k':ks') } - ITC_Nil -> return [] +tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes + ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType tcIfaceCtxt sts = mapM tcIfaceType sts @@ -948,49 +936,56 @@ tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) {- -************************************************************************ -* * +%************************************************************************ +%* * Coercions * * ************************************************************************ -} tcIfaceCo :: IfaceCoercion -> IfL Coercion -tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t -tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2 -tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc - <*> mapM tcIfaceCo cs -tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1 - <*> tcIfaceCo c2 -tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' -> - mkForAllCo tv' <$> tcIfaceCo c -tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n -tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n - <*> pure i - <*> mapM tcIfaceCo cs -tcIfaceCo (IfaceUnivCo s r t1 t2) = UnivCo s r <$> tcIfaceType t1 - <*> tcIfaceType t2 -tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c -tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1 - <*> tcIfaceCo c2 -tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1 - <*> tcIfaceType t2 -tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c -tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c -tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c -tcIfaceCo (IfaceAxiomRuleCo ax tys cos) = AxiomRuleCo - <$> tcIfaceCoAxiomRule ax - <*> mapM tcIfaceType tys - <*> mapM tcIfaceCo cos - -tcIfaceCoVar :: FastString -> IfL CoVar -tcIfaceCoVar = tcIfaceLclId - -tcIfaceCoAxiomRule :: FastString -> IfL CoAxiomRule -tcIfaceCoAxiomRule n = - case Map.lookup n typeNatCoAxiomRules of - Just ax -> return ax - _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) +tcIfaceCo = go + where + go (IfaceReflCo r t) = Refl r <$> tcIfaceType t + go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 + go (IfaceTyConAppCo r tc cs) + = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs + go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 + go (IfaceForAllCo tv k c) = do { k' <- go k + ; bindIfaceTyVar tv $ \ tv' -> + ForAllCo tv' k' <$> go c } + go (IfaceCoVarCo n) = CoVarCo <$> go_var n + go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs + go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r + <*> tcIfaceType t1 <*> tcIfaceType t2 + go (IfaceSymCo c) = SymCo <$> go c + go (IfaceTransCo c1 c2) = TransCo <$> go c1 + <*> go c2 + go (IfaceInstCo c1 t2) = InstCo <$> go c1 + <*> go t2 + go (IfaceNthCo d c) = NthCo d <$> go c + go (IfaceLRCo lr c) = LRCo lr <$> go c + go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1 + <*> go c2 + go (IfaceKindCo c) = KindCo <$> go c + go (IfaceSubCo c) = SubCo <$> go c + go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax + <*> mapM go cos + + go_var :: FastString -> IfL CoVar + go_var = tcIfaceLclId + + go_axiom_rule :: FastString -> IfL CoAxiomRule + go_axiom_rule n = + case Map.lookup n typeNatCoAxiomRules of + Just ax -> return ax + _ -> pprPanic "go_axiom_rule" (ppr n) + +tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance +tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv +tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str {- ************************************************************************ @@ -1028,8 +1023,12 @@ tcIfaceExpr (IfaceFCall cc ty) = do tcIfaceExpr (IfaceTuple sort args) = do { args' <- mapM tcIfaceExpr args - ; tc <- tcTupleTyCon sort arity - ; let con_args = map (Type . exprType) args' ++ args' + ; tc <- tcTupleTyCon False sort arity + ; let con_tys = map exprType args' + some_con_args = map Type con_tys ++ args' + con_args = case sort of + UnboxedTuple -> map (Type . getLevity "tcIfaceExpr") con_tys ++ some_con_args + _ -> some_con_args -- Put the missing type arguments back in con_id = dataConWorkId (tyConSingleDataCon tc) ; return (mkApps (Var con_id) con_args) } @@ -1044,7 +1043,7 @@ tcIfaceExpr (IfaceLam (bndr, os) body) tcIfaceOneShot _ b = b tcIfaceExpr (IfaceApp fun arg) - = tcIfaceApps fun arg + = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg tcIfaceExpr (IfaceECase scrut ty) = do { scrut' <- tcIfaceExpr scrut @@ -1056,7 +1055,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut' - case_bndr' = mkLocalId case_bndr_name scrut_ty + case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty tc_app = splitTyConApp scrut_ty -- NB: Won't always succeed (polymorphic case) -- but won't be demanded in those cases @@ -1073,7 +1072,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body) ; ty' <- tcIfaceType ty ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} name ty' info - ; let id = mkLocalIdWithInfo name ty' id_info + ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) ; return (Let (NonRec id rhs') body') } @@ -1088,7 +1087,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) tc_rec_bndr (IfLetBndr fs ty _) = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; return (mkLocalId name ty') } + ; return (mkLocalIdOrCoVar name ty') } tc_pair (IfLetBndr _ _ info, rhs) id = do { rhs' <- tcIfaceExpr rhs ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} @@ -1107,31 +1106,6 @@ tcIfaceExpr (IfaceTick tickish expr) = do return (Tick tickish' expr') ------------------------- -tcIfaceApps :: IfaceExpr -> IfaceExpr -> IfL CoreExpr --- See Note [Checking IfaceTypes vs IfaceKinds] -tcIfaceApps fun arg - = go_down fun [arg] - where - go_down (IfaceApp fun arg) args = go_down fun (arg:args) - go_down fun args = do { fun' <- tcIfaceExpr fun - ; go_up fun' (exprType fun') args } - - go_up :: CoreExpr -> Type -> [IfaceExpr] -> IfL CoreExpr - go_up fun _ [] = return fun - go_up fun fun_ty (IfaceType t : args) - | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty - = do { t' <- if isKindVar tv - then tcIfaceKind t - else tcIfaceType t - ; let fun_ty' = substTyWith [tv] [t'] body_ty - ; go_up (App fun (Type t')) fun_ty' args } - go_up fun fun_ty (arg : args) - | Just (_, fun_ty') <- splitFunTy_maybe fun_ty - = do { arg' <- tcIfaceExpr arg - ; go_up (App fun arg') fun_ty' args } - go_up fun fun_ty args = pprPanic "tcIfaceApps" (ppr fun $$ ppr fun_ty $$ ppr args) - -------------------------- tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) @@ -1179,7 +1153,7 @@ tcIfaceDataAlt con inst_tys arg_strs rhs ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs con inst_tys - ; rhs' <- extendIfaceTyVarEnv ex_tvs $ + ; rhs' <- extendIfaceEnvs ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } @@ -1377,17 +1351,9 @@ tcIfaceTyConByName name tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon (IfaceTyCon name info) = do { thing <- tcIfaceGlobal name - ; case info of - NoIfaceTyConInfo -> return (tyThingTyCon thing) - IfacePromotedDataCon -> return (promoteDataCon (tyThingDataCon thing)) - -- Same Name as its underlying DataCon - IfacePromotedTyCon -> return (promote_tc (tyThingTyCon thing)) } - -- Same Name as its underlying TyCon - where - promote_tc tc - | Promoted prom_tc <- promotableTyCon_maybe tc = prom_tc - | isSuperKind (tyConKind tc) = tc - | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc) + ; return $ case info of + NoIfaceTyConInfo -> tyThingTyCon thing + IfacePromotedDataCon -> promoteDataCon $ tyThingDataCon thing } tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name @@ -1413,12 +1379,23 @@ tcIfaceExtId name = do { thing <- tcIfaceGlobal name ************************************************************************ -} -bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a -bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside +bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a +bindIfaceId (fs, ty) thing_inside = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; let id = mkLocalId name ty' + ; let id = mkLocalIdOrCoVar name ty' ; extendIfaceIdEnv [id] (thing_inside id) } + +bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds [] thing_inside = thing_inside [] +bindIfaceIds (b:bs) thing_inside + = bindIfaceId b $ \b' -> + bindIfaceIds bs $ \bs' -> + thing_inside (b':bs') + +bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a +bindIfaceBndr (IfaceIdBndr bndr) thing_inside + = bindIfaceId bndr thing_inside bindIfaceBndr (IfaceTvBndr bndr) thing_inside = bindIfaceTyVar bndr thing_inside @@ -1430,33 +1407,26 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- +bindIfaceBndrTy :: IfaceForAllBndr -> (TyVar -> VisibilityFlag -> IfL a) -> IfL a +bindIfaceBndrTy (IfaceTv tv vis) thing_inside + = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis + bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside = do { name <- newIfaceName (mkTyVarOccFS occ) ; tyvar <- mk_iface_tyvar name kind ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } -bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a -bindIfaceTyVars bndrs thing_inside - = do { names <- newIfaceNames (map mkTyVarOccFS occs) - ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds - (kis_name, tys_name) = splitAt (length kis_kind) names - -- We need to bring the kind variables in scope since type - -- variables may mention them. - ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind - ; extendIfaceTyVarEnv kvs $ do - { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind - ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } } - where - (occs,kinds) = unzip bndrs - -isSuperIfaceKind :: IfaceKind -> Bool -isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName -isSuperIfaceKind _ = False +bindIfaceTvBndrs :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTvBndrs [] thing_inside = thing_inside [] +bindIfaceTvBndrs (tv:tvs) thing_inside + = bindIfaceTyVar tv $ \tv' -> + bindIfaceTvBndrs tvs $ \tvs' -> + thing_inside (tv':tvs') mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar mk_iface_tyvar name ifKind - = do { kind <- tcIfaceKind ifKind + = do { kind <- tcIfaceType ifKind ; return (Var.mkTyVar name kind) } bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a @@ -1466,12 +1436,14 @@ bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a -- Here 'a' is in scope when we look at the 'data T' bindIfaceTyVars_AT [] thing_inside = thing_inside [] -bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside - = do { mb_tv <- lookupIfaceTyVar tv_occ - ; let bind_b :: (TyVar -> IfL a) -> IfL a - bind_b = case mb_tv of - Just b' -> \k -> k b' - Nothing -> bindIfaceTyVar b - ; bind_b $ \b' -> +bindIfaceTyVars_AT (b : bs) thing_inside + = do { bindIfaceTyVar_AT b $ \b' -> bindIfaceTyVars_AT bs $ \bs' -> thing_inside (b':bs') } + +bindIfaceTyVar_AT :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a +bindIfaceTyVar_AT tv thing + = do { mb_tv <- lookupIfaceTyVar tv + ; case mb_tv of + Just b' -> thing b' + Nothing -> bindIfaceTyVar tv thing } diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot index 619e3efdbb..9c1b16b520 100644 --- a/compiler/iface/TcIface.hs-boot +++ b/compiler/iface/TcIface.hs-boot @@ -1,7 +1,7 @@ module TcIface where import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) -import TypeRep ( TyThing ) +import TyCoRep ( TyThing ) import TcRnTypes ( IfL ) import InstEnv ( ClsInst ) import FamInstEnv ( FamInst ) diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index 82c5d2024c..a81ae80614 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -42,8 +42,8 @@ type AnnPayload = Serialized -- ^ The "payload" of an annotation -- and can be persisted to an interface file -- | An annotation target -data AnnTarget name - = NamedTarget name -- ^ We are annotating something with a name: +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: -- a type or identifier | ModuleTarget Module -- ^ We are annotating a particular module @@ -99,7 +99,7 @@ mkAnnEnv = extendAnnEnvList emptyAnnEnv -- | Add the given annotation to the environment. extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv -extendAnnEnvList (MkAnnEnv env) anns +extendAnnEnvList (MkAnnEnv env) anns = MkAnnEnv $ addListToUFM_C (++) env $ map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns @@ -107,11 +107,11 @@ extendAnnEnvList (MkAnnEnv env) anns plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 --- | Find the annotations attached to the given target as 'Typeable' --- values of your choice. If no deserializer is specified, +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, -- only transient annotations will be returned. findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] -findAnns deserialize (MkAnnEnv ann_env) +findAnns deserialize (MkAnnEnv ann_env) = (mapMaybe (fromSerialized deserialize)) . (lookupWithDefaultUFM ann_env []) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 7818c6b3b3..4aedc43054 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -332,6 +332,8 @@ data GeneralFlag | Opt_PrintExplicitForalls | Opt_PrintExplicitKinds + | Opt_PrintExplicitCoercions + | Opt_PrintEqualityRelations | Opt_PrintUnicodeSyntax | Opt_PrintExpandedSynonyms | Opt_PrintPotentialInstances @@ -662,6 +664,7 @@ data ExtensionFlag | Opt_StaticPointers | Opt_Strict | Opt_StrictData + | Opt_TypeInType | Opt_MonadFailDesugaring deriving (Eq, Enum, Show) @@ -3027,6 +3030,8 @@ fFlags = [ flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, + flagSpec "print-equality-relations" Opt_PrintEqualityRelations, flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, flagSpec "print-potential-instances" Opt_PrintPotentialInstances, @@ -3253,6 +3258,7 @@ xFlags = [ flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax, flagSpec "TransformListComp" Opt_TransformListComp, flagSpec "TupleSections" Opt_TupleSections, + flagSpec "TypeInType" Opt_TypeInType, flagSpec "TypeFamilies" Opt_TypeFamilies, flagSpec "TypeOperators" Opt_TypeOperators, flagSpec "TypeSynonymInstances" Opt_TypeSynonymInstances, @@ -3336,6 +3342,9 @@ impliedXFlags , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures , (Opt_PolyKinds, turnOn, Opt_KindSignatures) -- Ditto polymorphic kinds + , (Opt_TypeInType, turnOn, Opt_DataKinds) + , (Opt_TypeInType, turnOn, Opt_PolyKinds) + , (Opt_TypeInType, turnOn, Opt_KindSignatures) -- AutoDeriveTypeable is not very useful without DeriveDataTypeable , (Opt_AutoDeriveTypeable, turnOn, Opt_DeriveDataTypeable) diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index 0d72bece36..5942d6c91c 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -38,8 +38,7 @@ import PrelNames ( pluginTyConName ) import HscTypes import BasicTypes ( HValue ) -import TypeRep ( mkTyConTy, pprTyThingCategory ) -import Type ( Type, eqType ) +import Type ( Type, eqType, mkTyConTy, pprTyThingCategory ) import TyCon ( TyCon ) import Name ( Name, nameModule_maybe ) import Id ( idType ) @@ -99,7 +98,7 @@ forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () forceLoadModuleInterfaces hsc_env doc modules = (initTcInteractive hsc_env $ initIfaceTcRn $ - mapM_ (loadPluginInterface doc) modules) + mapM_ (loadPluginInterface doc) modules) >> return () -- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used @@ -117,7 +116,7 @@ forceLoadNameModuleInterface hsc_env reason name = do forceLoadTyCon :: HscEnv -> Name -> IO TyCon forceLoadTyCon hsc_env con_name = do forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name - + mb_con_thing <- lookupTypeHscEnv hsc_env con_name case mb_con_thing of Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 8e5a530700..965f7c1439 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -38,7 +38,7 @@ module GHC ( addTarget, removeTarget, guessTarget, - + -- * Loading\/compiling the program depanal, load, LoadHowMuch(..), InteractiveImport(..), @@ -136,7 +136,7 @@ module GHC ( SingleStep(..), Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), - History(historyBreakInfo, historyEnclosingDecls), + History(historyBreakInfo, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, abandon, abandonAll, getResumeContext, @@ -164,11 +164,11 @@ module GHC ( ModuleName, mkModuleName, moduleNameString, -- ** Names - Name, + Name, isExternalName, nameModule, pprParenSymName, nameSrcSpan, NamedThing(..), RdrName(Qual,Unqual), - + -- ** Identifiers Id, idType, isImplicitId, isDeadBinder, @@ -186,7 +186,7 @@ module GHC ( isPrimTyCon, isFunTyCon, isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, tyConClass_maybe, - synTyConRhs_maybe, synTyConDefn_maybe, tyConResKind, + synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, -- ** Type variables TyVar, @@ -200,46 +200,46 @@ module GHC ( StrictnessMark(..), isMarkedStrict, -- ** Classes - Class, + Class, classMethods, classSCTheta, classTvsFds, classATs, pprFundeps, -- ** Instances - ClsInst, - instanceDFunId, + ClsInst, + instanceDFunId, pprInstance, pprInstanceHdr, pprFamInst, FamInst, -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprForAll, pprThetaArrowTy, + ThetaType, pprForAll, pprForAllImplicit, pprThetaArrowTy, -- ** Entities - TyThing(..), + TyThing(..), -- ** Syntax module HsSyn, -- ToDo: remove extraneous bits -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, + FixityDirection(..), + defaultFixity, maxPrecedence, negateFixity, compareFixity, -- ** Source locations - SrcLoc(..), RealSrcLoc, + SrcLoc(..), RealSrcLoc, mkSrcLoc, noSrcLoc, srcLocFile, srcLocLine, srcLocCol, SrcSpan(..), RealSrcSpan, mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, srcSpanStart, srcSpanEnd, - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, -- ** Located @@ -305,7 +305,6 @@ import NameSet import RdrName import HsSyn import Type hiding( typeKind ) -import Kind ( tyConResKind ) import TcType hiding( typeKind ) import Id import TysPrim ( alphaTyVars ) @@ -709,9 +708,9 @@ guessTarget str Nothing dflags <- getDynFlags liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags $ - text "target" <+> quotes (text file) <+> + text "target" <+> quotes (text file) <+> text "is not a module name or a source file")) - where + where (file,obj_allowed) | '*':rest <- str = (rest, False) | otherwise = (str, True) @@ -724,7 +723,7 @@ guessTarget str Nothing -- | Inform GHC that the working directory has changed. GHC will flush -- its cache of module locations, since it may no longer be valid. --- +-- -- Note: Before changing the working directory make sure all threads running -- in the same session have stopped. If you change the working directory, -- you should also unload the current program (set targets to empty, @@ -923,11 +922,11 @@ loadModule tcm = do mb_linkable <- case ms_obj_date ms of Just t | t > ms_hs_date ms -> do - l <- liftIO $ findObjectLinkable (ms_mod ms) + l <- liftIO $ findObjectLinkable (ms_mod ms) (ml_obj_file loc) t return (Just l) _otherwise -> return Nothing - + let source_modified | isNothing mb_linkable = SourceModified | otherwise = SourceUnmodified -- we can't determine stability here @@ -1103,10 +1102,10 @@ getModuleInfo mdl = withSession $ \hsc_env -> do getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI -getPackageModuleInfo hsc_env mdl +getPackageModuleInfo hsc_env mdl = do eps <- hscEPS hsc_env iface <- hscGetModuleInterface hsc_env mdl - let + let avails = mi_exports iface pte = eps_PTE eps tys = [ ty | name <- concatMap availNames avails, @@ -1119,7 +1118,7 @@ getPackageModuleInfo hsc_env mdl minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = emptyModBreaks + minf_modBreaks = emptyModBreaks })) #else -- bogusly different for non-GHCI (ToDo) @@ -1128,7 +1127,7 @@ getPackageModuleInfo _hsc_env _mdl = do #endif getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = +getHomeModuleInfo hsc_env mdl = case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of Nothing -> return Nothing Just hmi -> do @@ -1182,7 +1181,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do Just tyThing -> return (Just tyThing) Nothing -> do eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) + return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name modInfoIface :: ModuleInfo -> Maybe ModIface @@ -1194,12 +1193,13 @@ modInfoSafe = minf_safe #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks -modInfoModBreaks = minf_modBreaks +modInfoModBreaks = minf_modBreaks #endif isDictonaryId :: Id -> Bool isDictonaryId id - = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } + = case tcSplitSigmaTy (idType id) of { + (_tvs, _theta, tau) -> isDictTy tau } -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use @@ -1361,11 +1361,11 @@ showRichTokenStream ts = go startLoc ts "" -- Interactive evaluation -- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the --- filesystem and package database to find the corresponding 'Module', +-- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do - let + let dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags -- @@ -1388,7 +1388,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ - text "module is not loaded:" <+> + text "module is not loaded:" <+> quotes (ppr (moduleName m)) <+> parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) @@ -1465,7 +1465,7 @@ obtainTermFromId bound force id = withSession $ \hsc_env -> -- entity known to GHC, including 'Name's defined using 'runStmt'. lookupName :: GhcMonad m => Name -> m (Maybe TyThing) lookupName name = - withSession $ \hsc_env -> + withSession $ \hsc_env -> liftIO $ hscTcRcLookupName hsc_env name -- ----------------------------------------------------------------------------- @@ -1478,17 +1478,16 @@ parser :: String -- ^ Haskell module source text (full Unicode is suppor -> FilePath -- ^ the filename (for source locations) -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) -parser str dflags filename = +parser str dflags filename = let loc = mkRealSrcLoc (mkFastString filename) 1 1 buf = stringToStringBuffer str in case unP Parser.parseModule (mkPState dflags buf loc) of - PFailed span err -> + PFailed span err -> Left (unitBag (mkPlainErrMsg dflags span err)) POk pst rdr_module -> let (warns,_) = getMessages pst in Right (warns, rdr_module) - diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 34d5bcf91f..02e07c25be 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -11,10 +11,10 @@ module GhcMonad ( -- * 'Ghc' monad stuff GhcMonad(..), - Ghc(..), + Ghc(..), GhcT(..), liftGhcT, reflectGhc, reifyGhc, - getSessionDynFlags, + getSessionDynFlags, liftIO, Session(..), withSession, modifySession, withTempSession, @@ -94,7 +94,7 @@ newtype Ghc a = Ghc { unGhc :: Session -> IO a } -- session. A compilation session consists of a set of modules -- constituting the current program or library, the context for -- interactive evaluation, and various caches. -data Session = Session !(IORef HscEnv) +data Session = Session !(IORef HscEnv) instance Functor Ghc where fmap f m = Ghc $ \s -> f `fmap` unGhc m s diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs index 2326ebdf6c..c60b41ec50 100644 --- a/compiler/main/GhcPlugins.hs +++ b/compiler/main/GhcPlugins.hs @@ -4,7 +4,7 @@ -- the functions and types you are likely to need when writing a -- plugin for GHC. So authors of plugins can probably get away simply -- with saying "import GhcPlugins". --- +-- -- Particularly interesting modules for plugin writers include -- "CoreSyn" and "CoreMonad". module GhcPlugins( @@ -14,11 +14,11 @@ module GhcPlugins( module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, module Rules, module Annotations, module DynFlags, module Packages, - module Module, module Type, module TyCon, module Coercion, + module Module, module Type, module TyCon, module Coercion, module TysWiredIn, module HscTypes, module BasicTypes, - module VarSet, module VarEnv, module NameSet, module NameEnv, + module VarSet, module VarEnv, module NameSet, module NameEnv, module UniqSet, module UniqFM, module FiniteMap, - module Util, module Serialized, module SrcLoc, module Outputable, + module Util, module Serialized, module SrcLoc, module Outputable, module UniqSupply, module Unique, module FastString ) where @@ -54,9 +54,9 @@ import Packages -- Important GHC types import Module import Type hiding {- conflict with CoreSubst -} - ( substTy, extendTvSubst, extendTvSubstList, isInScope ) + ( substTy, extendTCvSubst, extendTCvSubstList, isInScope ) import Coercion hiding {- conflict with CoreSubst -} - ( substTy, extendTvSubst, substCo, substTyVarBndr, lookupTyVar ) + ( substCo ) import TyCon import TysWiredIn import HscTypes diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index b7f3dd756e..cc1e842be0 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -58,19 +58,19 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) decls = map unLoc ldecls pp_val (_, 0) = empty - pp_val (str, n) + pp_val (str, n) | not short = hcat [text str, int n] | otherwise = hcat [text (trim str), equals, int n, semi] - + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 3ffffa1f3b..a3eda3abaa 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -75,7 +75,7 @@ module HscTypes ( -- * TyThings and type environments TyThing(..), tyThingAvailInfo, tyThingTyCon, tyThingDataCon, - tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyVars, + tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing, @@ -1496,10 +1496,10 @@ icExtendGblRdrEnv env tythings _ -> False is_sub_bndr _ = False -substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext +substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst - | isEmptyTvSubst subst = ictxt - | otherwise = ictxt { ic_tythings = map subst_ty tts } + | isEmptyTCvSubst subst = ictxt + | otherwise = ictxt { ic_tythings = map subst_ty tts } where subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id) subst_ty tt = tt @@ -1781,19 +1781,19 @@ tyThingParent_maybe (AnId id) = case idDetails id of _other -> Nothing tyThingParent_maybe _other = Nothing -tyThingsTyVars :: [TyThing] -> TyVarSet -tyThingsTyVars tts = +tyThingsTyCoVars :: [TyThing] -> TyCoVarSet +tyThingsTyCoVars tts = unionVarSets $ map ttToVarSet tts where - ttToVarSet (AnId id) = tyVarsOfType $ idType id + ttToVarSet (AnId id) = tyCoVarsOfType $ idType id ttToVarSet (AConLike cl) = case cl of - RealDataCon dc -> tyVarsOfType $ dataConRepType dc + RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc PatSynCon{} -> emptyVarSet ttToVarSet (ATyCon tc) = case tyConClass_maybe tc of Just cls -> (mkVarSet . fst . classTvsFds) cls - Nothing -> tyVarsOfType $ tyConKind tc - ttToVarSet _ = emptyVarSet + Nothing -> tyCoVarsOfType $ tyConKind tc + ttToVarSet (ACoAxiom _) = emptyVarSet -- | The Names that a TyThing should bring into scope. Used to build -- the GlobalRdrEnv for the InteractiveContext. diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 6defdff1af..286b62e9f7 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -74,7 +74,7 @@ import Unique import UniqSupply import MonadUtils import Module -import PrelNames ( toDynName ) +import PrelNames ( toDynName, pretendNameIsInScope ) import Panic import UniqFM import Maybes @@ -675,8 +675,8 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do (ids, offsets) = unzip pointers - free_tvs = mapUnionVarSet (tyVarsOfType . idType) ids - `unionVarSet` tyVarsOfType result_ty + free_tvs = mapUnionVarSet (tyCoVarsOfType . idType) ids + `unionVarSet` tyCoVarsOfType result_ty -- It might be that getIdValFromApStack fails, because the AP_STACK -- has been accidentally evaluated, or something else has gone wrong. @@ -720,13 +720,13 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } - newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst + newTyVars :: UniqSupply -> TcTyVarSet -> TCvSubst -- Similarly, clone the type variables mentioned in the types -- we have here, *and* make them all RuntimeUnk tyars newTyVars us tvs - = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) - | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us - , let name = setNameUnique (tyVarName tv) uniq ] + = mkTopTCvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) + | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us + , let name = setNameUnique (tyVarName tv) uniq ] rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do @@ -738,7 +738,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) return hsc_env' where - noSkolems = isEmptyVarSet . tyVarsOfType . idType + noSkolems = isEmptyVarSet . tyCoVarsOfType . idType improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do let tmp_ids = [id | AnId id <- ic_tythings ic] Just id = find (\i -> idName i == name) tmp_ids @@ -963,11 +963,13 @@ getInfo allInfo name || all ok (nameSetElems names) where -- A name is ok if it's in the rdr_env, -- whether qualified or not - ok n | n == name = True -- The one we looked for in the first place! - | isBuiltInSyntax n = True - | isExternalName n = any ((== n) . gre_name) - (lookupGRE_Name rdr_env n) - | otherwise = True + ok n | n == name = True + -- The one we looked for in the first place! + | pretendNameIsInScope n = True + | isBuiltInSyntax n = True + | isExternalName n = any ((== n) . gre_name) + (lookupGRE_Name rdr_env n) + | otherwise = True -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs index 7aaf5f2cd8..7e6e837bea 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -21,7 +21,7 @@ import Id import BasicTypes import Name import RdrName -import TypeRep +import Type import ByteCodeInstr import SrcLoc import Exception diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs index e66b199305..6b20db719d 100644 --- a/compiler/main/PipelineMonad.hs +++ b/compiler/main/PipelineMonad.hs @@ -6,7 +6,7 @@ module PipelineMonad ( CompPipeline(..), evalP , PhasePlus(..) , PipeEnv(..), PipeState(..), PipelineOutput(..) - , getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO ) where import MonadUtils diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 3e48ec3a8a..365a57c7b9 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -19,7 +19,7 @@ module PprTyThing ( #include "HsVersions.h" -import TypeRep ( TyThing(..) ) +import Type ( TyThing(..) ) import CoAxiom ( coAxiomTyCon ) import HscTypes( tyThingParent_maybe ) import MkIface ( tyThingToIfaceDecl ) @@ -156,7 +156,7 @@ pprTypeForUser :: Type -> SDoc -- Then we want to display -- (C a, Ord b) => stuff pprTypeForUser ty - = pprSigmaType (mkSigmaTy tvs ctxt tau) + = pprSigmaType (mkInvSigmaTy tvs ctxt tau) where (tvs, ctxt, tau) = tcSplitSigmaTy tidy_ty (_, tidy_ty) = tidyOpenType emptyTidyEnv ty diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 0fbce8ccd9..b8fe838c7a 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -893,4 +893,3 @@ limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 = limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 = panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed." limitShiftRI _ x = x - diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs index deb3ac1b70..787b1d2f85 100644 --- a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs +++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs @@ -4,10 +4,10 @@ -- as per: "A Generalized Algorithm for Graph-Coloring Register Allocation" -- Michael Smith, Normal Ramsey, Glenn Holloway. -- PLDI 2004 --- +-- -- These general versions are not used in GHC proper because they are too slow. -- Instead, hand written optimised versions are provided for each architecture --- in MachRegs*.hs +-- in MachRegs*.hs -- -- This code is here because we can test the architecture specific code against -- it. @@ -16,7 +16,7 @@ module RegAlloc.Graph.ArchBase ( RegClass(..), Reg(..), RegSub(..), - + worst, bound, squeese @@ -33,7 +33,7 @@ data RegClass = ClassG32 -- 32 bit GPRs | ClassG16 -- 16 bit GPRs | ClassG8 -- 8 bit GPRs - + -- floating point regs | ClassF64 -- 64 bit FPRs deriving (Show, Eq, Enum) @@ -43,7 +43,7 @@ data RegClass data Reg -- a register of some class = Reg RegClass Int - + -- a sub-component of one of the other regs | RegSub RegSub Reg deriving (Show, Eq) @@ -56,7 +56,7 @@ instance Uniquable Reg where $ fromEnum c * 1000 + i getUnique (RegSub s (Reg c i)) - = mkRegSubUnique + = mkRegSubUnique $ fromEnum s * 10000 + fromEnum c * 1000 + i getUnique (RegSub _ (RegSub _ _)) @@ -69,11 +69,11 @@ data RegSub | SubL8 -- lowest 8 bits | SubL8H -- second lowest 8 bits deriving (Show, Enum, Ord, Eq) - + -- | Worst case displacement -- --- a node N of classN has some number of neighbors, +-- a node N of classN has some number of neighbors, -- all of which are from classC. -- -- (worst neighbors classN classC) is the maximum number of potential @@ -93,22 +93,22 @@ worst regsOfClass regAlias neighbors classN classC -- all the regs in classes N, C regsN = regsOfClass classN regsC = regsOfClass classC - + -- all the possible subsets of c which have size < m - regsS = filter (\s -> sizeUniqSet s >= 1 + regsS = filter (\s -> sizeUniqSet s >= 1 && sizeUniqSet s <= neighbors) $ powersetLS regsC -- for each of the subsets of C, the regs which conflict -- with posiblities for N - regsS_conflict + regsS_conflict = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS in maximum $ map sizeUniqSet $ regsS_conflict -- | For a node N of classN and neighbors of classesC --- (bound classN classesC) is the maximum number of potential +-- (bound classN classesC) is the maximum number of potential -- colors for N that can be lost by coloring its neighbors. bound :: (RegClass -> UniqSet Reg) -> (Reg -> UniqSet Reg) @@ -118,13 +118,13 @@ bound regsOfClass regAlias classN classesC = let regAliasS regs = unionManyUniqSets $ map regAlias $ uniqSetToList regs - + regsC_aliases = unionManyUniqSets $ map (regAliasS . regsOfClass) classesC overlap = intersectUniqSets (regsOfClass classN) regsC_aliases - + in sizeUniqSet overlap @@ -132,16 +132,16 @@ bound regsOfClass regAlias classN classesC -- -- A version of this should be constructed for each particular architecture, -- possibly including uses of bound, so that alised registers don't get --- counted twice, as per the paper. +-- counted twice, as per the paper. squeese :: (RegClass -> UniqSet Reg) -> (Reg -> UniqSet Reg) -> RegClass -> [(Int, RegClass)] -> Int squeese regsOfClass regAlias classN countCs - = sum - $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) + = sum + $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC) $ countCs - + -- | powerset (for lists) powersetL :: [a] -> [[a]] diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs index c5122693d3..439899071a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs +++ b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs @@ -23,56 +23,56 @@ classOfReg :: Reg -> RegClass classOfReg reg = case reg of Reg c _ -> c - + RegSub SubL16 _ -> ClassG16 RegSub SubL8 _ -> ClassG8 RegSub SubL8H _ -> ClassG8 - + -- | Determine all the regs that make up a certain class. regsOfClass :: RegClass -> UniqSet Reg regsOfClass c = case c of - ClassG32 - -> mkUniqSet [ Reg ClassG32 i + ClassG32 + -> mkUniqSet [ Reg ClassG32 i | i <- [0..7] ] - ClassG16 + ClassG16 -> mkUniqSet [ RegSub SubL16 (Reg ClassG32 i) | i <- [0..7] ] - ClassG8 + ClassG8 -> unionUniqSets (mkUniqSet [ RegSub SubL8 (Reg ClassG32 i) | i <- [0..3] ]) (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ]) - - ClassF64 + + ClassF64 -> mkUniqSet [ Reg ClassF64 i | i <- [0..5] ] - + -- | Determine the common name of a reg -- returns Nothing if this reg is not part of the machine. regName :: Reg -> Maybe String regName reg = case reg of - Reg ClassG32 i + Reg ClassG32 i | i <= 7-> Just $ [ "eax", "ebx", "ecx", "edx" , "ebp", "esi", "edi", "esp" ] !! i RegSub SubL16 (Reg ClassG32 i) | i <= 7 -> Just $ [ "ax", "bx", "cx", "dx" , "bp", "si", "di", "sp"] !! i - + RegSub SubL8 (Reg ClassG32 i) | i <= 3 -> Just $ [ "al", "bl", "cl", "dl"] !! i - + RegSub SubL8H (Reg ClassG32 i) | i <= 3 -> Just $ [ "ah", "bh", "ch", "dh"] !! i _ -> Nothing - + -- | Which regs alias what other regs. regAlias :: Reg -> UniqSet Reg regAlias reg @@ -80,31 +80,31 @@ regAlias reg -- 32 bit regs alias all of the subregs Reg ClassG32 i - + -- for eax, ebx, ecx, eds - | i <= 3 - -> mkUniqSet + | i <= 3 + -> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg , RegSub SubL8 reg, RegSub SubL8H reg ] - + -- for esi, edi, esp, ebp - | 4 <= i && i <= 7 - -> mkUniqSet + | 4 <= i && i <= 7 + -> mkUniqSet $ [ Reg ClassG32 i, RegSub SubL16 reg ] - + -- 16 bit subregs alias the whole reg - RegSub SubL16 r@(Reg ClassG32 _) + RegSub SubL16 r@(Reg ClassG32 _) -> regAlias r - + -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg RegSub SubL8 r@(Reg ClassG32 _) -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ] RegSub SubL8H r@(Reg ClassG32 _) -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ] - + -- fp - Reg ClassF64 _ + Reg ClassF64 _ -> unitUniqSet reg _ -> error "regAlias: invalid register" @@ -120,27 +120,27 @@ worst n classN classC ClassG16 -> min n 8 ClassG8 -> min n 4 ClassF64 -> 0 - + ClassG16 -> case classC of ClassG32 -> min n 8 ClassG16 -> min n 8 ClassG8 -> min n 4 ClassF64 -> 0 - + ClassG8 -> case classC of ClassG32 -> min (n*2) 8 ClassG16 -> min (n*2) 8 ClassG8 -> min n 8 ClassF64 -> 0 - + ClassF64 -> case classC of ClassF64 -> min n 6 _ -> 0 - + squeese :: RegClass -> [(Int, RegClass)] -> Int squeese classN countCs = sum (map (\(i, classC) -> worst i classN classC) countCs) - + diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 69f0745dc3..7e8047f29f 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -23,26 +23,26 @@ import Data.List -- second reg is born then the mov only serves to join live ranges. -- The two regs can be renamed to be the same and the move instruction -- safely erased. -regCoalesce +regCoalesce :: Instruction instr - => [LiveCmmDecl statics instr] + => [LiveCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr] regCoalesce code - = do + = do let joins = foldl' unionBags emptyBag $ map slurpJoinMovs code - let alloc = foldl' buildAlloc emptyUFM + let alloc = foldl' buildAlloc emptyUFM $ bagToList joins let patched = map (patchEraseLive (sinkReg alloc)) code - + return patched -- | Add a v1 = v2 register renaming to the map. --- The register with the lowest lexical name is set as the +-- The register with the lowest lexical name is set as the -- canonical version. buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg buildAlloc fm (r1, r2) @@ -57,23 +57,23 @@ sinkReg :: UniqFM Reg -> Reg -> Reg sinkReg fm r = case lookupUFM fm r of Nothing -> r - Just r' -> sinkReg fm r' - + Just r' -> sinkReg fm r' + -- | Slurp out mov instructions that only serve to join live ranges. -- -- During a mov, if the source reg dies and the destiation reg is -- born then we can rename the two regs to the same thing and -- eliminate the move. -slurpJoinMovs +slurpJoinMovs :: Instruction instr - => LiveCmmDecl statics instr + => LiveCmmDecl statics instr -> Bag (Reg, Reg) slurpJoinMovs live = slurpCmm emptyBag live - where - slurpCmm rs CmmData{} + where + slurpCmm rs CmmData{} = rs slurpCmm rs (CmmProc _ _ _ sccs) @@ -81,7 +81,7 @@ slurpJoinMovs live slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs - + slurpLI rs (LiveInstr _ Nothing) = rs slurpLI rs (LiveInstr instr (Just live)) | Just (r1, r2) <- takeRegRegMoveInstr instr @@ -90,10 +90,10 @@ slurpJoinMovs live -- only coalesce movs between two virtuals for now, -- else we end up with allocatable regs in the live - -- regs list.. + -- regs list.. , isVirtualReg r1 && isVirtualReg r2 = consBag (r1, r2) rs - + | otherwise = rs - + diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 8d5a4dbabd..52ed438f81 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -30,7 +30,7 @@ import Control.Monad -- | The maximum number of build\/spill cycles we'll allow. --- +-- -- It should only take 3 or 4 cycles for the allocator to converge. -- If it takes any longer than this it's probably in an infinite loop, -- so it's better just to bail out and report a bug. @@ -71,11 +71,11 @@ regAlloc dflags regsFree slotsFree code -- | Perform solver iterations for the graph coloring allocator. -- -- We extract a register confict graph from the provided cmm code, --- and try to colour it. If that works then we use the solution rewrite +-- and try to colour it. If that works then we use the solution rewrite -- the code with real hregs. If coloring doesn't work we add spill code -- and try to colour it again. After `maxSpinCount` iterations we give up. -- -regAlloc_spin +regAlloc_spin :: (Instruction instr, Outputable instr, Outputable statics) @@ -110,7 +110,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code ( text "It looks like the register allocator is stuck in an infinite loop." $$ text "max cycles = " <> int maxSpinCount $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr - $ uniqSetToList $ unionManyUniqSets + $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree) $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) @@ -126,7 +126,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code seqGraph graph `seq` return () -- Build a map of the cost of spilling each instruction. - -- This is a lazy binding, so the map will only be computed if we + -- This is a lazy binding, so the map will only be computed if we -- actually have to spill to the stack. let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo $ map (slurpSpillCostInfo platform) code @@ -135,7 +135,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code let spill = chooseSpill spillCosts -- Record startup state in our log. - let stat1 + let stat1 = if spinCount == 0 then Just $ RegAllocStatsStart { raLiveCmm = code @@ -179,7 +179,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code else graph_colored -- Rewrite the code to use real hregs, using the colored graph. - let code_patched + let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced @@ -197,7 +197,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code = map (stripLive dflags) code_spillclean -- Record what happened in this stage for debugging - let stat + let stat = RegAllocStatsColored { raCode = code , raGraph = graph @@ -207,11 +207,11 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code , raPatched = code_patched , raSpillClean = code_spillclean , raFinal = code_final - , raSRMs = foldl' addSRM (0, 0, 0) + , raSRMs = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean } -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not + -- .. but make sure to drop them on the floor if they're not -- needed, otherwise we'll get a space leak. let statList = if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs @@ -243,7 +243,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code -- NOTE: we have to reverse the SCCs here to get them back into -- the reverse-dependency order required by computeLiveness. -- If they're not in the correct order that function will panic. - code_relive <- mapM (regLiveness platform . reverseBlocksInTops) + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled -- Record what happened in this stage for debugging. @@ -257,7 +257,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code , raSpilled = code_spilled } -- Bundle up all the register allocator statistics. - -- .. but make sure to drop them on the floor if they're not + -- .. but make sure to drop them on the floor if they're not -- needed, otherwise we'll get a space leak. let statList = if dump @@ -289,7 +289,7 @@ buildGraph code -- Add the reg-reg conflicts to the graph. let conflictBag = unionManyBags conflictList - let graph_conflict + let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictBag -- Add the coalescences edges to the graph. @@ -381,7 +381,7 @@ patchRegsFromGraph platform graph code -- no node in the graph for this virtual, bad news. | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." - ( text "There is no node in the graph for register " + ( text "There is no node in the graph for register " <> ppr reg $$ ppr code $$ Color.dotGraph diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 7267ef8eae..1ec8d1276f 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -46,7 +46,7 @@ regSpill -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmDecl statics instr] + ([LiveCmmDecl statics instr] -- code with SPILL and RELOAD meta instructions added. , UniqSet Int -- left over slots , SpillStats ) -- stats about what happened during spilling @@ -83,9 +83,9 @@ regSpill platform code slotsFree regs regSpill_top :: Instruction instr => Platform - -> RegMap Int + -> RegMap Int -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmDecl statics instr + -> LiveCmmDecl statics instr -- ^ the top level thing. -> SpillM (LiveCmmDecl statics instr) @@ -109,7 +109,7 @@ regSpill_top platform regSlotMap cmm -- after we've done a successful allocation. let liveSlotsOnEntry' :: Map BlockId (Set Int) liveSlotsOnEntry' - = mapFoldWithKey patchLiveSlot + = mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry let info' @@ -126,12 +126,12 @@ regSpill_top platform regSlotMap cmm -- if registers in this block are being spilled to stack slots, -- then record the fact that these slots are now live in those blocks -- in the given slotmap. - patchLiveSlot - :: BlockId -> RegSet + patchLiveSlot + :: BlockId -> RegSet -> Map BlockId (Set Int) -> Map BlockId (Set Int) patchLiveSlot blockId regsLive slotMap - = let + = let -- Slots that are already recorded as being live. curSlotsLive = fromMaybe Set.empty $ Map.lookup blockId slotMap @@ -142,7 +142,7 @@ regSpill_top platform regSlotMap cmm $ uniqSetToList regsLive slotMap' - = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) + = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) slotMap in slotMap' @@ -295,10 +295,10 @@ patchInstr reg instr -- If it's not then something has gone horribly wrong. let nReg = case reg of - RegVirtual vr + RegVirtual vr -> RegVirtual (renameVirtualReg nUnique vr) - RegReal{} + RegReal{} -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" let instr' = patchReg1 reg nReg instr diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 01ab3efff1..f472d29270 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -50,7 +50,7 @@ import qualified Data.Set as Set -- | The identification number of a spill slot. --- A value is stored in a spill slot when we don't have a free +-- A value is stored in a spill slot when we don't have a free -- register to hold it. type Slot = Int @@ -58,8 +58,8 @@ type Slot = Int -- | Clean out unneeded spill\/reloads from this top level thing. cleanSpills :: Instruction instr - => Platform - -> LiveCmmDecl statics instr + => Platform + -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr cleanSpills platform cmm @@ -84,7 +84,7 @@ cleanSpin platform spinCount code code_forward <- mapBlockTopM (cleanBlockForward platform) code code_backward <- cleanTopBackward code_forward - + -- During the cleaning of each block we collected information about -- what regs were valid across each jump. Based on this, work out -- whether it will be safe to erase reloads after join points for @@ -158,7 +158,7 @@ cleanForward platform blockId assoc acc (li1 : li2 : instrs) = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } cleanForward platform blockId assoc acc - $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing + $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing : instrs cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) @@ -245,7 +245,7 @@ cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) | otherwise = do -- Update the association. let assoc' - = addAssoc (SReg reg) (SSlot slot) + = addAssoc (SReg reg) (SSlot slot) -- doing the reload makes reg and slot the same value $ delAssoc (SReg reg) -- reg value changes on reload @@ -290,7 +290,7 @@ cleanReload _ _ _ _ -- we should really be updating the noReloads set as we cross jumps also. -- -- TODO: generate noReloads from liveSlotsOnEntry --- +-- cleanTopBackward :: Instruction instr => LiveCmmDecl statics instr @@ -300,17 +300,17 @@ cleanTopBackward cmm = case cmm of CmmData{} -> return cmm - + CmmProc info label live sccs | LiveInfo _ _ _ liveSlotsOnEntry <- info -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label live sccs' + return $ CmmProc info label live sccs' -cleanBlockBackward +cleanBlockBackward :: Instruction instr => Map BlockId (Set Int) - -> LiveBasicBlock instr + -> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr) cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs) @@ -332,7 +332,7 @@ cleanBackward liveSlotsOnEntry noReloads acc lis cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis -cleanBackward' +cleanBackward' :: Instruction instr => Map BlockId (Set Int) -> UniqFM [BlockId] @@ -379,17 +379,17 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs) -- liveness map doesn't get updated. | LiveInstr instr _ <- li , targets <- jumpDestsOfInstr instr - = do + = do let slotsReloadedByTargets = Set.unions $ catMaybes - $ map (flip Map.lookup liveSlotsOnEntry) + $ map (flip Map.lookup liveSlotsOnEntry) $ targets - + let noReloads' - = foldl' delOneFromUniqSet noReloads + = foldl' delOneFromUniqSet noReloads $ Set.toList slotsReloadedByTargets - + cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs -- some other instruction @@ -423,7 +423,7 @@ findRegOfSlot assoc slot ------------------------------------------------------------------------------- -- | Cleaner monad. -type CleanM +type CleanM = State CleanS -- | Cleaner state. diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 97616baaf1..a797514482 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -136,12 +136,12 @@ slurpSpillCostInfo platform cmm -- | Take all the virtual registers from this set. takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg -takeVirtuals set +takeVirtuals set = mapUniqSet get_virtual $ filterUniqSet isVirtualReg set where - get_virtual (RegVirtual vr) = vr - get_virtual _ = panic "getVirt" + get_virtual (RegVirtual vr) = vr + get_virtual _ = panic "getVirt" -- | Choose a node to spill from this graph @@ -215,7 +215,7 @@ spillCost_chaitin info graph reg = 0 -- Otherwise revert to chaitin's regular cost function. - | otherwise = fromIntegral (uses + defs) + | otherwise = fromIntegral (uses + defs) / fromIntegral (nodeDegree graph reg) where (_, defs, uses, lifetime) = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg @@ -232,7 +232,7 @@ spillCost_length info _ reg | lifetime <= 1 = 1/0 | otherwise = 1 / fromIntegral lifetime where (_, _, _, lifetime) - = fromMaybe (reg, 0, 0, 0) + = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg @@ -246,19 +246,19 @@ lifeMapFromSpillCostInfo info -- | Determine the degree (number of neighbors) of this node which -- have the same class. -nodeDegree +nodeDegree :: (VirtualReg -> RegClass) - -> Graph VirtualReg RegClass RealReg - -> VirtualReg + -> Graph VirtualReg RegClass RealReg + -> VirtualReg -> Int nodeDegree classOfVirtualReg graph reg | Just node <- lookupUFM (graphMap graph) reg - , virtConflicts - <- length + , virtConflicts + <- length $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) - $ uniqSetToList + $ uniqSetToList $ nodeConflicts node = virtConflicts + sizeUniqSet (nodeExclusions node) @@ -269,11 +269,11 @@ nodeDegree classOfVirtualReg graph reg -- | Show a spill cost record, including the degree from the graph -- and final calulated spill cost. -pprSpillCostRecord +pprSpillCostRecord :: (VirtualReg -> RegClass) -> (Reg -> SDoc) - -> Graph VirtualReg RegClass RealReg - -> SpillCostRecord + -> Graph VirtualReg RegClass RealReg + -> SpillCostRecord -> SDoc pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) @@ -283,6 +283,6 @@ pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) , ppr defs , ppr life , ppr $ nodeDegree regClass graph reg - , text $ show $ (fromIntegral (uses + defs) + , text $ show $ (fromIntegral (uses + defs) / fromIntegral (nodeDegree regClass graph reg) :: Float) ] diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 8fada96ee2..07f4266b48 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -41,13 +41,13 @@ data RegAllocStats statics instr -- Information about the initial conflict graph. = RegAllocStatsStart { -- | Initial code, with liveness. - raLiveCmm :: [LiveCmmDecl statics instr] + raLiveCmm :: [LiveCmmDecl statics instr] -- | The initial, uncolored graph. - , raGraph :: Color.Graph VirtualReg RegClass RealReg + , raGraph :: Color.Graph VirtualReg RegClass RealReg -- | Information to help choose which regs to spill. - , raSpillCosts :: SpillCostInfo } + , raSpillCosts :: SpillCostInfo } -- Information about an intermediate graph. @@ -55,22 +55,22 @@ data RegAllocStats statics instr -- instruction stream. | RegAllocStatsSpill { -- | Code we tried to allocate registers for. - raCode :: [LiveCmmDecl statics instr] + raCode :: [LiveCmmDecl statics instr] -- | Partially colored graph. , raGraph :: Color.Graph VirtualReg RegClass RealReg -- | The regs that were coaleced. - , raCoalesced :: UniqFM VirtualReg + , raCoalesced :: UniqFM VirtualReg -- | Spiller stats. - , raSpillStats :: SpillStats + , raSpillStats :: SpillStats -- | Number of instructions each reg lives for. - , raSpillCosts :: SpillCostInfo + , raSpillCosts :: SpillCostInfo -- | Code with spill instructions added. - , raSpilled :: [LiveCmmDecl statics instr] } + , raSpilled :: [LiveCmmDecl statics instr] } -- a successful coloring @@ -103,7 +103,7 @@ data RegAllocStats statics instr , raSRMs :: (Int, Int, Int) } -instance (Outputable statics, Outputable instr) +instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> @@ -141,7 +141,7 @@ instance (Outputable statics, Outputable instr) $$ ppr (raSpilled s) - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = sdocWithPlatform $ \platform -> text "# Colored" @@ -304,7 +304,7 @@ countSRMs cmm = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) -countSRM_block +countSRM_block :: Instruction instr => GenBasicBlock (LiveInstr instr) -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index bee091b584..2d593c626d 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -657,12 +657,12 @@ saveClobberedTemps clobbered dying -- (2) no free registers: spill the value [] -> do (spill, slot) <- spillR (RegReal reg) temp - + -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) - + let new_assign = addToUFM assig temp (InBoth reg slot) - + clobber new_assign (spill : instrs) rest diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs index b76fe79d7d..a2a6dacb65 100644 --- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs @@ -37,7 +37,7 @@ releaseReg (RealRegSingle r) (FreeRegs g f) releaseReg _ _ = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" - + initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldr releaseReg noFreeRegs (allocatableRegs platform) @@ -52,7 +52,7 @@ getFreeRegs cls (FreeRegs g f) | otherwise = go x (m `shiftR` 1) $! i-1 allocateReg :: RealReg -> FreeRegs -> FreeRegs -allocateReg (RealRegSingle r) (FreeRegs g f) +allocateReg (RealRegSingle r) (FreeRegs g f) | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs index 2cb9999ce7..89a9407b71 100644 --- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs @@ -28,8 +28,8 @@ import Data.Bits -- -- Free regs have a bit set in the corresponding bitmap. -- -data FreeRegs - = FreeRegs +data FreeRegs + = FreeRegs !Word32 -- int reg bitmap regs 0..31 !Word32 -- float reg bitmap regs 32..63 !Word32 -- double reg bitmap regs 32..63 @@ -47,23 +47,23 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldr (releaseReg platform) noFreeRegs allocatableRegs - + -- | Get all the free registers of this class. getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily getFreeRegs cls (FreeRegs g f d) - | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 - | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 - | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 + | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 + | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 + | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) where go _ _ 0 _ = [] - go step bitmap mask ix - | bitmap .&. mask /= 0 - = ix : (go step bitmap (mask `shiftL` step) $! ix + step) + go step bitmap mask ix + | bitmap .&. mask /= 0 + = ix : (go step bitmap (mask `shiftL` step) $! ix + step) - | otherwise + | otherwise = go step bitmap (mask `shiftL` step) $! ix + step @@ -76,19 +76,19 @@ allocateReg platform -- can't allocate free regs | not $ freeReg platform r = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) - + -- a general purpose reg | r <= 31 = let mask = complement (bitMask r) - in FreeRegs - (g .&. mask) - f + in FreeRegs + (g .&. mask) + f d -- a float reg | r >= 32, r <= 63 = let mask = complement (bitMask (r - 32)) - + -- the mask of the double this FP reg aliases maskLow = if r `mod` 2 == 0 then complement (bitMask (r - 32)) @@ -100,11 +100,11 @@ allocateReg platform | otherwise = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - + allocateReg _ reg@(RealRegPair r1 r2) (FreeRegs g f d) - + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 , r2 >= 32, r2 <= 63 = let mask1 = complement (bitMask (r1 - 32)) @@ -114,19 +114,19 @@ allocateReg _ g ((f .&. mask1) .&. mask2) (d .&. mask1) - + | otherwise = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - + -- | Release a register from allocation. --- The register liveness information says that most regs die after a C call, +-- The register liveness information says that most regs die after a C call, -- but we still don't want to allocate to some of them. -- releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs releaseReg platform - reg@(RealRegSingle r) + reg@(RealRegSingle r) regs@(FreeRegs g f d) -- don't release pinned reg @@ -134,28 +134,28 @@ releaseReg platform = regs -- a general purpose reg - | r <= 31 + | r <= 31 = let mask = bitMask r in FreeRegs (g .|. mask) f d -- a float reg | r >= 32, r <= 63 = let mask = bitMask (r - 32) - + -- the mask of the double this FP reg aliases maskLow = if r `mod` 2 == 0 then bitMask (r - 32) else bitMask (r - 32 - 1) - in FreeRegs - g + in FreeRegs + g (f .|. mask) (d .|. maskLow) | otherwise = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - + releaseReg _ - reg@(RealRegPair r1 r2) + reg@(RealRegPair r1 r2) (FreeRegs g f d) | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 @@ -167,10 +167,10 @@ releaseReg _ g ((f .|. mask1) .|. mask2) (d .|. mask1) - + | otherwise = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - + bitMask :: Int -> Word32 diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs index 85ea6771b8..748fb98c30 100644 --- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -28,8 +28,8 @@ import Unique -- | Identifier for a stack slot. type StackSlot = Int -data StackMap - = StackMap +data StackMap + = StackMap { -- | The slots that are still available to be allocated. stackMapNextFreeSlot :: !Int diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index 83f5fbc950..b7d93f4436 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -33,7 +33,7 @@ binSpillReasons reasons -- | Count reg-reg moves remaining in this code. -countRegRegMovesNat +countRegRegMovesNat :: Instruction instr => NatCmmDecl statics instr -> Int @@ -54,8 +54,8 @@ countRegRegMovesNat cmm -- | Pretty print some RegAllocStats -pprStats - :: Instruction instr +pprStats + :: Instruction instr => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc pprStats code statss diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 1942891c77..f186d437d0 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -27,30 +27,30 @@ import OrdList import Outputable -- | Code to assign a 64 bit value to memory. -assignMem_I64Code +assignMem_I64Code :: CmmExpr -- ^ expr producing the destination address -> CmmExpr -- ^ expr producing the source value. -> NatM InstrBlock -assignMem_I64Code addrTree valueTree +assignMem_I64Code addrTree valueTree = do - ChildCode64 vcode rlo <- iselExpr64 valueTree + ChildCode64 vcode rlo <- iselExpr64 valueTree (src, acode) <- getSomeReg addrTree - let + let rhi = getHiVRegFromLo rlo - + -- Big-endian store mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0)) mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4)) - + code = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo -{- pprTrace "assignMem_I64Code" +{- pprTrace "assignMem_I64Code" (vcat [ text "addrTree: " <+> ppr addrTree , text "valueTree: " <+> ppr valueTree , text "vcode:" - , vcat $ map ppr $ fromOL vcode + , vcat $ map ppr $ fromOL vcode , text "" , text "acode:" , vcat $ map ppr $ fromOL acode ]) @@ -59,15 +59,15 @@ assignMem_I64Code addrTree valueTree -- | Code to assign a 64 bit value to a register. -assignReg_I64Code +assignReg_I64Code :: CmmReg -- ^ the destination register -> CmmExpr -- ^ expr producing the source value -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree +assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree + let r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk) r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo @@ -88,7 +88,7 @@ assignReg_I64Code _ _ iselExpr64 :: CmmExpr -> NatM ChildCode64 -- Load a 64 bit word -iselExpr64 (CmmLoad addrTree ty) +iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do Amode amode addr_code <- getAmode addrTree let result @@ -98,8 +98,8 @@ iselExpr64 (CmmLoad addrTree ty) tmp <- getNewRegNat II32 let rhi = getHiVRegFromLo rlo - return $ ChildCode64 - ( addr_code + return $ ChildCode64 + ( addr_code `appOL` toOL [ ADD False False r1 (RIReg r2) tmp , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi @@ -109,9 +109,9 @@ iselExpr64 (CmmLoad addrTree ty) | AddrRegImm r1 (ImmInt i) <- amode = do rlo <- getNewRegNat II32 let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code + + return $ ChildCode64 + ( addr_code `appOL` toOL [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ]) @@ -119,23 +119,23 @@ iselExpr64 (CmmLoad addrTree ty) | otherwise = panic "SPARC.CodeGen.Gen64: no match" - + result -- Add a literal to a 64 bit integer -iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) +iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do ChildCode64 code1 r1_lo <- iselExpr64 e1 let r1_hi = getHiVRegFromLo r1_lo - + r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - + let r_dst_hi = getHiVRegFromLo r_dst_lo + let code = code1 `appOL` toOL [ ADD False True r1_lo (RIImm (ImmInteger i)) r_dst_lo , ADD True False r1_hi (RIReg g0) r_dst_hi ] - + return $ ChildCode64 code r_dst_lo @@ -146,21 +146,21 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1, e2]) ChildCode64 code2 r2_lo <- iselExpr64 e2 let r2_hi = getHiVRegFromLo r2_lo - + r_dst_lo <- getNewRegNat II32 let r_dst_hi = getHiVRegFromLo r_dst_lo - + let code = code1 `appOL` code2 `appOL` toOL [ ADD False True r1_lo (RIReg r2_lo) r_dst_lo , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] - + return $ ChildCode64 code r_dst_lo -iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) - | isWord64 ty +iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) + | isWord64 ty = do r_dst_lo <- getNewRegNat II32 let r_dst_hi = getHiVRegFromLo r_dst_lo @@ -174,7 +174,7 @@ iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) ) -- Convert something into II64 -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) +iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do r_dst_lo <- getNewRegNat II32 let r_dst_hi = getHiVRegFromLo r_dst_lo @@ -188,12 +188,9 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) `appOL` toOL [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits , mkRegRegMoveInstr platform a_reg r_dst_lo ] - + return $ ChildCode64 code r_dst_lo iselExpr64 expr = pprPanic "iselExpr64(sparc)" (ppr expr) - - - diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index f73479695a..b5214c17b3 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -253,8 +253,6 @@ data AnnKeywordId | AnnRec | AnnRole | AnnSafe - | AnnStar -- ^ '*' - | AnnStarU -- ^ '*', unicode variant. | AnnSemi -- ^ ';' | AnnSimpleQuote -- ^ ''' | AnnStatic -- ^ 'static' @@ -330,9 +328,7 @@ unicodeAnn Annlarrowtail = AnnLarrowtailU unicodeAnn Annrarrowtail = AnnrarrowtailU unicodeAnn AnnLarrowtail = AnnLarrowtailU unicodeAnn AnnRarrowtail = AnnRarrowtailU -unicodeAnn AnnStar = AnnStarU unicodeAnn ann = ann --- What about '*'? -- | Some template haskell tokens have two variants, one with an `e` the other diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index db96acbcbc..3f6fa8c6e0 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -605,7 +605,6 @@ data Token | ITdarrow IsUnicodeSyntax | ITminus | ITbang - | ITstar IsUnicodeSyntax | ITdot | ITbiglam -- GHC-extension symbols @@ -807,9 +806,6 @@ reservedSymsFM = listToUFM $ ,("-", ITminus, always) ,("!", ITbang, always) - -- For data T (a::*) = MkT - ,("*", ITstar NormalSyntax, always) - -- \i -> kindSigsEnabled i || tyFamEnabled i) -- For 'forall a . t' ,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i) @@ -833,8 +829,6 @@ reservedSymsFM = listToUFM $ ,("⤜", ITRarrowtail UnicodeSyntax, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("★", ITstar UnicodeSyntax, unicodeSyntaxEnabled) - -- ToDo: ideally, → and ∷ should be "specials", so that they cannot -- form part of a large operator. This would let us have a better -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). @@ -2007,7 +2001,6 @@ data ExtBits | PatternSynonymsBit -- pattern synonyms | HaddockBit-- Lex and parse Haddock comments | MagicHashBit -- "#" in both functions and operators - | KindSigsBit -- Kind signatures on type variables | RecursiveDoBit -- mdo | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc | UnboxedTuplesBit -- (# and #) @@ -2052,8 +2045,6 @@ haddockEnabled :: ExtsBitmap -> Bool haddockEnabled = xtest HaddockBit magicHashEnabled :: ExtsBitmap -> Bool magicHashEnabled = xtest MagicHashBit --- kindSigsEnabled :: ExtsBitmap -> Bool --- kindSigsEnabled = xtest KindSigsBit unicodeSyntaxEnabled :: ExtsBitmap -> Bool unicodeSyntaxEnabled = xtest UnicodeSyntaxBit unboxedTuplesEnabled :: ExtsBitmap -> Bool @@ -2140,7 +2131,6 @@ mkPState flags buf loc = .|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags .|. HaddockBit `setBitIf` gopt Opt_Haddock flags .|. MagicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. KindSigsBit `setBitIf` xopt Opt_KindSignatures flags .|. RecursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags .|. UnicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags .|. UnboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index bbde989293..06be056575 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -59,7 +59,7 @@ import BasicTypes -- compiler/types import Type ( funTyCon ) -import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) +import Kind ( Kind ) import Class ( FunDep ) -- compiler/parser @@ -73,10 +73,11 @@ import TcEvidence ( emptyTcEvBinds ) -- compiler/prelude import ForeignCall -import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon ) +import TysPrim ( eqPrimTyCon ) +import PrelNames ( eqTyCon_RDR ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) + listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) -- compiler/utils import Util ( looksLikePackageName ) @@ -84,9 +85,9 @@ import Prelude } -{- Last updated: 31 Jul 2015 +{- Last updated: 18 Nov 2015 -Conflicts: 47 shift/reduce +Conflicts: 36 shift/reduce If you modify this parser and add a conflict, please update this comment. You can learn more about the conflicts by passing 'happy' the -i flag: @@ -127,35 +128,26 @@ state 46 contains 2 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 50 contains 11 shift/reduce conflicts. +state 50 contains 1 shift/reduce conflict. - context -> btype . (rule 282) - *** type -> btype . (rule 283) - type -> btype . qtyconop type (rule 284) - type -> btype . tyvarop type (rule 285) - type -> btype . '->' ctype (rule 286) - type -> btype . SIMPLEQUOTE qconop type (rule 287) - type -> btype . SIMPLEQUOTE varop type (rule 288) - btype -> btype . atype (rule 299) + context -> btype . (rule 295) + *** type -> btype . (rule 297) + type -> btype . '->' ctype (rule 298) - Conflicts: ':' '->' '-' '!' '*' '.' '`' VARSYM CONSYM QVARSYM QCONSYM + Conflicts: '->' -Example of ambiguity: 'e :: a `b` c'; does this mean - (e::a) `b` c, or - (e :: (a `b` c)) +------------------------------------------------------------------------------- + +state 51 contains 9 shift/reduce conflicts. + + *** btype -> tyapps . (rule 303) + tyapps -> tyapps . tyapp (rule 307) -The case for '->' involves view patterns rather than type operators: - 'case v of { x :: T -> T ... } ' - Which of these two is intended? - case v of - (x::T) -> T -- Rhs is T - or - case v of - (x::T -> T) -> .. -- Rhs is ... + Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM ------------------------------------------------------------------------------- -state 119 contains 15 shift/reduce conflicts. +state 132 contains 14 shift/reduce conflicts. exp -> infixexp . '::' sigtype (rule 416) exp -> infixexp . '-<' exp (rule 417) @@ -165,7 +157,7 @@ state 119 contains 15 shift/reduce conflicts. *** exp -> infixexp . (rule 421) infixexp -> infixexp . qop exp10 (rule 423) - Conflicts: ':' '::' '-' '!' '*' '-<' '>-' '-<<' '>>-' + Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-' '.' '`' VARSYM CONSYM QVARSYM QCONSYM Examples of ambiguity: @@ -180,7 +172,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 279 contains 1 shift/reduce conflicts. +state 292 contains 1 shift/reduce conflicts. rule -> STRING . rule_activation rule_forall infixexp '=' exp (rule 215) @@ -198,23 +190,18 @@ a rule instructing how to rewrite the expression '[0] f'. ------------------------------------------------------------------------------- -state 288 contains 11 shift/reduce conflicts. +state 301 contains 1 shift/reduce conflict. - *** type -> btype . (rule 283) - type -> btype . qtyconop type (rule 284) - type -> btype . tyvarop type (rule 285) - type -> btype . '->' ctype (rule 286) - type -> btype . SIMPLEQUOTE qconop type (rule 287) - type -> btype . SIMPLEQUOTE varop type (rule 288) - btype -> btype . atype (rule 299) + *** type -> btype . (rule 297) + type -> btype . '->' ctype (rule 298) - Conflicts: ':' '->' '-' '!' '*' '.' '`' VARSYM CONSYM QVARSYM QCONSYM + Conflict: '->' -Same as State 50, but minus the context productions. +Same as state 50 but without contexts. ------------------------------------------------------------------------------- -state 324 contains 1 shift/reduce conflicts. +state 337 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail (rule 505) sysdcon_nolist -> '(' commas . ')' (rule 616) @@ -229,7 +216,7 @@ if -XTupleSections is not specified. ------------------------------------------------------------------------------- -state 376 contains 1 shift/reduce conflicts. +state 388 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail (rule 505) sysdcon_nolist -> '(#' commas . '#)' (rule 618) @@ -241,20 +228,18 @@ Same as State 324 for unboxed tuples. ------------------------------------------------------------------------------- -state 404 contains 1 shift/reduce conflicts. +state 460 contains 1 shift/reduce conflict. - exp10 -> 'let' binds . 'in' exp (rule 425) - exp10 -> 'let' binds . 'in' error (rule 440) - exp10 -> 'let' binds . error (rule 441) - *** qual -> 'let' binds . (rule 579) + oqtycon -> '(' qtyconsym . ')' (rule 621) + *** qtyconop -> qtyconsym . (rule 628) - Conflict: error + Conflict: ')' TODO: Why? ------------------------------------------------------------------------------- -state 633 contains 1 shift/reduce conflicts. +state 635 contains 1 shift/reduce conflicts. *** aexp2 -> ipvar . (rule 466) dbind -> ipvar . '=' exp (rule 590) @@ -269,7 +254,7 @@ sensible meaning, namely the lhs of an implicit binding. ------------------------------------------------------------------------------- -state 699 contains 1 shift/reduce conflicts. +state 702 contains 1 shift/reduce conflicts. rule -> STRING rule_activation . rule_forall infixexp '=' exp (rule 215) @@ -286,7 +271,7 @@ doesn't include 'forall'. ------------------------------------------------------------------------------- -state 950 contains 1 shift/reduce conflicts. +state 930 contains 1 shift/reduce conflicts. transformqual -> 'then' 'group' . 'using' exp (rule 528) transformqual -> 'then' 'group' . 'by' exp 'using' exp (rule 529) @@ -294,6 +279,16 @@ state 950 contains 1 shift/reduce conflicts. Conflict: 'by' +------------------------------------------------------------------------------- + +state 1270 contains 1 shift/reduce conflict. + + *** atype -> tyvar . (rule 314) + tv_bndr -> '(' tyvar . '::' kind ')' (rule 346) + + Conflict: '::' + +TODO: Why? ------------------------------------------------------------------------------- -- API Annotations @@ -413,7 +408,6 @@ output it generates. '=>' { L _ (ITdarrow _) } '-' { L _ ITminus } '!' { L _ ITbang } - '*' { L _ (ITstar _) } '-<' { L _ (ITlarrowtail _) } -- for arrow notation '>-' { L _ (ITrarrowtail _) } -- for arrow notation '-<<' { L _ (ITLarrowtail _) } -- for arrow notation @@ -1606,12 +1600,22 @@ ctypedoc :: { LHsType RdrName } -- but not f :: ?x::Int => blah -- See Note [Parsing ~] context :: { LHsContext RdrName } - : btype {% do { (anns,ctx) <- checkContext (splitTilde $1) + : btype {% do { (anns,ctx) <- checkContext $1 ; if null (unLoc ctx) then addAnnotation (gl $1) AnnUnit (gl $1) else return () ; ams ctx anns } } + +context_no_ops :: { LHsContext RdrName } + : btype_no_ops {% do { let { ty = splitTilde $1 } + ; (anns,ctx) <- checkContext ty + ; if null (unLoc ctx) + then addAnnotation (gl ty) AnnUnit (gl ty) + else return () + ; ams ctx anns + } } + {- Note [GADT decl discards annotations] ~~~~~~~~~~~~~~~~~~~~~ The type production for @@ -1628,40 +1632,49 @@ the top-level annotation will be disconnected. Hence for this specific case it is connected to the first type too. -} --- See Note [Parsing ~] type :: { LHsType RdrName } - : btype { splitTilde $1 } - | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } - | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } - | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3) - [mu AnnRarrow $2] } - | btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) - [mj AnnSimpleQuote $2] } - | btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) - [mj AnnSimpleQuote $2] } --- See Note [Parsing ~] + : btype { $1 } + | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] + >> ams (sLL $1 $> $ HsFunTy $1 $3) + [mu AnnRarrow $2] } + + typedoc :: { LHsType RdrName } - : btype { splitTilde $1 } - | btype docprev { sLL $1 $> $ HsDocTy (splitTilde $1) $2 } - | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } - | btype qtyconop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } - | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } - | btype tyvarop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } - | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3) + : btype { $1 } + | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } + | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) [mu AnnRarrow $2] } - | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (L (comb2 (splitTilde $1) $2) - (HsDocTy $1 $2)) $4) + | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ + HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) + $4) [mu AnnRarrow $3] } - | btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) - [mj AnnSimpleQuote $2] } - | btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4) - [mj AnnSimpleQuote $2] } +-- See Note [Parsing ~] btype :: { LHsType RdrName } - : btype atype { sLL $1 $> $ HsAppTy $1 $2 } + : tyapps { sL1 $1 $ HsAppsTy (splitTildeApps (reverse (unLoc $1))) } + +-- Used for parsing Haskell98-style data constructors, +-- in order to forbid the blasphemous +-- > data Foo = Int :+ Char :* Bool +-- See also Note [Parsing data constructors is hard]. +btype_no_ops :: { LHsType RdrName } + : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 } | atype { $1 } +tyapps :: { Located [HsAppType RdrName] } -- NB: This list is reversed + : tyapp { sL1 $1 [unLoc $1] } + | tyapps tyapp { sLL $1 $> $ (unLoc $2) : (unLoc $1) } + +-- See Note [HsAppsTy] in HsTypes +tyapp :: { Located (HsAppType RdrName) } + : atype { sL1 $1 $ HsAppPrefix $1 } + | qtyconop { sL1 $1 $ HsAppInfix $1 } + | tyvarop { sL1 $1 $ HsAppInfix $1 } + | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2) + [mj AnnSimpleQuote $1] } + | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2) + [mj AnnSimpleQuote $1] } + atype :: { LHsType RdrName } : ntgtycon { sL1 $1 (HsTyVar $1) } -- Not including unit tuples | tyvar {% do { nwc <- namedWildCardsEnabled -- (See Note [Unit tuples]) @@ -1797,37 +1810,7 @@ turn them into HsEqTy's. -- Kinds kind :: { LHsKind RdrName } - : bkind { $1 } - | bkind '->' kind {% ams (sLL $1 $> $ HsFunTy $1 $3) - [mu AnnRarrow $2] } - -bkind :: { LHsKind RdrName } - : akind { $1 } - | bkind akind { sLL $1 $> $ HsAppTy $1 $2 } - -akind :: { LHsKind RdrName } - : '*' {% ams (sL1 $1 $ HsTyVar (sL1 $1 (nameRdrName liftedTypeKindTyConName))) - [mu AnnStar $1] } - | '(' kind ')' {% ams (sLL $1 $> $ HsParTy $2) - [mop $1,mcp $3] } - | pkind { $1 } - | tyvar { sL1 $1 $ HsTyVar $1 } - -pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] - : qtycon { sL1 $1 $ HsTyVar $1 } - | '(' ')' {% ams (sLL $1 $> $ HsTyVar $ (sLL $1 $> $ getRdrName unitTyCon)) - [mop $1,mcp $2] } - | '(' kind ',' comma_kinds1 ')' - {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsTupleTy HsBoxedTuple ( $2 : $4)) - [mop $1,mcp $5] } - | '[' kind ']' {% ams (sLL $1 $> $ HsListTy $2) - [mos $1,mcs $3] } - -comma_kinds1 :: { [LHsKind RdrName] } - : kind { [$1] } - | kind ',' comma_kinds1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return ($1 : $3) } + : ctype { $1 } {- Note [Promotion] ~~~~~~~~~~~~~~~~ @@ -1840,12 +1823,6 @@ few reasons: 2. if one day we merge types and kinds, tick would mean look in DataName 3. we don't have a kind namespace anyway -- Syntax of explicit kind polymorphism (IA0_TODO: not yet implemented) -Kind abstraction is implicit. We write -> data SList (s :: k -> *) (as :: [k]) where ... -because it looks like what we do in terms -> id (x :: a) = x - - Name resolution When the user write Zero instead of 'Zero in types, we parse it a HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We @@ -1922,7 +1899,7 @@ constrs1 :: { Located [LConDecl RdrName] } | constr { sL1 $1 [$1] } constr :: { LConDecl RdrName } - : maybe_docnext forall context '=>' constr_stuff maybe_docprev + : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev {% ams (let (con,details) = unLoc $5 in addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con (snd $ unLoc $2) $3 details)) @@ -1941,16 +1918,17 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) } constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- see Note [Parsing data constructors is hard] - : btype {% splitCon $1 >>= return.sLL $1 $> } - | btype conop btype { sLL $1 $> ($2, InfixCon $1 $3) } + : btype_no_ops {% do { c <- splitCon $1 + ; return $ sLL $1 $> c } } + | btype_no_ops conop btype_no_ops { sLL $1 $> ($2, InfixCon (splitTilde $1) $3) } {- Note [Parsing data constructors is hard] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We parse the constructor declaration C t1 t2 -as a btype (treating C as a type constructor) and then convert C to be +as a btype_no_ops (treating C as a type constructor) and then convert C to be a data constructor. Reason: it might continue like this: - C t1 t2 %: D Int + C t1 t2 :% D Int in which case C really would be a type constructor. We can't resolve this ambiguity till we come across the constructor oprerator :% (or not, more usually) -} @@ -2931,8 +2909,6 @@ tyconsym :: { Located RdrName } : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) } | ':' { sL1 $1 $! consDataCon_RDR } - | '*' {% ams (sL1 $1 $! mkUnqual tcClsName (fsLit "*")) - [mu AnnStar $1] } | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } @@ -3070,7 +3046,6 @@ special_id special_sym :: { Located FastString } special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } | '.' { sL1 $1 (fsLit ".") } - | '*' {% ams (sL1 $1 (fsLit "*")) [mu AnnStar $1] } ----------------------------------------------------------------------------- -- Data constructors @@ -3240,7 +3215,6 @@ isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 53e6184491..e8687acb6c 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -52,7 +52,7 @@ module RdrHsSyn ( checkDoAndIfThenElse, checkRecordSyntax, parseErrorSDoc, - splitTilde, + splitTilde, splitTildeApps, -- Help with processing exports ImpExpSubSpec(..), @@ -77,9 +77,10 @@ import Lexer import Type ( TyThing(..) ) import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, - listTyConName, listTyConKey ) + listTyConName, listTyConKey, + starKindTyConName, unicodeStarKindTyConName ) import ForeignCall -import PrelNames ( forall_tv_RDR, allNameStrings ) +import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings ) import DynFlags import SrcLoc import Unique ( hasKey ) @@ -443,9 +444,10 @@ splitCon :: LHsType RdrName splitCon ty = split ty [] where - split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) + -- This is used somewhere where HsAppsTy is not used + split (L _ (HsAppTy t u)) ts = split t (u : ts) + split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) @@ -641,8 +643,11 @@ checkTyVars pp_what equals_or_where tc tparms ; return (mkHsQTvs tvs) } where + chk (L _ (HsParTy ty)) = chk ty + chk (L _ (HsAppsTy [HsAppPrefix ty])) = chk ty + -- Check that the name space is correct! - chk (L l (HsKindSig (L lv (HsTyVar (L _ tv))) k)) + chk (L l (HsKindSig (L _ (HsAppsTy [HsAppPrefix (L lv (HsTyVar (L _ tv)))])) k)) | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) chk (L l (HsTyVar (L ltv tv))) | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) @@ -695,10 +700,18 @@ checkTyClHdr is_cls ty go l (HsTyVar (L _ tc)) acc ann | isRdrTc tc = return (L l tc, acc, ann) - go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann + go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann | isRdrTc tc = return (ltc, t1:t2:acc, ann) go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l) go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann + go _ (HsAppsTy ts) acc ann + | Just (head, args) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann + + go _ (HsAppsTy [HsAppInfix (L loc star)]) [] ann + | occNameFS (rdrNameOcc star) == fsLit "*" + = return (L loc (nameRdrName starKindTyConName), [], ann) + | occNameFS (rdrNameOcc star) == fsLit "★" + = return (L loc (nameRdrName unicodeStarKindTyConName), [], ann) go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann = return (L l (nameRdrName tup_name), ts, ann) @@ -718,6 +731,10 @@ checkContext (L l orig_t) check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () + -- don't let HsAppsTy get in the way + check anns (L _ (HsAppsTy [HsAppPrefix ty])) + = check anns ty + check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way = check anns' ty where anns' = if l == lp1 then anns @@ -1028,7 +1045,7 @@ isFunLhs e = go e [] [] go _ _ _ = return Nothing --- | Transform btype with strict_mark's into HsEqTy's +-- | Transform btype_no_ops with strict_mark's into HsEqTy's -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d splitTilde :: LHsType RdrName -> LHsType RdrName splitTilde t = go t @@ -1043,6 +1060,23 @@ splitTilde t = go t go t = t +-- | Transform tyapps with strict_marks into uses of twiddle +-- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d +splitTildeApps :: [HsAppType RdrName] -> [HsAppType RdrName] +splitTildeApps [] = [] +splitTildeApps (t : rest) = t : concatMap go rest + where go (HsAppPrefix + (L loc (HsBangTy + (HsSrcBang Nothing NoSrcUnpack SrcLazy) + ty))) + = [HsAppInfix (L tilde_loc eqTyCon_RDR), HsAppPrefix ty] + where + tilde_loc = srcSpanFirstCharacter loc + + go t = [t] + + + --------------------------------------------------------------------------- -- Check for monad comprehensions -- diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index 1a7e056ada..0651a2c299 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -34,14 +34,18 @@ import DataCon import Id import Name import MkId +import NameEnv import TysPrim import TysWiredIn import HscTypes +import UniqFM import Class import TyCon import Util +import Panic ( panic ) import {-# SOURCE #-} TcTypeNats ( typeNatTyCons ) +import Data.List ( intercalate ) import Data.Array {- @@ -77,7 +81,19 @@ knownKeyNames :: [Name] -- you get a Name with the correct known key -- (See Note [Known-key names] in PrelNames) knownKeyNames - = concat [ tycon_kk_names funTyCon + | debugIsOn + , not (isNullUFM badNamesEnv) + = panic ("badKnownKeyNames:\n" ++ badNamesStr) + -- NB: We can't use ppr here, because this is sometimes evaluated in a + -- context where there are no DynFlags available, leading to a cryptic + -- "<<details unavailable>>" error. (This seems to happen only in the + -- stage 2 compiler, for reasons I [Richard] have no clue of.) + + | otherwise + = names + where + names = + concat [ tycon_kk_names funTyCon , concatMap tycon_kk_names primTyCons , concatMap tycon_kk_names wiredInTyCons @@ -95,28 +111,40 @@ knownKeyNames , map idName wiredInIds , map (idName . primOpId) allThePrimOps , basicKnownKeyNames ] - where + -- "kk" short for "known-key" - tycon_kk_names :: TyCon -> [Name] - tycon_kk_names tc = tyConName tc : (rep_names tc ++ concatMap thing_kk_names (implicitTyConThings tc)) - - datacon_kk_names dc - | Promoted tc <- promoteDataCon_maybe dc = dataConName dc : rep_names tc - | otherwise = [dataConName dc] - - thing_kk_names :: TyThing -> [Name] - thing_kk_names (ATyCon tc) = tycon_kk_names tc - thing_kk_names (AConLike (RealDataCon dc)) = datacon_kk_names dc - thing_kk_names thing = [getName thing] - - -- The TyConRepName for a known-key TyCon has a known key, - -- but isn't itself an implicit thing. Yurgh. - -- NB: if any of the wired-in TyCons had record fields, the record - -- field names would be in a similar situation. Ditto class ops. - -- But it happens that there aren't any - rep_names tc = case tyConRepName_maybe tc of - Just n -> [n] - Nothing -> [] + tycon_kk_names :: TyCon -> [Name] + tycon_kk_names tc = tyConName tc : (rep_names tc ++ concatMap thing_kk_names (implicitTyConThings tc)) + + datacon_kk_names dc + = dataConName dc : rep_names (promoteDataCon dc) + + thing_kk_names :: TyThing -> [Name] + thing_kk_names (ATyCon tc) = tycon_kk_names tc + thing_kk_names (AConLike (RealDataCon dc)) = datacon_kk_names dc + thing_kk_names thing = [getName thing] + + -- The TyConRepName for a known-key TyCon has a known key, + -- but isn't itself an implicit thing. Yurgh. + -- NB: if any of the wired-in TyCons had record fields, the record + -- field names would be in a similar situation. Ditto class ops. + -- But it happens that there aren't any + rep_names tc = case tyConRepName_maybe tc of + Just n -> [n] + Nothing -> [] + + namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n) + emptyUFM names + badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv + badNamesPairs = nameEnvUniqueElts badNamesEnv + badNamesStrs = map pairToStr badNamesPairs + badNamesStr = unlines badNamesStrs + + pairToStr (uniq, ns) = " " ++ + show uniq ++ + ": [" ++ + intercalate ", " (map (occNameString . nameOccName) ns) ++ + "]" {- We let a lot of "non-standard" values be visible, so that we can make diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 057e96dbd4..a9b43227f5 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -372,6 +372,9 @@ basicKnownKeyNames , typeErrorVAppendDataConName , typeErrorShowTypeDataConName + -- homogeneous equality + , eqTyConName + ] ++ case cIntegerLibraryType of IntegerGMP -> [integerSDataConName] IntegerSimple -> [] @@ -417,7 +420,8 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, - cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module + cONTROL_EXCEPTION_BASE, gHC_TYPELITS, dATA_TYPE_EQUALITY, + dATA_COERCE :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") @@ -473,6 +477,8 @@ gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") +dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") +dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") gHC_PARR' :: Module gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") @@ -776,6 +782,9 @@ traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") mempty_RDR = varQual_RDR gHC_BASE (fsLit "mempty") mappend_RDR = varQual_RDR gHC_BASE (fsLit "mappend") +eqTyCon_RDR :: RdrName +eqTyCon_RDR = tcQual_RDR dATA_TYPE_EQUALITY (fsLit "~") + ---------------------- varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR :: Module -> FastString -> RdrName @@ -1360,6 +1369,10 @@ fingerprintDataConName :: Name fingerprintDataConName = dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey +-- homogeneous equality +eqTyConName :: Name +eqTyConName = tcQual dATA_TYPE_EQUALITY (fsLit "~") eqTyConKey + {- ************************************************************************ * * @@ -1491,8 +1504,8 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, - stablePtrTyConKey, anyTyConKey, eqTyConKey, smallArrayPrimTyConKey, - smallMutableArrayPrimTyConKey :: Unique + stablePtrTyConKey, anyTyConKey, eqTyConKey, heqTyConKey, + smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 boolTyConKey = mkPreludeTyConUnique 4 @@ -1529,8 +1542,9 @@ stablePtrPrimTyConKey = mkPreludeTyConUnique 35 stablePtrTyConKey = mkPreludeTyConUnique 36 anyTyConKey = mkPreludeTyConUnique 37 eqTyConKey = mkPreludeTyConUnique 38 -arrayArrayPrimTyConKey = mkPreludeTyConUnique 39 -mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 40 +heqTyConKey = mkPreludeTyConUnique 39 +arrayArrayPrimTyConKey = mkPreludeTyConUnique 40 +mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 41 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, @@ -1539,34 +1553,35 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, - eqReprPrimTyConKey, voidPrimTyConKey :: Unique + eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 eqPrimTyConKey = mkPreludeTyConUnique 53 eqReprPrimTyConKey = mkPreludeTyConUnique 54 -mutVarPrimTyConKey = mkPreludeTyConUnique 55 -ioTyConKey = mkPreludeTyConUnique 56 -voidPrimTyConKey = mkPreludeTyConUnique 57 -wordPrimTyConKey = mkPreludeTyConUnique 58 -wordTyConKey = mkPreludeTyConUnique 59 -word8TyConKey = mkPreludeTyConUnique 60 -word16TyConKey = mkPreludeTyConUnique 61 -word32PrimTyConKey = mkPreludeTyConUnique 62 -word32TyConKey = mkPreludeTyConUnique 63 -word64PrimTyConKey = mkPreludeTyConUnique 64 -word64TyConKey = mkPreludeTyConUnique 65 -liftedConKey = mkPreludeTyConUnique 66 -unliftedConKey = mkPreludeTyConUnique 67 -anyBoxConKey = mkPreludeTyConUnique 68 -kindConKey = mkPreludeTyConUnique 69 -boxityConKey = mkPreludeTyConUnique 70 -typeConKey = mkPreludeTyConUnique 71 -threadIdPrimTyConKey = mkPreludeTyConUnique 72 -bcoPrimTyConKey = mkPreludeTyConUnique 73 -ptrTyConKey = mkPreludeTyConUnique 74 -funPtrTyConKey = mkPreludeTyConUnique 75 -tVarPrimTyConKey = mkPreludeTyConUnique 76 +eqPhantPrimTyConKey = mkPreludeTyConUnique 55 +mutVarPrimTyConKey = mkPreludeTyConUnique 56 +ioTyConKey = mkPreludeTyConUnique 57 +voidPrimTyConKey = mkPreludeTyConUnique 58 +wordPrimTyConKey = mkPreludeTyConUnique 59 +wordTyConKey = mkPreludeTyConUnique 60 +word8TyConKey = mkPreludeTyConUnique 61 +word16TyConKey = mkPreludeTyConUnique 62 +word32PrimTyConKey = mkPreludeTyConUnique 63 +word32TyConKey = mkPreludeTyConUnique 64 +word64PrimTyConKey = mkPreludeTyConUnique 65 +word64TyConKey = mkPreludeTyConUnique 66 +liftedConKey = mkPreludeTyConUnique 67 +unliftedConKey = mkPreludeTyConUnique 68 +anyBoxConKey = mkPreludeTyConUnique 69 +kindConKey = mkPreludeTyConUnique 70 +boxityConKey = mkPreludeTyConUnique 71 +typeConKey = mkPreludeTyConUnique 72 +threadIdPrimTyConKey = mkPreludeTyConUnique 73 +bcoPrimTyConKey = mkPreludeTyConUnique 74 +ptrTyConKey = mkPreludeTyConUnique 75 +funPtrTyConKey = mkPreludeTyConUnique 76 +tVarPrimTyConKey = mkPreludeTyConUnique 77 -- Parallel array type constructor parrTyConKey :: Unique @@ -1579,33 +1594,17 @@ objectTyConKey = mkPreludeTyConUnique 83 eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 --- Super Kinds constructors -superKindTyConKey :: Unique -superKindTyConKey = mkPreludeTyConUnique 85 - -- Kind constructors -liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey, - unliftedTypeKindTyConKey, constraintKindTyConKey :: Unique -anyKindTyConKey = mkPreludeTyConUnique 86 +liftedTypeKindTyConKey, tYPETyConKey, + unliftedTypeKindTyConKey, constraintKindTyConKey, levityTyConKey, + starKindTyConKey, unicodeStarKindTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 -openTypeKindTyConKey = mkPreludeTyConUnique 88 +tYPETyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 +levityTyConKey = mkPreludeTyConUnique 90 constraintKindTyConKey = mkPreludeTyConUnique 92 - --- Coercion constructors -symCoercionTyConKey, transCoercionTyConKey, leftCoercionTyConKey, - rightCoercionTyConKey, instCoercionTyConKey, unsafeCoercionTyConKey, - csel1CoercionTyConKey, csel2CoercionTyConKey, cselRCoercionTyConKey - :: Unique -symCoercionTyConKey = mkPreludeTyConUnique 93 -transCoercionTyConKey = mkPreludeTyConUnique 94 -leftCoercionTyConKey = mkPreludeTyConUnique 95 -rightCoercionTyConKey = mkPreludeTyConUnique 96 -instCoercionTyConKey = mkPreludeTyConUnique 97 -unsafeCoercionTyConKey = mkPreludeTyConUnique 98 -csel1CoercionTyConKey = mkPreludeTyConUnique 99 -csel2CoercionTyConKey = mkPreludeTyConUnique 100 -cselRCoercionTyConKey = mkPreludeTyConUnique 101 +starKindTyConKey = mkPreludeTyConUnique 93 +unicodeStarKindTyConKey = mkPreludeTyConUnique 94 pluginTyConKey :: Unique pluginTyConKey = mkPreludeTyConUnique 102 @@ -1717,7 +1716,6 @@ ipTyConKey = mkPreludeTyConUnique 184 ipCoNameKey :: Unique ipCoNameKey = mkPreludeTyConUnique 185 - ---------------- Template Haskell ------------------- -- THNames.hs: USES TyConUniques 200-299 ----------------------------------------------------- @@ -1739,7 +1737,7 @@ ipCoNameKey = mkPreludeTyConUnique 185 charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - word8DataConKey, ioDataConKey, integerDataConKey, eqBoxDataConKey, + word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey, coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 @@ -1759,7 +1757,7 @@ trueDataConKey = mkPreludeDataConUnique 15 wordDataConKey = mkPreludeDataConUnique 16 ioDataConKey = mkPreludeDataConUnique 17 integerDataConKey = mkPreludeDataConUnique 18 -eqBoxDataConKey = mkPreludeDataConUnique 19 +heqDataConKey = mkPreludeDataConUnique 19 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique @@ -1799,10 +1797,15 @@ srcLocDataConKey = mkPreludeDataConUnique 37 ipDataConKey :: Unique ipDataConKey = mkPreludeDataConUnique 38 +-- Levity +liftedDataConKey, unliftedDataConKey :: Unique +liftedDataConKey = mkPreludeDataConUnique 39 +unliftedDataConKey = mkPreludeDataConUnique 40 + trTyConDataConKey, trModuleDataConKey, trNameSDataConKey :: Unique -trTyConDataConKey = mkPreludeDataConUnique 40 -trModuleDataConKey = mkPreludeDataConUnique 41 -trNameSDataConKey = mkPreludeDataConUnique 42 +trTyConDataConKey = mkPreludeDataConUnique 41 +trModuleDataConKey = mkPreludeDataConUnique 42 +trNameSDataConKey = mkPreludeDataConUnique 43 typeErrorTextDataConKey, typeErrorAppendDataConKey, @@ -2117,13 +2120,17 @@ toDynIdKey = mkPreludeMiscIdUnique 509 bitIntegerIdKey :: Unique bitIntegerIdKey = mkPreludeMiscIdUnique 510 +heqSCSelIdKey, coercibleSCSelIdKey :: Unique +heqSCSelIdKey = mkPreludeMiscIdUnique 511 +coercibleSCSelIdKey = mkPreludeMiscIdUnique 512 + sappendClassOpKey :: Unique -sappendClassOpKey = mkPreludeMiscIdUnique 511 +sappendClassOpKey = mkPreludeMiscIdUnique 513 memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique -memptyClassOpKey = mkPreludeMiscIdUnique 512 -mappendClassOpKey = mkPreludeMiscIdUnique 513 -mconcatClassOpKey = mkPreludeMiscIdUnique 514 +memptyClassOpKey = mkPreludeMiscIdUnique 514 +mappendClassOpKey = mkPreludeMiscIdUnique 515 +mconcatClassOpKey = mkPreludeMiscIdUnique 516 {- @@ -2176,3 +2183,21 @@ derivableClassKeys :: [Unique] derivableClassKeys = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, boundedClassKey, showClassKey, readClassKey ] + +{- +************************************************************************ +* * + Semi-builtin names +* * +************************************************************************ + +The following names should be considered by GHCi to be in scope always. + +-} + +pretendNameIsInScope :: Name -> Bool +pretendNameIsInScope n + = any (n `hasKey`) + [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey + , unliftedTypeKindTyConKey, levityTyConKey, liftedDataConKey + , unliftedDataConKey ] diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot index 0bd74d5577..e25c83618f 100644 --- a/compiler/prelude/PrelNames.hs-boot +++ b/compiler/prelude/PrelNames.hs-boot @@ -4,4 +4,5 @@ import Module import Unique mAIN :: Module -liftedTypeKindTyConKey :: Unique +starKindTyConKey :: Unique +unicodeStarKindTyConKey :: Unique diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 68140f73f3..3e9d7ae35a 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -35,7 +35,6 @@ import DataCon ( dataConTag, dataConTyCon, dataConWorkId ) import CoreUtils ( cheapEqExpr, exprIsHNF ) import CoreUnfold ( exprIsConApp_maybe ) import Type -import TypeRep import OccName ( occNameFS ) import PrelNames import Maybes ( orElse ) @@ -936,10 +935,9 @@ dataToTagRule = a `mplus` b -- seq# :: forall a s . a -> State# s -> (# State# s, a #) seqRule :: RuleM CoreExpr seqRule = do - [ty_a, Type ty_s, a, s] <- getArgs + [Type ty_a, Type ty_s, a, s] <- getArgs guard $ exprIsHNF a - return $ mkConApp (tupleDataCon Unboxed 2) - [Type (mkStatePrimTy ty_s), ty_a, s, a] + return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a] -- spark# :: forall a s . a -> State# s -> (# State# s, a #) sparkRule :: RuleM CoreExpr @@ -1178,7 +1176,7 @@ match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] , Just dictTc <- tyConAppTyCon_maybe dictTy , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc = Just - $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a])) + $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) `App` y match_magicDict _ = Nothing @@ -1195,8 +1193,8 @@ match_IntToInteger = match_IntToInteger_unop id match_WordToInteger :: RuleFun match_WordToInteger _ id_unf id [xl] | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl - = case idType id of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_WordToInteger: Id has the wrong type" @@ -1205,8 +1203,8 @@ match_WordToInteger _ _ _ _ = Nothing match_Int64ToInteger :: RuleFun match_Int64ToInteger _ id_unf id [xl] | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl - = case idType id of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_Int64ToInteger: Id has the wrong type" @@ -1215,8 +1213,8 @@ match_Int64ToInteger _ _ _ _ = Nothing match_Word64ToInteger :: RuleFun match_Word64ToInteger _ id_unf id [xl] | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl - = case idType id of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_Word64ToInteger: Id has the wrong type" @@ -1256,8 +1254,8 @@ warning in this case. match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun match_IntToInteger_unop unop _ id_unf fn [xl] | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl - = case idType fn of - FunTy _ integerTy -> + = case splitFunTy_maybe (idType fn) of + Just (_, integerTy) -> Just (Lit (LitInteger (unop x) integerTy)) _ -> panic "match_IntToInteger_unop: Id has the wrong type" @@ -1278,11 +1276,7 @@ match_Integer_divop_both divop _ id_unf _ [xl,yl] , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 , (r,s) <- x `divop` y - = Just $ mkConApp (tupleDataCon Unboxed 2) - [Type t, - Type t, - Lit (LitInteger r t), - Lit (LitInteger s t)] + = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)] match_Integer_divop_both _ _ _ _ _ = Nothing -- This helper is used for the quot and rem functions @@ -1350,17 +1344,17 @@ match_rationalTo _ _ _ _ _ = Nothing match_decodeDouble :: RuleFun match_decodeDouble _ id_unf fn [xl] | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl - = case idType fn of - FunTy _ (TyConApp _ [integerTy, intHashTy]) -> - case decodeFloat (fromRational x :: Double) of - (y, z) -> - Just $ mkConApp (tupleDataCon Unboxed 2) - [Type integerTy, - Type intHashTy, - Lit (LitInteger y integerTy), - Lit (MachInt (toInteger z))] + = case splitFunTy_maybe (idType fn) of + Just (_, res) + | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res + -> case decodeFloat (fromRational x :: Double) of + (y, z) -> + Just $ mkCoreUbxTup [integerTy, intHashTy] + [Lit (LitInteger y integerTy), + Lit (MachInt (toInteger z))] _ -> - panic "match_decodeDouble: Id has the wrong type" + pprPanic "match_decodeDouble: Id has the wrong type" + (ppr fn <+> dcolon <+> ppr (idType fn)) match_decodeDouble _ _ _ _ = Nothing match_XToIntegerToX :: Name -> RuleFun diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index 202fd815d5..67a44cc462 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -29,11 +29,9 @@ import TysWiredIn import CmmType import Demand -import Var ( TyVar ) import OccName ( OccName, pprOccName, mkVarOccFS ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) -import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, - typePrimRep ) +import Type import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..) ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) @@ -538,7 +536,7 @@ primOpType op Compare _occ ty -> compare_fun_ty ty GenPrimOp _occ tyvars arg_tys res_ty -> - mkForAllTys tyvars (mkFunTys arg_tys res_ty) + mkInvForAllTys tyvars (mkFunTys arg_tys res_ty) primOpOcc :: PrimOp -> OccName primOpOcc op = case primOpInfo op of diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 3a6dd0341e..1b5adf6bee 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -13,22 +13,19 @@ module TysPrim( mkPrimTyConName, -- For implicit parameters in TysWiredIn only mkTemplateTyVars, - alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, - alphaTy, betaTy, gammaTy, deltaTy, - openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, + alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + alphaTys, alphaTy, betaTy, gammaTy, deltaTy, + levity1TyVar, levity2TyVar, levity1Ty, levity2Ty, + openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, kKiVar, -- Kind constructors... - superKindTyCon, superKind, anyKindTyCon, liftedTypeKindTyCon, - openTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyCon, + tYPETyCon, unliftedTypeKindTyCon, unliftedTypeKind, - superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, - openTypeKindTyConName, unliftedTypeKindTyConName, - constraintKindTyConName, + tYPETyConName, unliftedTypeKindTyConName, -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, - mkArrowKind, mkArrowKinds, + tYPE, funTyCon, funTyConName, primTyCons, @@ -72,6 +69,7 @@ module TysPrim( eqPrimTyCon, -- ty1 ~# ty2 eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) + eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) -- * Any anyTy, anyTyCon, anyTypeOfKind, @@ -82,14 +80,17 @@ module TysPrim( #include "HsVersions.h" +import {-# SOURCE #-} TysWiredIn ( levityTy, unliftedDataConTy, liftedTypeKind ) + import Var ( TyVar, KindVar, mkTyVar ) import Name import TyCon -import TypeRep import SrcLoc import Unique import PrelNames import FastString +import TyCoRep -- doesn't need special access, but this is easier to avoid + -- import loops import Data.Char @@ -136,13 +137,10 @@ primTyCons , anyTyCon , eqPrimTyCon , eqReprPrimTyCon + , eqPhantPrimTyCon - , liftedTypeKindTyCon , unliftedTypeKindTyCon - , openTypeKindTyCon - , constraintKindTyCon - , superKindTyCon - , anyKindTyCon + , tYPETyCon #include "primop-vector-tycons.hs-incl" ] @@ -162,7 +160,7 @@ mkBuiltInPrimTc fs unique tycon BuiltInSyntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -178,6 +176,7 @@ voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPr proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon +eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon @@ -221,9 +220,6 @@ mkTemplateTyVars kinds = alphaTyVars :: [TyVar] alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind -betaTyVars :: [TyVar] -betaTyVars = tail alphaTyVars - alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar (alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars @@ -232,20 +228,25 @@ alphaTys = mkTyVarTys alphaTyVars alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys - -- openAlphaTyVar is prepared to be instantiated - -- to a lifted or unlifted type variable. It's used for the - -- result type for "error", so that we can have (error Int# "Help") -openAlphaTyVars :: [TyVar] +levity1TyVar, levity2TyVar :: TyVar +(levity1TyVar : levity2TyVar : _) + = drop 21 (mkTemplateTyVars (repeat levityTy)) -- selects 'v','w' + +levity1Ty, levity2Ty :: Type +levity1Ty = mkTyVarTy levity1TyVar +levity2Ty = mkTyVarTy levity2TyVar + openAlphaTyVar, openBetaTyVar :: TyVar -openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) - = mkTemplateTyVars $ repeat openTypeKind +[openAlphaTyVar,openBetaTyVar] + = mkTemplateTyVars [tYPE levity1Ty, tYPE levity2Ty] openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar kKiVar :: KindVar -kKiVar = (mkTemplateTyVars $ repeat superKind) !! 10 +kKiVar = (mkTemplateTyVars $ repeat liftedTypeKind) !! 10 + -- the 10 selects the 11th letter in the alphabet: 'k' {- ************************************************************************ @@ -261,7 +262,7 @@ funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon funTyCon :: TyCon funTyCon = mkFunTyCon funTyConName kind tc_rep_nm where - kind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind + kind = mkFunTys [liftedTypeKind, 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 (->) @@ -294,95 +295,74 @@ funTyCon = mkFunTyCon funTyConName kind tc_rep_nm * * ************************************************************************ -Note [SuperKind (BOX)] -~~~~~~~~~~~~~~~~~~~~~~ -Kinds are classified by "super-kinds". There is only one super-kind, namely BOX. +Note [TYPE] +~~~~~~~~~~~ +There are a few places where we wish to be able to deal interchangeably +with kind * and kind #. unsafeCoerce#, error, and (->) are some of these +places. The way we do this is to use levity polymorphism. + +We have (levityTyCon, liftedDataCon, unliftedDataCon) + + data Levity = Lifted | Unlifted + +and a magical constant (tYPETyCon) -Perhaps surprisingly we give BOX the kind BOX, thus BOX :: BOX -Reason: we want to have kind equalities, thus (without the kind applications) - keq :: * ~ * = Eq# <refl *> -Remember that - (~) :: forall (k:BOX). k -> k -> Constraint - (~#) :: forall (k:BOX). k -> k -> # - Eq# :: forall (k:BOX). forall (a:k) (b:k). (~#) k a b -> (~) k a b + TYPE :: Levity -> TYPE Lifted -So the full defn of keq is - keq :: (~) BOX * * = Eq# BOX * * <refl *> +We then have synonyms (liftedTypeKindTyCon, unliftedTypeKindTyCon) -So you can see it's convenient to have BOX:BOX + type Type = TYPE Lifted + type # = TYPE Unlifted + +So, for example, we get + + unsafeCoerce# :: forall (v1 :: Levity) (v2 :: Levity) + (a :: TYPE v1) (b :: TYPE v2). a -> b + +This replaces the old sub-kinding machinery. We call variables `a` and `b` +above "levity polymorphic". -} --- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's -superKindTyCon, anyKindTyCon, liftedTypeKindTyCon, - openTypeKindTyCon, unliftedTypeKindTyCon, - constraintKindTyCon - :: TyCon -superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, - openTypeKindTyConName, unliftedTypeKindTyConName, - constraintKindTyConName - :: Name - -mk_kind_tycon :: Name -- ^ Name of the kind constructor, e.g. @*@ - -> FastString -- ^ Name of the 'TyConRepName' function, - -- e.g. @tcLiftedKind :: TyCon@ - -> TyCon -- ^ The kind constructor -mk_kind_tycon tc_name rep_fs - = mkKindTyCon tc_name superKind (mkSpecialTyConRepName rep_fs tc_name) - -superKindTyCon = mk_kind_tycon superKindTyConName (fsLit "tcBOX") - -- See Note [SuperKind (BOX)] - -anyKindTyCon = mk_kind_tycon anyKindTyConName (fsLit "tcAnyK") -constraintKindTyCon = mk_kind_tycon constraintKindTyConName (fsLit "tcConstraint") -liftedTypeKindTyCon = mk_kind_tycon liftedTypeKindTyConName (fsLit "tcLiftedKind") -openTypeKindTyCon = mk_kind_tycon openTypeKindTyConName (fsLit "tcOpenKind") -unliftedTypeKindTyCon = mk_kind_tycon unliftedTypeKindTyConName (fsLit "tcUnliftedKind") +tYPETyCon, unliftedTypeKindTyCon :: TyCon +tYPETyConName, unliftedTypeKindTyConName :: Name + +tYPETyCon = mkKindTyCon tYPETyConName + (ForAllTy (Anon levityTy) liftedTypeKind) + [Nominal] + (mkSpecialTyConRepName (fsLit "tcTYPE") tYPETyConName) + + -- See Note [TYPE] + -- NB: unlifted is wired in because there is no way to parse it in + -- Haskell. That's the only reason for wiring it in. +unliftedTypeKindTyCon = mkSynonymTyCon unliftedTypeKindTyConName + liftedTypeKind + [] [] + (tYPE unliftedDataConTy) -------------------------- -- ... and now their names -- If you edit these, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.hs -superKindTyConName = mkPrimTyConName (fsLit "BOX") superKindTyConKey superKindTyCon -anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon -liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon -openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon -unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon +tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon +unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon + +unliftedTypeKind :: Kind +unliftedTypeKind = tYPE unliftedDataConTy mkPrimTyConName :: FastString -> Unique -> TyCon -> Name mkPrimTyConName = mkPrimTcName BuiltInSyntax -- All of the super kinds and kinds are defined in Prim, -- and use BuiltInSyntax, because they are never in scope in the source -constraintKindTyConName -- Unlike the others, Constraint does *not* use BuiltInSyntax, - -- and can be imported/exported like any other type constructor - = mkPrimTcName UserSyntax (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon - - mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name mkPrimTcName built_in_syntax occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax -kindTyConType :: TyCon -> Type -kindTyConType kind = TyConApp kind [] -- mkTyConApp isn't defined yet - --- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, superKind :: Kind - -superKind = kindTyConType superKindTyCon -anyKind = kindTyConType anyKindTyCon -- See Note [Any kinds] -liftedTypeKind = kindTyConType liftedTypeKindTyCon -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon -openTypeKind = kindTyConType openTypeKindTyCon -constraintKind = kindTyConType constraintKindTyCon - --- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ -mkArrowKind :: Kind -> Kind -> Kind -mkArrowKind k1 k2 = FunTy k1 k2 - --- | Iterated application of 'mkArrowKind' -mkArrowKinds :: [Kind] -> Kind -> Kind -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds +----------------------------- +-- | Given a Levity, applies TYPE to it. See Note [TYPE]. +tYPE :: Type -> Type +tYPE lev = TyConApp tYPETyCon [lev] {- ************************************************************************ @@ -397,7 +377,7 @@ pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon pcPrimTyCon name roles rep = mkPrimTyCon name kind roles rep where - kind = mkArrowKinds (map (const liftedTypeKind) roles) result_kind + kind = mkFunTys (map (const liftedTypeKind) roles) result_kind result_kind = unliftedTypeKind pcPrimTyCon0 :: Name -> PrimRep -> TyCon @@ -463,17 +443,16 @@ doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep * * ************************************************************************ -Note [The ~# TyCon) +Note [The ~# TyCon] ~~~~~~~~~~~~~~~~~~~~ There is a perfectly ordinary type constructor ~# that represents the type of coercions (which, remember, are values). For example - Refl Int :: ~# * Int Int + Refl Int :: ~# * * Int Int It is a kind-polymorphic type constructor like Any: - Refl Maybe :: ~# (* -> *) Maybe Maybe + Refl Maybe :: ~# (* -> *) (* -> *) Maybe Maybe -(~) only appears saturated. So we check that in CoreLint (and, in an -assertion, in Kind.typeKind). +(~) only appears saturated. So we check that in CoreLint. Note [The State# TyCon] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -508,27 +487,49 @@ mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] proxyPrimTyCon :: TyCon proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName kind [Nominal,Nominal] VoidRep - where kind = ForAllTy kv $ mkArrowKind k unliftedTypeKind + where kind = ForAllTy (Named kv Invisible) $ + mkFunTy k unliftedTypeKind kv = kKiVar k = mkTyVarTy kv eqPrimTyCon :: TyCon -- The representation type for equality predicates -- See Note [The ~# TyCon] -eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind [Nominal, Nominal, Nominal] VoidRep - where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind - kv = kKiVar - k = mkTyVarTy kv +eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind roles VoidRep + where kind = ForAllTy (Named kv1 Invisible) $ + ForAllTy (Named kv2 Invisible) $ + mkFunTys [k1, k2] unliftedTypeKind + [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] + k1 = mkTyVarTy kv1 + k2 = mkTyVarTy kv2 + roles = [Nominal, Nominal, Nominal, Nominal] -- like eqPrimTyCon, but the type for *Representational* coercions -- this should only ever appear as the type of a covar. Its role is -- interpreted in coercionRole eqReprPrimTyCon :: TyCon eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind - -- the roles really should be irrelevant! - [Nominal, Representational, Representational] VoidRep - where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind - kv = kKiVar - k = mkTyVarTy kv + roles VoidRep + where kind = ForAllTy (Named kv1 Invisible) $ + ForAllTy (Named kv2 Invisible) $ + mkFunTys [k1, k2] unliftedTypeKind + [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] + k1 = mkTyVarTy kv1 + k2 = mkTyVarTy kv2 + roles = [Nominal, Nominal, Representational, Representational] + +-- like eqPrimTyCon, but the type for *Phantom* coercions. +-- This is only used to make higher-order equalities. Nothing +-- should ever actually have this type! +eqPhantPrimTyCon :: TyCon +eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName kind + [Nominal, Nominal, Phantom, Phantom] + VoidRep + where kind = ForAllTy (Named kv1 Invisible) $ + ForAllTy (Named kv2 Invisible) $ + mkFunTys [k1, k2] unliftedTypeKind + [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] + k1 = mkTyVarTy kv1 + k2 = mkTyVarTy kv2 {- RealWorld is deeply magical. It is *primitive*, but it is not @@ -740,24 +741,6 @@ The type constructor Any of kind forall k. k has these properties: For example length Any [] See Note [Strangely-kinded void TyCons] -Note [Any kinds] -~~~~~~~~~~~~~~~~ -The type constructor AnyK (of sort BOX) is used internally only to zonk kind -variables with no constraints on them. It appears in similar circumstances to -Any, but at the kind level. For example: - - type family Length (l :: [k]) :: Nat - type instance Length [] = Zero - - f :: Proxy (Length []) -> Int - f = .... - -Length is kind-polymorphic. So what is the elaborated type of f? - f :: Proxy (Length AnyK ([] AnyK)) -> Int - -Just like (length []) at the term level, which elaborates to - length (Any *) ([] (Any *)) - Note [Strangely-kinded void TyCons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Trac #959 for more examples @@ -791,7 +774,7 @@ anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing Nothing NotInjective where - kind = ForAllTy kKiVar (mkTyVarTy kKiVar) + kind = ForAllTy (Named kKiVar Invisible) (mkTyVarTy kKiVar) anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = TyConApp anyTyCon [kind] diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 067700f120..1d0feabb4a 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -16,13 +16,13 @@ module TysWiredIn ( boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, trueDataCon, trueDataConId, true_RDR, falseDataCon, falseDataConId, false_RDR, - promotedBoolTyCon, promotedFalseDataCon, promotedTrueDataCon, + promotedFalseDataCon, promotedTrueDataCon, -- * Ordering + orderingTyCon, ltDataCon, ltDataConId, eqDataCon, eqDataConId, gtDataCon, gtDataConId, - promotedOrderingTyCon, promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, -- * Char @@ -50,7 +50,7 @@ module TysWiredIn ( nilDataCon, nilDataConName, nilDataConKey, consDataCon_RDR, consDataCon, consDataConName, - mkListTy, mkPromotedListTy, + mkListTy, -- * Maybe maybeTyCon, maybeTyConName, @@ -59,16 +59,17 @@ module TysWiredIn ( -- * Tuples mkTupleTy, mkBoxedTupleTy, tupleTyCon, tupleDataCon, tupleTyConName, - promotedTupleTyCon, promotedTupleDataCon, + promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, - unboxedSingletonTyCon, unboxedSingletonDataCon, - unboxedPairTyCon, unboxedPairDataCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName, -- * Kinds typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, + isLiftedTypeKindTyConName, liftedTypeKind, constraintKind, + starKindTyConName, unicodeStarKindTyConName, + liftedTypeKindTyCon, constraintKindTyCon, -- * Parallel arrays mkPArrTy, @@ -76,7 +77,7 @@ module TysWiredIn ( parrTyCon_RDR, parrTyConName, -- * Equality predicates - eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon, + heqTyCon, heqClass, heqDataCon, coercibleTyCon, coercibleDataCon, coercibleClass, -- * Implicit Parameters @@ -84,13 +85,21 @@ module TysWiredIn ( callStackTyCon, - mkWiredInTyConName -- This is used in TcTypeNats to define the - -- built-in functions for evaluation. + mkWiredInTyConName, -- This is used in TcTypeNats to define the + -- built-in functions for evaluation. + + mkWiredInIdName, -- used in MkId + + -- * Levity + levityTy, levityTyCon, liftedDataCon, unliftedDataCon, + liftedPromDataCon, unliftedPromDataCon, + liftedDataConTy, unliftedDataConTy, + liftedDataConName, unliftedDataConName ) where #include "HsVersions.h" -import {-# SOURCE #-} MkId( mkDataConWorkId ) +import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) -- friends: import PrelNames @@ -102,13 +111,11 @@ import Coercion import Id import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import Module ( Module ) -import Type ( mkTyConApp ) +import Type import DataCon import {-# SOURCE #-} ConLike -import Var import TyCon import Class ( Class, mkClass ) -import TypeRep import RdrName import Name import NameSet ( NameSet, mkNameSet, elemNameSet ) @@ -169,10 +176,15 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , listTyCon , maybeTyCon , parrTyCon - , eqTyCon + , heqTyCon , coercibleTyCon , typeNatKindCon , typeSymbolKindCon + , levityTyCon + , constraintKindTyCon + , liftedTypeKindTyCon + , starKindTyCon + , unicodeStarKindTyCon , ipTyCon ] @@ -195,15 +207,22 @@ mkWiredInCoAxiomName built_in modu fs unique ax (ACoAxiom ax) -- Relevant CoAxiom built_in --- See Note [Kind-changing of (~) and Coercible] -eqTyConName, eqBoxDataConName :: Name -eqTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon -eqBoxDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqBoxDataConKey eqBoxDataCon +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax -- See Note [Kind-changing of (~) and Coercible] -coercibleTyConName, coercibleDataConName :: Name +-- in libraries/ghc-prim/GHC/Types.hs +heqTyConName, heqDataConName, heqSCSelIdName :: Name +heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon +heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") heqDataConKey heqDataCon +heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "HEq_sc") heqSCSelIdKey heqSCSelId + +-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs +coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon +coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "Coercible_sc") coercibleSCSelIdKey coercibleSCSelId charTyConName, charDataConName, intTyConName, intDataConName :: Name charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon @@ -246,6 +265,20 @@ typeNatKindConName, typeSymbolKindConName :: Name typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon +constraintKindTyConName :: Name +constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon + +liftedTypeKindTyConName, starKindTyConName, unicodeStarKindTyConName + :: Name +liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon +starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon +unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon + +levityTyConName, liftedDataConName, unliftedDataConName :: Name +levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon +liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon +unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon + parrTyConName, parrDataConName :: Name parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon @@ -253,7 +286,7 @@ parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, - intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName true_RDR = nameRdrName trueDataConName @@ -263,7 +296,6 @@ intDataCon_RDR = nameRdrName intDataConName listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName parrTyCon_RDR = nameRdrName parrTyConName -eqTyCon_RDR = nameRdrName eqTyConName {- ************************************************************************ @@ -274,28 +306,34 @@ eqTyCon_RDR = nameRdrName eqTyConName -} pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon --- Not an enumeration, not promotable -pcNonRecDataTyCon = pcTyCon False NonRecursive False +-- Not an enumeration +pcNonRecDataTyCon = pcTyCon False NonRecursive -- This function assumes that the types it creates have all parameters at --- Representational role! -pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon -pcTyCon is_enum is_rec is_prom name cType tyvars cons - = buildAlgTyCon name - tyvars - (map (const Representational) tyvars) - cType - [] -- No stupid theta - (DataTyCon cons is_enum) - is_rec - is_prom - False -- Not in GADT syntax - (VanillaAlgTyCon (mkPrelTyConRepName name)) +-- Representational role, and that there is no kind polymorphism. +pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon is_enum is_rec name cType tyvars cons + = mkAlgTyCon name + (mkFunTys (map tyVarKind tyvars) liftedTypeKind) + tyvars + (map (const Representational) tyvars) + cType + [] -- No stupid theta + (DataTyCon cons is_enum) + (VanillaAlgTyCon (mkPrelTyConRepName name)) + is_rec + False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon = pcDataConWithFixity False - -pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon n univs = pcDataConWithFixity False n univs [] -- no ex_tvs + +pcDataConWithFixity :: Bool -- ^ declared infix? + -> Name -- ^ datacon name + -> [TyVar] -- ^ univ tyvars + -> [TyVar] -- ^ ex tyvars + -> [Type] -- ^ args + -> TyCon + -> DataCon pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n)) -- The Name's unique is the first of two free uniques; -- the first is used for the datacon itself, @@ -304,18 +342,19 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique -- To support this the mkPreludeDataConUnique function "allocates" -- one DataCon unique per pair of Ints. -pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [TyVar] + -> [Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. -pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon +pcDataConWithFixity' declared_infix dc_name wrk_key tyvars ex_tyvars arg_tys tycon = data_con where data_con = mkDataCon dc_name declared_infix prom_info (map (const no_bang) arg_tys) [] -- No labelled fields tyvars - [] -- No existential type variables + ex_tyvars [] -- No equality spec [] -- No theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) @@ -333,10 +372,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon wrk_name = mkWiredInName modu wrk_occ wrk_key (AnId (dataConWorkId data_con)) UserSyntax - prom_info | Promoted {} <- promotableTyCon_maybe tycon -- Knot-tied - = Promoted (mkPrelTyConRepName dc_name) - | otherwise - = NotPromoted + prom_info = mkPrelTyConRepName dc_name {- ************************************************************************ @@ -349,12 +385,21 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon typeNatKindCon, typeSymbolKindCon :: TyCon -- data Nat -- data Symbol -typeNatKindCon = pcTyCon False NonRecursive True typeNatKindConName Nothing [] [] -typeSymbolKindCon = pcTyCon False NonRecursive True typeSymbolKindConName Nothing [] [] +typeNatKindCon = pcTyCon False NonRecursive typeNatKindConName Nothing [] [] +typeSymbolKindCon = pcTyCon False NonRecursive typeSymbolKindConName Nothing [] [] typeNatKind, typeSymbolKind :: Kind -typeNatKind = TyConApp (promoteTyCon typeNatKindCon) [] -typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) [] +typeNatKind = mkTyConTy typeNatKindCon +typeSymbolKind = mkTyConTy typeSymbolKindCon + +constraintKindTyCon :: TyCon +constraintKindTyCon = pcTyCon False NonRecursive constraintKindTyConName + Nothing [] [] + +liftedTypeKind, constraintKind :: Kind +liftedTypeKind = tYPE liftedDataConTy +constraintKind = mkTyConApp constraintKindTyCon [] + {- ************************************************************************ @@ -485,9 +530,6 @@ tupleTyConName ConstraintTuple a = cTupleTyConName a tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) -promotedTupleTyCon :: Boxity -> Arity -> TyCon -promotedTupleTyCon boxity i = promoteTyCon (tupleTyCon boxity i) - promotedTupleDataCon :: Boxity -> Arity -> TyCon promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) @@ -503,40 +545,43 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con - tup_sort - prom_tc flavour - - flavour = case boxity of - Boxed -> VanillaAlgTyCon (mkPrelTyConRepName tc_name) - Unboxed -> UnboxedAlgTyCon - - tup_sort = case boxity of - Boxed -> BoxedTuple - Unboxed -> UnboxedTuple - - prom_tc = case boxity of - Boxed -> Promoted (mkPromotedTyCon tycon (promoteKind tc_kind)) - Unboxed -> NotPromoted - - modu = case boxity of - Boxed -> gHC_TUPLE - Unboxed -> gHC_PRIM + tycon = mkTupleTyCon tc_name tc_kind tc_arity tyvars tuple_con + tup_sort flavour + + (tup_sort, modu, tc_kind, tc_arity, tyvars, tyvar_tys, flavour) + = case boxity of + Boxed -> + let boxed_tyvars = take arity alphaTyVars in + ( BoxedTuple + , gHC_TUPLE + , mkFunTys (nOfThem arity liftedTypeKind) liftedTypeKind + , arity + , boxed_tyvars + , mkTyVarTys boxed_tyvars + , VanillaAlgTyCon (mkPrelTyConRepName tc_name) + ) + -- See Note [Unboxed tuple levity vars] in TyCon + Unboxed -> + let all_tvs = mkTemplateTyVars (replicate arity levityTy ++ + map (tYPE . mkTyVarTy) (take arity all_tvs)) + -- NB: This must be one call to mkTemplateTyVars, to make + -- sure that all the uniques are different + (lev_tvs, open_tvs) = splitAt arity all_tvs + in + ( UnboxedTuple + , gHC_PRIM + , mkInvForAllTys lev_tvs $ + mkFunTys (map tyVarKind open_tvs) $ + unliftedTypeKind + , arity * 2 + , all_tvs + , mkTyVarTys open_tvs + , UnboxedAlgTyCon + ) tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax - tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind - - res_kind = case boxity of - Boxed -> liftedTypeKind - Unboxed -> unliftedTypeKind - - tyvars = take arity $ case boxity of - Boxed -> alphaTyVars - Unboxed -> openAlphaTyVars - tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon - tyvar_tys = mkTyVarTys tyvars dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq (AConLike (RealDataCon tuple_con)) BuiltInSyntax tc_uniq = mkTupleTyConUnique boxity arity @@ -563,18 +608,6 @@ unboxedUnitTyCon = tupleTyCon Unboxed 0 unboxedUnitDataCon :: DataCon unboxedUnitDataCon = tupleDataCon Unboxed 0 -unboxedSingletonTyCon :: TyCon -unboxedSingletonTyCon = tupleTyCon Unboxed 1 - -unboxedSingletonDataCon :: DataCon -unboxedSingletonDataCon = tupleDataCon Unboxed 1 - -unboxedPairTyCon :: TyCon -unboxedPairTyCon = tupleTyCon Unboxed 2 - -unboxedPairDataCon :: DataCon -unboxedPairDataCon = tupleDataCon Unboxed 2 - {- ************************************************************************ * * @@ -583,6 +616,90 @@ unboxedPairDataCon = tupleDataCon Unboxed 2 ************************************************************************ -} +heqTyCon, coercibleTyCon :: TyCon +heqClass, coercibleClass :: Class +heqDataCon, coercibleDataCon :: DataCon +heqSCSelId, coercibleSCSelId :: Id + +(heqTyCon, heqClass, heqDataCon, heqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon heqTyConName kind tvs roles + rhs klass NonRecursive + (mkSpecialTyConRepName (fsLit "tcHEq") heqTyConName) + klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon + datacon = pcDataCon heqDataConName tvs [sc_pred] tycon + + kind = mkInvForAllTys [kv1, kv2] $ mkFunTys [k1, k2] constraintKind + kv1:kv2:_ = drop 9 alphaTyVars -- gets "j" and "k" + k1 = mkTyVarTy kv1 + k2 = mkTyVarTy kv2 + [av,bv] = mkTemplateTyVars [k1, k2] + tvs = [kv1, kv2, av, bv] + roles = [Nominal, Nominal, Nominal, Nominal] + rhs = DataTyCon { data_cons = [datacon], is_enum = False } + + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) + sc_sel_id = mkDictSelId heqSCSelIdName klass + +(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon coercibleTyConName kind tvs roles + rhs klass NonRecursive + (mkPrelTyConRepName coercibleTyConName) + klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon + datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon + + kind = mkInvForAllTys [kKiVar] $ mkFunTys [k, k] constraintKind + k = mkTyVarTy kKiVar + [av,bv] = mkTemplateTyVars [k, k] + tvs = [kKiVar, av, bv] + roles = [Nominal, Representational, Representational] + rhs = DataTyCon { data_cons = [datacon], is_enum = False } + + sc_pred = mkTyConApp eqReprPrimTyCon [k, k, mkTyVarTy av, mkTyVarTy bv] + sc_sel_id = mkDictSelId coercibleSCSelIdName klass + +-- For information about the usage of the following type, see Note [TYPE] +-- in module Kind +levityTy :: Type +levityTy = mkTyConTy levityTyCon + +levityTyCon :: TyCon +levityTyCon = pcTyCon True NonRecursive levityTyConName + Nothing [] [liftedDataCon, unliftedDataCon] + +liftedDataCon, unliftedDataCon :: DataCon +liftedDataCon = pcDataCon liftedDataConName [] [] levityTyCon +unliftedDataCon = pcDataCon unliftedDataConName [] [] levityTyCon + +liftedPromDataCon, unliftedPromDataCon :: TyCon +liftedPromDataCon = promoteDataCon liftedDataCon +unliftedPromDataCon = promoteDataCon unliftedDataCon + +liftedDataConTy, unliftedDataConTy :: Type +liftedDataConTy = mkTyConTy liftedPromDataCon +unliftedDataConTy = mkTyConTy unliftedPromDataCon + +liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon + + -- See Note [TYPE] in TysPrim +liftedTypeKindTyCon = mkSynonymTyCon liftedTypeKindTyConName + liftedTypeKind + [] [] + (tYPE liftedDataConTy) + +starKindTyCon = mkSynonymTyCon starKindTyConName + liftedTypeKind + [] [] + (tYPE liftedDataConTy) + +unicodeStarKindTyCon = mkSynonymTyCon unicodeStarKindTyConName + liftedTypeKind + [] [] + (tYPE liftedDataConTy) + charTy :: Type charTy = mkTyConTy charTyCon @@ -701,7 +818,7 @@ boolTy :: Type boolTy = mkTyConTy boolTyCon boolTyCon :: TyCon -boolTyCon = pcTyCon True NonRecursive True boolTyConName +boolTyCon = pcTyCon True NonRecursive boolTyConName (Just (CType "" Nothing ("HsBool", fsLit "HsBool"))) [] [falseDataCon, trueDataCon] @@ -714,7 +831,7 @@ falseDataConId = dataConWorkId falseDataCon trueDataConId = dataConWorkId trueDataCon orderingTyCon :: TyCon -orderingTyCon = pcTyCon True NonRecursive True orderingTyConName Nothing +orderingTyCon = pcTyCon True NonRecursive orderingTyConName Nothing [] [ltDataCon, eqDataCon, gtDataCon] ltDataCon, eqDataCon, gtDataCon :: DataCon @@ -746,22 +863,16 @@ listTyCon :: TyCon listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational] Nothing [] (DataTyCon [nilDataCon, consDataCon] False ) - Recursive True False + Recursive False (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcList") listTyConName)) -mkPromotedListTy :: Type -> Type -mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] - -promotedListTyCon :: TyCon -promotedListTyCon = promoteTyCon listTyCon - nilDataCon :: DataCon nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon consDataCon :: DataCon consDataCon = pcDataConWithFixity True {- Declared infix -} consDataConName - alpha_tyvar [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon + alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) @@ -769,7 +880,7 @@ consDataCon = pcDataConWithFixity True {- Declared infix -} -- Wired-in type Maybe maybeTyCon :: TyCon -maybeTyCon = pcTyCon True NonRecursive True maybeTyConName Nothing alpha_tyvar +maybeTyCon = pcTyCon False NonRecursive maybeTyConName Nothing alpha_tyvar [nothingDataCon, justDataCon] nothingDataCon :: DataCon @@ -826,10 +937,14 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} -} +-- | Make a tuple type. The list of types should /not/ include any +-- levity specifications. mkTupleTy :: Boxity -> [Type] -> Type -- Special case for *boxed* 1-tuples, which are represented by the type itself -mkTupleTy Boxed [ty] = ty -mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys +mkTupleTy Boxed [ty] = ty +mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys +mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) + (map (getLevity "mkTupleTy") tys ++ tys) -- | Build the type of a small tuple that holds the specified type of thing mkBoxedTupleTy :: [Type] -> Type @@ -913,79 +1028,20 @@ isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) -- Promoted Booleans -promotedBoolTyCon, promotedFalseDataCon, promotedTrueDataCon :: TyCon -promotedBoolTyCon = promoteTyCon boolTyCon +promotedFalseDataCon, promotedTrueDataCon :: TyCon promotedTrueDataCon = promoteDataCon trueDataCon promotedFalseDataCon = promoteDataCon falseDataCon -- Promoted Ordering -promotedOrderingTyCon - , promotedLTDataCon +promotedLTDataCon , promotedEQDataCon , promotedGTDataCon :: TyCon -promotedOrderingTyCon = promoteTyCon orderingTyCon promotedLTDataCon = promoteDataCon ltDataCon promotedEQDataCon = promoteDataCon eqDataCon promotedGTDataCon = promoteDataCon gtDataCon -{- ********************************************************************* -* * - Type equalities -* * -********************************************************************* -} - -eqTyCon :: TyCon -eqTyCon = mkAlgTyCon eqTyConName - (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) - [kv, a, b] - [Nominal, Nominal, Nominal] - Nothing - [] -- No stupid theta - (DataTyCon [eqBoxDataCon] False) - (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcEq") eqTyConName)) - NonRecursive - False - NotPromoted - where - kv = kKiVar - k = mkTyVarTy kv - [a,b] = mkTemplateTyVars [k,k] - -eqBoxDataCon :: DataCon -eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon - where - kv = kKiVar - k = mkTyVarTy kv - [a,b] = mkTemplateTyVars [k,k] - args = [kv, a, b] - - -coercibleTyCon :: TyCon -coercibleTyCon = mkClassTyCon coercibleTyConName kind tvs - [Nominal, Representational, Representational] - rhs coercibleClass NonRecursive - (mkPrelTyConRepName coercibleTyConName) - where - kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) - kv = kKiVar - k = mkTyVarTy kv - [a,b] = mkTemplateTyVars [k,k] - tvs = [kv, a, b] - rhs = DataTyCon [coercibleDataCon] False - -coercibleDataCon :: DataCon -coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon (map mkTyVarTy args)] coercibleTyCon - where - kv = kKiVar - k = mkTyVarTy kv - [a,b] = mkTemplateTyVars [k,k] - args = [kv, a, b] - -coercibleClass :: Class -coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] (mkAnd []) coercibleTyCon - {- Note [The Implicit Parameter class] @@ -1012,7 +1068,7 @@ ipTyCon :: TyCon ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive (mkPrelTyConRepName ipTyConName) where - kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind + kind = mkFunTys [typeSymbolKind, liftedTypeKind] constraintKind [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind] rhs = NewTyCon ipDataCon (mkTyVarTy a) ([], mkTyVarTy a) ipCoAxiom diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index a001338087..f7ae6354b3 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -1,9 +1,13 @@ module TysWiredIn where -import {-# SOURCE #-} TyCon (TyCon) -import {-# SOURCE #-} TypeRep (Type) +import TyCon +import {-# SOURCE #-} TyCoRep (Type, Kind) -eqTyCon, listTyCon, coercibleTyCon :: TyCon +listTyCon :: TyCon typeNatKind, typeSymbolKind :: Type mkBoxedTupleTy :: [Type] -> Type + +levityTy, unliftedDataConTy :: Type + +liftedTypeKind :: Kind diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 7466381cd5..a398e333b2 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -4,7 +4,7 @@ \section[RnEnv]{Environment manipulation for the renamer monad} -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MultiWayIf #-} module RnEnv ( newTopSrcBinder, @@ -37,7 +37,8 @@ module RnEnv ( extendTyVarEnvFVRn, checkDupRdrNames, checkShadowedRdrNames, - checkDupNames, checkDupAndShadowedNames, checkTupSize, + checkDupNames, checkDupAndShadowedNames, dupNamesErr, + checkTupSize, addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, @@ -57,6 +58,7 @@ import HscTypes import TcEnv import TcRnMonad import RdrHsSyn ( setRdrNameSpace ) +import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName ) import Name import NameSet import NameEnv @@ -710,10 +712,17 @@ lookupOccRn rdr_name lookupKindOccRn :: RdrName -> RnM Name -- Looking up a name occurring in a kind lookupKindOccRn rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> reportUnboundName rdr_name } + = do { typeintype <- xoptM Opt_TypeInType + ; if | typeintype -> lookupTypeOccRn rdr_name + | is_star -> return starKindTyConName + | is_uni_star -> return unicodeStarKindTyConName + | otherwise -> lookupOccRn rdr_name } + where + -- With -XNoTypeInType, treat any usage of * in kinds as in scope + -- this is a dirty hack, but then again so was the old * kind. + fs_name = occNameFS $ rdrNameOcc rdr_name + is_star = fs_name == fsLit "*" + is_uni_star = fs_name == fsLit "★" -- lookupPromotedOccRn looks up an optionally promoted RdrName. lookupTypeOccRn :: RdrName -> RnM Name diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index cfe5fc5c27..7d60d6e32a 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -627,7 +627,7 @@ getLocalNonValBinders fixity_env where (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty cdflds = case tau of - L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds + L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _) -> flds _ -> [] find_con_flds _ = [] diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 77f08f4049..88496d496b 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -49,7 +49,7 @@ import DynFlags import PrelNames import TyCon ( tyConName ) import ConLike -import TypeRep ( TyThing(..) ) +import Type ( TyThing(..) ) import Name import NameSet import RdrName @@ -614,7 +614,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldCon {} -> arg_in_scope lbl _other -> True ] - ; addUsedGREs (map thirdOf3 dot_dot_gres) + ; addUsedGREs (map thdOf3 dot_dot_gres) ; return [ L loc (HsRecField { hsRecFieldLbl = L loc (FieldOcc arg_rdr sel) , hsRecFieldArg = L loc (mk_arg loc arg_rdr) diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index b284ec8d88..e6b735211f 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -612,11 +612,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_datafam_insts = adts }) = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' - ; let cls = case splitLHsClassTy_maybe head_ty' of + ; let cls = case hsTyGetAppHead_maybe head_ty' of Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>")) Just (L _ cls, _) -> cls -- rnLHsInstType has added an error message - -- if splitLHsClassTy_maybe fails + -- if hsTyGetAppHead_maybe fails -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -667,36 +667,32 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload [] -> pprPanic "rnFamInstDecl" (ppr tycon) (L loc _ : []) -> loc (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) - (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats + ; tv_rdr_names <- extractHsTysRdrTyVars pats - ; rdr_env <- getLocalRdrEnv - ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names - ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names + ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $ + freeKiTyVarsAllVars tv_rdr_names -- All the free vars of the family patterns -- with a sensible binding location ; ((pats', payload'), fvs) - <- bindLocalNamesFV kv_names $ - bindLocalNamesFV tv_names $ - do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats + <- bindLocalNamesFV var_names $ + do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats ; (payload', rhs_fvs) <- rnPayload doc payload -- See Note [Renaming associated types] - ; let lhs_names = mkNameSet kv_names `unionNameSet` mkNameSet tv_names - bad_tvs = case mb_cls of + ; let bad_tvs = case mb_cls of Nothing -> [] Just (_,cls_tkvs) -> filter is_bad cls_tkvs + var_name_set = mkNameSet var_names is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs - && not (cls_tkv `elemNameSet` lhs_names) + && not (cls_tkv `elemNameSet` var_name_set) ; unless (null bad_tvs) (badAssocRhs bad_tvs) ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) } - ; let all_fvs = fvs `addOneFV` unLoc tycon' ; return (tycon', - HsIB { hsib_body = pats' - , hsib_kvs = kv_names, hsib_tvs = tv_names }, + HsIB { hsib_body = pats', hsib_vars = var_names }, payload', all_fvs) } -- type instance => use, hence addOneFV @@ -1133,8 +1129,8 @@ rnTyClDecl (FamDecl { tcdFam = decl }) rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = fst (extractHsTyRdrTyVars rhs) - doc = TySynCtx tycon + ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs + ; let doc = TySynCtx tycon ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs) ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' -> @@ -1147,8 +1143,8 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) -- both top level and (for an associated type) in an instance decl rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn }) = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = extractDataDefnKindVars defn - doc = TyDataCtx tycon + ; kvs <- extractDataDefnKindVars defn + ; let doc = TyDataCtx tycon ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs) ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' -> do { (defn', fvs) <- rnDataDefn doc defn @@ -1201,7 +1197,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. ; (mbinds', sigs', meth_fvs) - <- rnMethodBinds True cls' (hsLKiTyVarNames tyvars') mbinds sigs + <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope @@ -1331,12 +1327,15 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars , fdInfo = info, fdResultSig = res_sig , fdInjectivityAnn = injectivity }) = do { tycon' <- lookupLocatedTopBndrRn tycon + ; kvs <- extractRdrKindSigVars res_sig ; ((tyvars', res_sig', injectivity'), fv1) <- - bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' -> - do { (res_sig', fv_kind) <- wrapLocFstM (rnFamResultSig doc) res_sig + bindHsQTyVars doc mb_cls kvs tyvars $ + \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) -> + do { let rn_sig = rnFamResultSig doc rn_kvs + ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') injectivity - ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } ; (info', fv2) <- rn_info info ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' , fdInfo = info', fdResultSig = res_sig' @@ -1344,7 +1343,6 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars , fv1 `plusFV` fv2) } where doc = TyFamilyCtx tycon - kvs = extractRdrKindSigVars res_sig ---------------------- rn_info (ClosedTypeFamily (Just eqns)) @@ -1356,29 +1354,24 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) rn_info DataFamily = return (DataFamily, emptyFVs) -rnFamResultSig :: HsDocContext -> FamilyResultSig RdrName +rnFamResultSig :: HsDocContext + -> [Name] -- kind variables already in scope + -> FamilyResultSig RdrName -> RnM (FamilyResultSig Name, FreeVars) -rnFamResultSig _ NoSig +rnFamResultSig _ _ NoSig = return (NoSig, emptyFVs) -rnFamResultSig doc (KindSig kind) +rnFamResultSig doc _ (KindSig kind) = do { (rndKind, ftvs) <- rnLHsKind doc kind ; return (KindSig rndKind, ftvs) } -rnFamResultSig doc (TyVarSig tvbndr) +rnFamResultSig doc kv_names (TyVarSig tvbndr) = do { -- `TyVarSig` tells us that user named the result of a type family by -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to -- be sure that the supplied result name is not identical to an - -- already in-scope type variables: - -- - -- (a) one of already declared type family arguments. Example of - -- disallowed declaration: - -- type family F a = a + -- already in-scope type variable from an enclosing class. -- - -- (b) already in-scope type variable. This second case might happen - -- for associated types, where type class head bounds some type - -- variables. Example of disallowed declaration: + -- Example of disallowed declaration: -- class C a b where -- type F b = a | a -> b - -- Both are caught by the "in-scope" check that comes next rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ @@ -1388,8 +1381,13 @@ rnFamResultSig doc (TyVarSig tvbndr) ] $$ text "shadows an already bound type variable") - ; (tvbndr', fvs) <- rnLHsTyVarBndr doc Nothing rdr_env tvbndr - ; return (TyVarSig tvbndr', fvs) } + ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for + -- scoping checks that are irrelevant here + (mkNameSet kv_names) emptyNameSet + -- use of emptyNameSet here avoids + -- redundant duplicate errors + tvbndr $ \ _ tvbndr' -> + return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) } -- Note [Renaming injectivity annotation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1442,7 +1440,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) ; injTo' <- mapM rnLTyVar injTo ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } - ; let tvNames = Set.fromList $ hsLKiTyVarNames tvBndrs + ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv -- See Note [Renaming injectivity annotation] lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) @@ -1593,7 +1591,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs ; new_name <- lookupLocatedTopBndrRn name ; let doc = ConDeclCtx [new_name] ; mb_doc' <- rnMbLHsDoc mb_doc - ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) + ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details) ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do { (new_context, fvs1) <- case mcxt of @@ -1607,7 +1605,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs , text "qtvs:" <+> ppr qtvs , text "qtvs':" <+> ppr qtvs' ]) ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - ; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs + ; warnUnusedForAlls (inHsDocContext doc) (hsQTvExplicit new_tyvars) all_fvs ; let new_tyvars' = case qtvs of Nothing -> Nothing Just _ -> Just new_tyvars @@ -1619,14 +1617,14 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs cxt = maybe [] unLoc mcxt get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) - get_con_qtvs :: Maybe (LHsQTyVars RdrName) -> [LHsType RdrName] - -> ([RdrName], LHsQTyVars RdrName) - get_con_qtvs Nothing _arg_tys - = ([], mkHsQTvs []) - get_con_qtvs (Just qtvs) arg_tys - = (free_kvs, qtvs) - where - (free_kvs, _) = get_rdr_tvs arg_tys + get_con_qtvs :: [LHsType RdrName] + -> RnM ([Located RdrName], LHsQTyVars RdrName) + get_con_qtvs arg_tys + | Just tvs <- qtvs -- data T = forall a. MkT (a -> a) + = do { free_vars <- get_rdr_tvs arg_tys + ; return (freeKiTyVarsKindVars free_vars, tvs) } + | otherwise -- data T = MkT (a -> a) + = return ([], mkHsQTvs []) rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty , con_doc = mb_doc }) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index b716ee0721..fef7b67000 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -4,8 +4,8 @@ \section[RnSource]{Main pass of renamer} -} -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module RnTypes ( -- Type related stuff @@ -16,17 +16,18 @@ module RnTypes ( rnLHsInstType, newTyVarNameRn, collectAnonWildCards, rnConDeclFields, - rnLTyVar, rnLHsTyVarBndr, + rnLTyVar, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, checkPrecMatch, checkSectionPrec, -- Binding related stuff - warnUnusedForAlls, - bindSigTyVarsFV, bindHsQTyVars, + warnUnusedForAlls, bindLHsTyVarBndr, + bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractRdrKindSigVars, extractDataDefnKindVars + extractRdrKindSigVars, extractDataDefnKindVars, + freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars ) where import {-# SOURCE #-} RnSplice( rnSpliceType ) @@ -37,8 +38,9 @@ import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad import RdrName -import PrelNames ( negateName, dot_tv_RDR, forall_tv_RDR ) +import PrelNames import TysPrim ( funTyConName ) +import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName ) import Name import SrcLoc import NameSet @@ -50,7 +52,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity, import Outputable import FastString import Maybes -import Data.List ( nub, nubBy ) +import Data.List ( nubBy ) import Control.Monad ( unless, when ) #if __GLASGOW_HASKELL__ < 709 @@ -98,10 +100,9 @@ rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs -- rn_hs_sig_wc_type is used for source-language type signatures rn_hs_sig_wc_type no_implicit_if_forall ctxt (HsIB { hsib_body = wc_ty }) thing_inside - = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ kvs tvs -> + = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ vars -> rn_hs_wc_type ctxt wc_ty $ \ wc_ty' -> - thing_inside (HsIB { hsib_kvs = kvs - , hsib_tvs = tvs + thing_inside (HsIB { hsib_vars = vars , hsib_body = wc_ty' }) rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars) @@ -133,7 +134,7 @@ rnWcSigTy :: HsDocContext -> LHsType RdrName -- on a qualified type, and return info on any extra-constraints -- wildcard. Some code duplication, but no big deal. rnWcSigTy ctxt (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau })) - = bindLHsTyVarBndrs ctxt Nothing tvs $ \ tvs' -> + = bindLHsTyVarBndrs ctxt Nothing [] tvs $ \ _ tvs' -> do { (hs_tau', fvs) <- rnWcSigTy ctxt hs_tau ; warnUnusedForAlls (inTypeDoc hs_ty) tvs' fvs ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' } @@ -190,10 +191,9 @@ rnHsSigType :: HsDocContext -> LHsSigType RdrName -- Used for source-language type signatures -- that cannot have wildcards rnHsSigType ctx (HsIB { hsib_body = hs_ty }) - = rnImplicitBndrs True hs_ty $ \ kvs tvs -> + = rnImplicitBndrs True hs_ty $ \ vars -> do { (body', fvs) <- rnLHsType ctx hs_ty - ; return (HsIB { hsib_kvs = kvs - , hsib_tvs = tvs + ; return (HsIB { hsib_vars = vars , hsib_body = body' }, fvs) } rnImplicitBndrs :: Bool -- True <=> no implicit quantification @@ -201,22 +201,23 @@ rnImplicitBndrs :: Bool -- True <=> no implicit quantification -- E.g. f :: forall a. a->b -- Do not quantify over 'b' too. -> LHsType RdrName - -> ([Name] -> [Name] -> RnM (a, FreeVars)) + -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside = do { rdr_env <- getLocalRdrEnv - ; let (kv_rdrs, tv_rdrs) = filterInScope rdr_env $ - extractHsTyRdrTyVars hs_ty - real_tv_rdrs -- Implicit quantification only if - -- there is no explicit forall + ; free_vars <- filterInScope rdr_env <$> + extractHsTyRdrTyVars hs_ty + ; let real_tv_rdrs -- Implicit quantification only if + -- there is no explicit forall | no_implicit_if_forall , L _ (HsForAllTy {}) <- hs_ty = [] - | otherwise = tv_rdrs - ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr kv_rdrs $$ ppr tv_rdrs)) - ; kvs <- mapM (newLocalBndrRn . L loc) kv_rdrs - ; tvs <- mapM (newLocalBndrRn . L loc) real_tv_rdrs - ; bindLocalNamesFV (kvs ++ tvs) $ - thing_inside kvs tvs } + | otherwise = freeKiTyVarsTypeVars free_vars + real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs + ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr free_vars $$ + ppr real_rdrs)) + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs + ; bindLocalNamesFV vars $ + thing_inside vars } rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl @@ -265,6 +266,35 @@ f :: forall a. a -> (() => b) binds "a" and "b" The -fwarn-context-quantification flag warns about this situation. See rnHsTyKi for case HsForAllTy Qualified. + +Note [Dealing with *] +~~~~~~~~~~~~~~~~~~~~~ +As a legacy from the days when types and kinds were different, we use +the type * to mean what we now call GHC.Types.Type. The problem is that +* should associate just like an identifier, *not* a symbol. +Running example: the user has written + + T (Int, Bool) b + c * d + +At this point, we have a bunch of stretches of types + + [[T, (Int, Bool), b], [c], [d]] + +these are the [[LHsType Name]] and a bunch of operators + + [GHC.TypeLits.+, GHC.Types.*] + +Note that the * is GHC.Types.*. So, we want to rearrange to have + + [[T, (Int, Bool), b], [c, *, d]] + +and + + [GHC.TypeLits.+] + +as our lists. We can then do normal fixity resolution on these. The fixities +must come along for the ride just so that the list stays in sync with the +operators. -} rnLHsTyKi :: RnTyKiWhat @@ -276,13 +306,14 @@ rnLHsTyKi what doc (L loc ty) rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnLHsType cxt ty = -- pprTrace "rnHsType" (pprHsDocContext cxt $$ ppr ty) $ - rnLHsTyKi RnType cxt ty + rnLHsTyKi (RnTypeBody TypeLevel) cxt ty -rnLHsPred :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnLHsPred = rnLHsTyKi RnConstraint +rnLHsPred :: RnTyKiWhat -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsPred (RnTypeBody level) = rnLHsTyKi (RnConstraint level) +rnLHsPred what = rnLHsTyKi what rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) -rnLHsKind = rnLHsTyKi RnKind +rnLHsKind = rnLHsTyKi (RnTypeBody KindLevel) rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name), FreeVars) @@ -293,43 +324,40 @@ rnLHsMaybeKind doc (Just kind) ; return (Just kind', fvs) } rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsType cxt ty = rnHsTyKi RnType cxt ty +rnHsType cxt ty = rnHsTyKi (RnTypeBody TypeLevel) cxt ty rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) -rnHsKind = rnHsTyKi RnKind +rnHsKind = rnHsTyKi (RnTypeBody KindLevel) -data RnTyKiWhat = RnType - | RnKind - | RnTopConstraint -- Top-level context of HsSigWcTypes - | RnConstraint -- All other constraints +data RnTyKiWhat = RnTypeBody TypeOrKind + | RnTopConstraint -- Top-level context of HsSigWcTypes + | RnConstraint TypeOrKind -- All other constraints instance Outputable RnTyKiWhat where - ppr RnType = ptext (sLit "RnType") - ppr RnKind = ptext (sLit "RnKind") - ppr RnTopConstraint = ptext (sLit "RnTopConstraint") - ppr RnConstraint = ptext (sLit "RnConstraint") - -isRnType :: RnTyKiWhat -> Bool -isRnType RnType = True -isRnType _ = False + ppr (RnTypeBody lev) = text "RnTypeBody" <+> ppr lev + ppr RnTopConstraint = text "RnTopConstraint" + ppr (RnConstraint lev) = text "RnConstraint" <+> ppr lev -isRnKind :: RnTyKiWhat -> Bool -isRnKind RnKind = True -isRnKind _ = False +isRnKindLevel :: RnTyKiWhat -> Bool +isRnKindLevel (RnTypeBody KindLevel) = True +isRnKindLevel (RnConstraint KindLevel) = True +isRnKindLevel _ = False rnHsTyKi :: RnTyKiWhat -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi _ doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) - = bindLHsTyVarBndrs doc Nothing tyvars $ \ tyvars' -> - do { (tau', fvs) <- rnLHsType doc tau +rnHsTyKi what doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) + = do { checkTypeInType what ty + ; bindLHsTyVarBndrs doc Nothing [] tyvars $ \ _ tyvars' -> + do { (tau', fvs) <- rnLHsTyKi what doc tau ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' } - , fvs) } + , fvs) }} -rnHsTyKi _ doc (HsQualTy { hst_ctxt = lctxt - , hst_body = tau }) - = do { (ctxt', fvs1) <- rnContext doc lctxt - ; (tau', fvs2) <- rnLHsType doc tau +rnHsTyKi what doc ty@(HsQualTy { hst_ctxt = lctxt + , hst_body = tau }) + = do { checkTypeInType what ty + ; (ctxt', fvs1) <- rnTyKiContext what doc lctxt + ; (tau', fvs2) <- rnLHsTyKi what doc tau ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' } , fvs1 `plusFV` fvs2) } @@ -337,23 +365,15 @@ rnHsTyKi what _ (HsTyVar (L loc rdr_name)) = do { name <- rnTyVar what rdr_name ; return (HsTyVar (L loc name), unitFV name) } --- If we see (forall a . ty), without foralls on, the forall will give --- a sensible error message, but we don't want to complain about the dot too --- Hence the jiggery pokery with ty1 -rnHsTyKi what doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) - = setSrcSpan loc $ - do { ops_ok <- xoptM Opt_TypeOperators - ; op' <- if ops_ok - then rnTyVar what op - else do { addErr (opTyErr op ty) - ; return (mkUnboundNameRdr op) } -- Avoid double complaint - ; let l_op' = L loc op' - ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs1) <- rnLHsTyKi what doc ty1 - ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) - op' fix ty1' ty2' - ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } +rnHsTyKi what doc ty@(HsOpTy ty1 l_op ty2) + = setSrcSpan (getLoc l_op) $ + do { (l_op', fvs1) <- rnHsTyOp what ty l_op + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs2) <- rnLHsTyKi what doc ty1 + ; (ty2', fvs3) <- rnLHsTyKi what doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) + (unLoc l_op') fix ty1' ty2' + ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi what doc (HsParTy ty) = do { (ty', fvs) <- rnLHsTyKi what doc ty @@ -385,35 +405,34 @@ rnHsTyKi what doc (HsFunTy ty1 ty2) -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - ; res_ty <- if isRnType what - then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' - else return (HsFunTy ty1' ty2') - + ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' ; return (res_ty, fvs1 `plusFV` fvs2) } rnHsTyKi what doc listTy@(HsListTy ty) = do { data_kinds <- xoptM Opt_DataKinds - ; when (not data_kinds && isRnKind what) + ; when (not data_kinds && isRnKindLevel what) (addErr (dataKindsErr what listTy)) ; (ty', fvs) <- rnLHsTyKi what doc ty ; return (HsListTy ty', fvs) } -rnHsTyKi _ doc (HsKindSig ty k) - = do { kind_sigs_ok <- xoptM Opt_KindSignatures +rnHsTyKi what doc t@(HsKindSig ty k) + = do { checkTypeInType what t + ; kind_sigs_ok <- xoptM Opt_KindSignatures ; unless kind_sigs_ok (badKindSigErr doc ty) - ; (ty', fvs1) <- rnLHsType doc ty + ; (ty', fvs1) <- rnLHsTyKi what doc ty ; (k', fvs2) <- rnLHsKind doc k ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi _ doc (HsPArrTy ty) - = do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi what doc t@(HsPArrTy ty) + = do { notInKinds what t + ; (ty', fvs) <- rnLHsType doc ty ; return (HsPArrTy ty', fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsTyKi what doc tupleTy@(HsTupleTy tup_con tys) = do { data_kinds <- xoptM Opt_DataKinds - ; when (not data_kinds && isRnKind what) + ; when (not data_kinds && isRnKindLevel what) (addErr (dataKindsErr what tupleTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys ; return (HsTupleTy tup_con tys', fvs) } @@ -423,24 +442,83 @@ rnHsTyKi what _ tyLit@(HsTyLit t) = do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr what tyLit)) ; when (negLit t) (addErr negLitErr) + ; checkTypeInType what tyLit ; return (HsTyLit t, emptyFVs) } where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit +rnHsTyKi isType doc overall_ty@(HsAppsTy tys) + = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions + let (non_syms, syms) = splitHsAppsTy tys + + -- Step 2: rename the pieces + ; (syms1, fvs1) <- mapFvRn (rnHsTyOp isType overall_ty) syms + ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi isType doc) non_syms + + -- Step 3: deal with *. See Note [Dealing with *] + ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1 + + -- Step 4: collapse the non-symbol regions with HsAppTy + ; non_syms3 <- mapM deal_with_non_syms non_syms2 + + -- Step 5: assemble the pieces, using mkHsOpTyRn + ; L _ res_ty <- build_res_ty non_syms3 syms2 + + -- all done. Phew. + ; return (res_ty, fvs1 `plusFV` fvs2) } + where + -- See Note [Dealing with *] + deal_with_star :: [[LHsType Name]] -> [Located Name] + -> [[LHsType Name]] -> [Located Name] + -> ([[LHsType Name]], [Located Name]) + deal_with_star acc1 acc2 + (non_syms1 : non_syms2 : non_syms) (L loc star : ops) + | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey + = deal_with_star acc1 acc2 + ((non_syms1 ++ L loc (HsTyVar (L loc star)) : non_syms2) : non_syms) + ops + deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) + = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops + deal_with_star acc1 acc2 [non_syms] [] + = (reverse (non_syms : acc1), reverse acc2) + deal_with_star _ _ _ _ + = pprPanic "deal_with_star" (ppr overall_ty) + + -- collapse [LHsType Name] to LHsType Name by making applications + -- monadic only for failure + deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name) + deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms + deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty) + + -- assemble a right-biased OpTy for use in mkHsOpTyRn + build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name) + build_res_ty (arg1 : args) (op1 : ops) + = do { rhs <- build_res_ty args ops + ; fix <- lookupTyFixityRn op1 + ; res <- + mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs + ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs) + ; return (L loc res) + } + build_res_ty [arg] [] = return arg + build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty) + rnHsTyKi what doc (HsAppTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1 ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi _ doc (HsIParamTy n ty) - = do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi what doc t@(HsIParamTy n ty) + = do { notInKinds what t + ; (ty', fvs) <- rnLHsType doc ty ; return (HsIParamTy n ty', fvs) } -rnHsTyKi _ doc (HsEqTy ty1 ty2) - = do { (ty1', fvs1) <- rnLHsType doc ty1 - ; (ty2', fvs2) <- rnLHsType doc ty2 +rnHsTyKi what doc t@(HsEqTy ty1 ty2) + = do { checkTypeInType what t + ; (ty1', fvs1) <- rnLHsTyKi what doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi _ _ (HsSpliceTy sp k) @@ -456,19 +534,18 @@ rnHsTyKi _ _ (HsCoreTy ty) -- The emptyFVs probably isn't quite right -- but I don't think it matters -rnHsTyKi _ _ (HsWrapTy {}) - = panic "rnHsTyKi" - rnHsTyKi what doc ty@(HsExplicitListTy k tys) - = do { data_kinds <- xoptM Opt_DataKinds + = do { checkTypeInType what ty + ; data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr what ty)) - ; (tys', fvs) <- rnLHsTypes doc tys + ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys ; return (HsExplicitListTy k tys', fvs) } rnHsTyKi what doc ty@(HsExplicitTupleTy kis tys) - = do { data_kinds <- xoptM Opt_DataKinds + = do { checkTypeInType what ty + ; data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr what ty)) - ; (tys', fvs) <- rnLHsTypes doc tys + ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys ; return (HsExplicitTupleTy kis tys', fvs) } rnHsTyKi what ctxt (HsWildCardTy wc) @@ -490,9 +567,8 @@ rnHsTyKi what ctxt (HsWildCardTy wc) = Just (notAllowed wc) | otherwise = case what of - RnType -> Nothing - RnKind -> Just (notAllowed wc <+> ptext (sLit "in a kind")) - RnConstraint -> Just constraint_msg + RnTypeBody _ -> Nothing + RnConstraint _ -> Just constraint_msg RnTopConstraint -> case wc of AnonWildCard {} -> Just constraint_msg NamedWildCard {} -> Nothing @@ -516,8 +592,8 @@ wildCardMsg ctxt doc -------------- rnTyVar :: RnTyKiWhat -> RdrName -> RnM Name rnTyVar what rdr_name - | isRnKind what = lookupKindOccRn rdr_name - | otherwise = lookupTypeOccRn rdr_name + | isRnKindLevel what = lookupKindOccRn rdr_name + | otherwise = lookupTypeOccRn rdr_name rnLTyVar :: Located RdrName -> RnM (Located Name) rnLTyVar (L loc rdr_name) @@ -525,6 +601,20 @@ rnLTyVar (L loc rdr_name) ; return (L loc tyvar) } -------------- +rnHsTyOp :: Outputable a + => RnTyKiWhat -> a -> Located RdrName -> RnM (Located Name, FreeVars) +rnHsTyOp what overall_ty (L loc op) + = do { ops_ok <- xoptM Opt_TypeOperators + ; op' <- rnTyVar what op + ; unless (ops_ok + || op' == starKindTyConName + || op' == unicodeStarKindTyConName + || op' `hasKey` eqTyConKey) $ + addErr (opTyErr op overall_ty) + ; let l_op' = L loc op' + ; return (l_op', unitFV op') } + +-------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys @@ -592,6 +682,29 @@ rnWildCard ctxt wc@(NamedWildCard (L loc rdr_name)) msg = wildCardMsg ctxt (notAllowed wc) +--------------- +-- | Ensures either that we're in a type or that -XTypeInType is set +checkTypeInType :: Outputable ty + => RnTyKiWhat + -> ty -- ^ type + -> RnM () +checkTypeInType what ty + | isRnKindLevel what + = do { type_in_type <- xoptM Opt_TypeInType + ; unless type_in_type $ + addErr (text "Illegal kind:" <+> ppr ty $$ + text "Did you mean to enable TypeInType?") } +checkTypeInType _ _ = return () + +notInKinds :: Outputable ty + => RnTyKiWhat + -> ty + -> RnM () +notInKinds what ty + | isRnKindLevel what + = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty) +notInKinds _ _ = return () + {- ***************************************************** * * Binding type variables @@ -611,11 +724,24 @@ bindSigTyVarsFV tvs thing_inside else bindLocalNamesFV tvs thing_inside } +-- | Simply bring a bunch of RdrNames into scope. No checking for +-- validity, at all. The binding location is taken from the location +-- on each name. +bindLRdrNames :: [Located RdrName] + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindLRdrNames rdrs thing_inside + = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs + ; bindLocalNamesFV var_names $ + thing_inside var_names } + --------------- -bindHsQTyVars :: HsDocContext - -> Maybe a -- Just _ => an associated type decl - -> [RdrName] -- Kind variables from scope - -> LHsQTyVars RdrName -- Type variables +bindHsQTyVars :: forall a b. + HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [Located RdrName] -- Kind variables from scope, in l-to-r + -- order, but not from ... + -> (LHsQTyVars RdrName) -- ... these user-written tyvars -> (LHsQTyVars Name -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -- (a) Bring kind variables into scope @@ -623,68 +749,155 @@ bindHsQTyVars :: HsDocContext -- and (ii) mentioned in the kinds of tv_bndrs -- (b) Bring type variables into scope bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside - = do { rdr_env <- getLocalRdrEnv - ; let tvs = hsQTvBndrs tv_bndrs - kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs - , let (_, kvs) = extractHsTyRdrTyVars kind - , kv <- kvs ] - all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs) - all_kvs = filterOut (inScope rdr_env) all_kvs' - - overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ] - -- These variables appear both as kind and type variables - -- in the same declaration; eg type family T (x :: *) (y :: x) - -- We disallow this: too confusing! - - ; poly_kind <- xoptM Opt_PolyKinds - ; unless (poly_kind || null all_kvs) - (addErr (badKindBndrs doc all_kvs)) - ; unless (null overlap_kvs) - (addErr (overlappingKindVars doc overlap_kvs)) - - ; loc <- getSrcSpanM - ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs - ; bindLocalNamesFV kv_names $ - bindLHsTyVarBndrs doc mb_assoc tvs $ \ tv_bndrs' -> - thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } - -bindLHsTyVarBndrs :: HsDocContext - -> Maybe a -- Just _ => an associated type decl - -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (b, FreeVars)) + = do { bindLHsTyVarBndrs doc mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $ + \ rn_kvs rn_bndrs -> + thing_inside (HsQTvs { hsq_implicit = rn_kvs + , hsq_explicit = rn_bndrs }) } + +bindLHsTyVarBndrs :: forall a b. + HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [Located RdrName] -- Unbound kind variables from scope, + -- in l-to-r order, but not from ... + -> [LHsTyVarBndr RdrName] -- ... these user-written tyvars + -> ( [Name] -- all kv names + -> [LHsTyVarBndr Name] + -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndrs doc mb_assoc tv_bndrs thing_inside - = do { let tv_names_w_loc = map hsLTyVarLocName tv_bndrs - - -- Check for duplicate or shadowed tyvar bindrs - ; checkDupRdrNames tv_names_w_loc - ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) +bindLHsTyVarBndrs doc mb_assoc kv_bndrs tv_bndrs thing_inside + = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + ; go [] [] emptyNameSet emptyNameSet tv_bndrs } + where + tv_names_w_loc = map hsLTyVarLocName tv_bndrs + + go :: [Name] -- kind-vars found (in reverse order) + -> [LHsTyVarBndr Name] -- already renamed (in reverse order) + -> NameSet -- kind vars already in scope (for dup checking) + -> NameSet -- type vars already in scope (for dup checking) + -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped + -> RnM (b, FreeVars) + go rn_kvs rn_tvs kv_names tv_names (tv_bndr : tv_bndrs) + = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $ + \ kv_nms tv_bndr' -> go (reverse kv_nms ++ rn_kvs) + (tv_bndr' : rn_tvs) + (kv_names `extendNameSetList` kv_nms) + (tv_names `extendNameSet` hsLTyVarName tv_bndr') + tv_bndrs + + go rn_kvs rn_tvs _kv_names tv_names [] + = -- still need to deal with the kv_bndrs passed in originally + bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms -> + do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs) + all_rn_tvs = reverse rn_tvs + ; env <- getLocalRdrEnv + ; traceRn (text "bindHsTyVars" <+> (ppr env $$ + ppr all_rn_kvs $$ + ppr all_rn_tvs)) + ; thing_inside all_rn_kvs all_rn_tvs } + +bindLHsTyVarBndr :: HsDocContext + -> Maybe a -- associated class + -> NameSet -- kind vars already in scope + -> NameSet -- type vars already in scope + -> LHsTyVarBndr RdrName + -> ([Name] -> LHsTyVarBndr Name -> RnM (b, FreeVars)) + -- passed the newly-bound implicitly-declared kind vars, + -- and the renamed LHsTyVarBndr + -> RnM (b, FreeVars) +bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside + = case hs_tv_bndr of + L loc (UserTyVar lrdr@(L lv rdr)) -> + do { check_dup loc rdr + ; nm <- newTyVarNameRn mb_assoc lrdr + ; bindLocalNamesFV [nm] $ + thing_inside [] (L loc (UserTyVar (L lv nm))) } + L loc (KindedTyVar lrdr@(L lv rdr) kind) -> + do { check_dup lv rdr + + -- check for -XKindSignatures + ; sig_ok <- xoptM Opt_KindSignatures + ; unless sig_ok (badKindSigErr doc kind) + + -- deal with kind vars in the user-written kind + ; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind + ; bindImplicitKvs doc mb_assoc free_kvs tv_names $ \ kv_nms -> + do { (kind', fvs1) <- rnLHsKind doc kind + ; tv_nm <- newTyVarNameRn mb_assoc lrdr + ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $ + thing_inside kv_nms + (L loc (KindedTyVar (L lv tv_nm) kind')) + ; return (b, fvs1 `plusFV` fvs2) }} + where + -- make sure that the RdrName isn't in the sets of + -- names. We can't just check that it's not in scope at all + -- because we might be inside an associated class. + check_dup :: SrcSpan -> RdrName -> RnM () + check_dup loc rdr + = do { m_name <- lookupLocalOccRn_maybe rdr + ; whenIsJust m_name $ \name -> + do { when (name `elemNameSet` kv_names) $ + addErrAt loc (vcat [ ki_ty_err_msg name + , pprHsDocContext doc ]) + ; when (name `elemNameSet` tv_names) $ + dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }} + + ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+> + text "used as a kind variable before being bound" $$ + text "as a type variable. Perhaps reorder your variables?" + + +bindImplicitKvs :: HsDocContext + -> Maybe a + -> [Located RdrName] -- ^ kind var *occurrences*, from which + -- intent to bind is inferred + -> NameSet -- ^ *type* variables, for type/kind + -- misuse check for -XNoTypeInType + -> ([Name] -> RnM (b, FreeVars)) -- ^ passed new kv_names + -> RnM (b, FreeVars) +bindImplicitKvs _ _ [] _ thing_inside = thing_inside [] +bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside + = do { rdr_env <- getLocalRdrEnv + ; let part_kvs lrdr@(L loc kv_rdr) + = case lookupLocalRdrEnv rdr_env kv_rdr of + Just kv_name -> Left (L loc kv_name) + _ -> Right lrdr + (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs + + -- check whether we're mixing types & kinds illegally + ; type_in_type <- xoptM Opt_TypeInType + ; unless type_in_type $ + mapM_ (check_tv_used_in_kind tv_names) bound_kvs + + ; poly_kinds <- xoptM Opt_PolyKinds + ; unless poly_kinds $ + addErr (badKindBndrs doc new_kvs) + + -- bind the vars and move on + ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs + ; bindLocalNamesFV kv_nms $ + thing_inside kv_nms } + where + -- check to see if the variables free in a kind are bound as type + -- variables. Assume -XNoTypeInType. + check_tv_used_in_kind :: NameSet -- ^ *type* variables + -> Located Name -- ^ renamed var used in kind + -> RnM () + check_tv_used_in_kind tv_names (L loc kv_name) + = when (kv_name `elemNameSet` tv_names) $ + addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+> + text "used in a kind." $$ + text "Did you mean to use TypeInType?" + , pprHsDocContext doc ]) + + +newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name +newTyVarNameRn mb_assoc (L loc rdr) + = do { rdr_env <- getLocalRdrEnv + ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of + (Just _, Just n) -> return n + -- Use the same Name as the parent class decl - ; rdr_env <- getLocalRdrEnv - ; (tv_bndrs', fvs1) <- mapFvRn (rnLHsTyVarBndr doc mb_assoc rdr_env) tv_bndrs - ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ - thing_inside tv_bndrs' - ; return (res, fvs1 `plusFV` fvs2) } - -rnLHsTyVarBndr :: HsDocContext -> Maybe a -> LocalRdrEnv - -> LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) -rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar (L l rdr))) - = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; return (L loc (UserTyVar (L l nm)), emptyFVs) } -rnLHsTyVarBndr doc mb_assoc rdr_env (L loc (KindedTyVar (L lv rdr) kind)) - = do { sig_ok <- xoptM Opt_KindSignatures - ; unless sig_ok (badKindSigErr doc kind) - ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; (kind', fvs) <- rnLHsKind doc kind - ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) } - -newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name -newTyVarNameRn mb_assoc rdr_env loc rdr - | Just _ <- mb_assoc -- Use the same Name as the parent class decl - , Just n <- lookupLocalRdrEnv rdr_env rdr - = return n - | otherwise - = newLocalBndrRn (L loc rdr) + _ -> newLocalBndrRn (L loc rdr) } --------------------- collectNamedWildCards :: LHsType RdrName -> [Located RdrName] @@ -701,6 +914,7 @@ collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)] collectWildCards lty = go lty where go (L loc ty) = case ty of + HsAppsTy tys -> gos (mapMaybe prefix_types_only tys) HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2 HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2 HsListTy ty -> go ty @@ -716,7 +930,6 @@ collectWildCards lty = go lty HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds HsExplicitListTy _ tys -> gos tys HsExplicitTupleTy _ tys -> gos tys - HsWrapTy _ ty -> go (L loc ty) -- Interesting cases HsWildCardTy wc -> [L loc wc] HsForAllTy { hst_body = ty } -> go ty @@ -727,6 +940,9 @@ collectWildCards lty = go lty gos = mconcat . map go + prefix_types_only (HsAppPrefix ty) = Just ty + prefix_types_only (HsAppInfix _) = Nothing + {- ********************************************************* @@ -771,12 +987,16 @@ rnField fl_env doc (L l (ConDeclField names ty haddock_doc)) ********************************************************* -} -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) -rnContext doc (L loc cxt) +rnTyKiContext :: RnTyKiWhat + -> HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnTyKiContext what doc (L loc cxt) = do { traceRn (text "rncontext" <+> ppr cxt) - ; (cxt', fvs) <- mapFvRn (rnLHsPred doc) cxt + ; (cxt', fvs) <- mapFvRn (rnLHsPred what doc) cxt ; return (L loc cxt', fvs) } +rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext = rnTyKiContext (RnConstraint TypeLevel) + {- ************************************************************************ * * @@ -809,10 +1029,10 @@ mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) -> Name -> Fixity -> LHsType Name -> LHsType Name -> RnM (HsType Name) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy t1 (w2, op2) t2) + (\t1 t2 -> HsOpTy t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) @@ -1068,14 +1288,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) * * ***************************************************** -} -overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc -overlappingKindVars doc kvs - = withHsDocContext doc $ - ptext (sLit "Kind variable") <> plural kvs - <+> ptext (sLit "also used as type variable") <> plural kvs - <> colon <+> pprQuotedList kvs - -badKindBndrs :: HsDocContext -> [RdrName] -> SDoc +badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc badKindBndrs doc kvs = withHsDocContext doc $ hang (ptext (sLit "Unexpected kind variable") <> plural kvs @@ -1094,8 +1307,8 @@ dataKindsErr what thing = hang (ptext (sLit "Illegal") <+> pp_what <> colon <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use DataKinds")) where - pp_what | isRnKind what = ptext (sLit "kind") - | otherwise = ptext (sLit "type") + pp_what | isRnKindLevel what = ptext (sLit "kind") + | otherwise = ptext (sLit "type") inTypeDoc :: HsType RdrName -> SDoc inTypeDoc ty = ptext (sLit "In the type") <+> quotes (ppr ty) @@ -1111,20 +1324,19 @@ warnUnusedForAlls in_doc bound_names used_names vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) , in_doc ] -opTyErr :: RdrName -> HsType RdrName -> SDoc -opTyErr op ty@(HsOpTy ty1 _ _) - = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty)) +opTyErr :: Outputable a => RdrName -> a -> SDoc +opTyErr op overall_ty + = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) 2 extra where - extra | op == dot_tv_RDR && forall_head ty1 + extra | op == dot_tv_RDR = perhapsForallMsg | otherwise = ptext (sLit "Use TypeOperators to allow operators in types") - forall_head (L _ (HsTyVar (L _ tv))) = tv == forall_tv_RDR - forall_head (L _ (HsAppTy ty _)) = forall_head ty - forall_head _other = False -opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) +emptyNonSymsErr :: HsType RdrName -> SDoc +emptyNonSymsErr overall_ty + = text "Operator applied to too few arguments:" <+> ppr overall_ty {- ************************************************************************ @@ -1163,136 +1375,214 @@ Hence we returns a pair (kind-vars, type vars) See also Note [HsBSig binder lists] in HsTypes -} -type FreeKiTyVars = ([RdrName], [RdrName]) -- (Kind vars, type vars) +data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName] + , _fktv_k_set :: OccSet -- for efficiency, + -- only used internally + , fktv_tys :: [Located RdrName] + , _fktv_t_set :: OccSet + , fktv_all :: [Located RdrName] } + +instance Outputable FreeKiTyVars where + ppr (FKTV kis _ tys _ _) = ppr (kis, tys) + +emptyFKTV :: FreeKiTyVars +emptyFKTV = FKTV [] emptyOccSet [] emptyOccSet [] + +freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName] +freeKiTyVarsAllVars = fktv_all + +freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName] +freeKiTyVarsKindVars = fktv_kis + +freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName] +freeKiTyVarsTypeVars = fktv_tys filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env (kvs, tvs) - = (filterOut (inScope rdr_env) kvs, filterOut (inScope rdr_env) tvs) +filterInScope rdr_env (FKTV kis k_set tys t_set all) + = FKTV (filterOut in_scope kis) + (filterOccSet (not . in_scope_occ) k_set) + (filterOut in_scope tys) + (filterOccSet (not . in_scope_occ) t_set) + (filterOut in_scope all) + where + in_scope = inScope rdr_env . unLoc + in_scope_occ occ = isJust $ lookupLocalRdrOcc rdr_env occ inScope :: LocalRdrEnv -> RdrName -> Bool inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env -extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars +extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType -- or the free (sort, kind) variables of a HsKind -- It's used when making the for-alls explicit. -- Does not return any wildcards -- See Note [Kind and type-variable binders] extractHsTyRdrTyVars ty - = case extract_lty ty ([],[]) of - (kvs, tvs) -> (nub kvs, nub tvs) + = do { FKTV kis k_set tys t_set all <- extract_lty TypeLevel ty emptyFKTV + ; return (FKTV (nubL kis) k_set + (nubL tys) t_set + (nubL all)) } -extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars +extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars -- See Note [Kind and type-variable binders] -extractHsTysRdrTyVars ty - = case extract_ltys ty ([],[]) of - (kvs, tvs) -> (nub kvs, nub tvs) +extractHsTysRdrTyVars tys + = do { FKTV kis k_set tys t_set all <- extract_ltys TypeLevel tys emptyFKTV + ; return (FKTV (nubL kis) k_set + (nubL tys) t_set + (nubL all)) } -extractRdrKindSigVars :: LFamilyResultSig RdrName -> [RdrName] +extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName] extractRdrKindSigVars (L _ resultSig) | KindSig k <- resultSig = kindRdrNameFromSig k | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k - | TyVarSig (L _ (UserTyVar _)) <- resultSig = [] - | otherwise = [] -- this can only be NoSig but pattern exhasutiveness - -- checker complains about "NoSig <- resultSig" - where kindRdrNameFromSig k = nub (fst (extract_lkind k ([],[]))) + | otherwise = return [] + where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k -extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName] +extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName] -- Get the scoped kind variables mentioned free in the constructor decls -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) -- Here k should scope over the whole definition extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig , dd_cons = cons, dd_derivs = derivs }) - = fst $ extract_lctxt ctxt $ - extract_mb extract_lkind ksig $ - extract_mb (extract_sig_tys . unLoc) derivs $ - foldr (extract_con . unLoc) ([],[]) cons + = (nubL . freeKiTyVarsKindVars) <$> + (extract_lctxt TypeLevel ctxt =<< + extract_mb extract_lkind ksig =<< + extract_mb (extract_sig_tys . unLoc) derivs =<< + foldrM (extract_con . unLoc) emptyFKTV cons) where - extract_con (ConDeclGADT { }) acc = acc + extract_con (ConDeclGADT { }) acc = return acc extract_con (ConDeclH98 { con_qvars = qvs , con_cxt = ctxt, con_details = details }) acc - = extract_hs_tv_bndrs (maybe [] hsQTvBndrs qvs) acc $ - extract_mlctxt ctxt $ - extract_ltys (hsConDeclArgTys details) ([],[]) + = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<< + extract_mlctxt ctxt =<< + extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV +extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars +extract_mlctxt Nothing acc = return acc +extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc -extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> FreeKiTyVars -extract_mlctxt Nothing = mempty -extract_mlctxt (Just ctxt) = extract_lctxt ctxt +extract_lctxt :: TypeOrKind + -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt) -extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_lctxt ctxt = extract_ltys (unLoc ctxt) - -extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> FreeKiTyVars +extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars extract_sig_tys sig_tys acc - = foldr (\sig_ty acc -> extract_lty (hsSigType sig_ty) acc) - acc sig_tys + = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc) + acc sig_tys -extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars -extract_ltys tys acc = foldr extract_lty acc tys +extract_ltys :: TypeOrKind + -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars +extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys -extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars -extract_mb _ Nothing acc = acc +extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars) + -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars +extract_mb _ Nothing acc = return acc extract_mb f (Just x) acc = f x acc -extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of - (_, res_kvs) -> (res_kvs, acc_tvs) - -- Kinds shouldn't have sort signatures! +extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lkind = extract_lty KindLevel -extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_lty (L _ ty) acc +extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lty t_or_k (L _ ty) acc = case ty of - HsTyVar (L _ tv) -> extract_tv tv acc - HsBangTy _ ty -> extract_lty ty acc - HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc + HsTyVar ltv -> extract_tv t_or_k ltv acc + HsBangTy _ ty -> extract_lty t_or_k ty acc + HsRecTy flds -> foldrM (extract_lty t_or_k + . cd_fld_type . unLoc) acc flds - HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsListTy ty -> extract_lty ty acc - HsPArrTy ty -> extract_lty ty acc - HsTupleTy _ tys -> extract_ltys tys acc - HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsIParamTy _ ty -> extract_lty ty acc - HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc)) - HsParTy ty -> extract_lty ty acc - HsCoreTy {} -> acc -- The type is closed - HsSpliceTy {} -> acc -- Type splices mention no type variables - HsDocTy ty _ -> extract_lty ty acc - HsExplicitListTy _ tys -> extract_ltys tys acc - HsExplicitTupleTy _ tys -> extract_ltys tys acc - HsTyLit _ -> acc - HsWrapTy _ _ -> panic "extract_lty" - HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) + HsAppsTy tys -> extract_apps t_or_k tys acc + HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsListTy ty -> extract_lty t_or_k ty acc + HsPArrTy ty -> extract_lty t_or_k ty acc + HsTupleTy _ tys -> extract_ltys t_or_k tys acc + HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsIParamTy _ ty -> extract_lty t_or_k ty acc + HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<< + extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsParTy ty -> extract_lty t_or_k ty acc + HsCoreTy {} -> return acc -- The type is closed + HsSpliceTy {} -> return acc -- Type splices mention no tvs + HsDocTy ty _ -> extract_lty t_or_k ty acc + HsExplicitListTy _ tys -> extract_ltys t_or_k tys acc + HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc + HsTyLit _ -> return acc + HsKindSig ty ki -> extract_lty t_or_k ty =<< + extract_lkind ki acc HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc $ - extract_lty ty ([],[]) - HsQualTy { hst_ctxt = cx, hst_body = ty } - -> extract_lctxt cx (extract_lty ty acc) - HsWildCardTy {} -> acc + -> extract_hs_tv_bndrs tvs acc =<< + extract_lty t_or_k ty emptyFKTV + HsQualTy { hst_ctxt = ctxt, hst_body = ty } + -> extract_lctxt t_or_k ctxt =<< + extract_lty t_or_k ty acc + -- We deal with these separately in rnLHsTypeWithWildCards + HsWildCardTy {} -> return acc + +extract_apps :: TypeOrKind + -> [HsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars +extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys + +extract_app :: TypeOrKind -> HsAppType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_app t_or_k (HsAppInfix tv) acc = extract_tv t_or_k tv acc +extract_app t_or_k (HsAppPrefix ty) acc = extract_lty t_or_k ty acc extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars - -> FreeKiTyVars -> FreeKiTyVars + -> FreeKiTyVars -> RnM FreeKiTyVars -- In (forall (a :: Maybe e). a -> b) we have -- 'a' is bound by the forall -- 'b' is a free type variable -- 'e' is a free kind variable extract_hs_tv_bndrs tvs - (acc_kvs, acc_tvs) -- Note accumulator comes first - (body_kvs, body_tvs) + (FKTV acc_kvs acc_k_set acc_tvs acc_t_set acc_all) + -- Note accumulator comes first + (FKTV body_kvs body_k_set body_tvs body_t_set body_all) | null tvs - = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) + = return $ + FKTV (body_kvs ++ acc_kvs) (body_k_set `unionOccSets` acc_k_set) + (body_tvs ++ acc_tvs) (body_t_set `unionOccSets` acc_t_set) + (body_all ++ acc_all) | otherwise - = (acc_kvs ++ bndr_kvs ++ body_kvs, - acc_tvs ++ filterOut (`elem` local_tvs) body_tvs) + = do { FKTV bndr_kvs bndr_k_set _ _ _ + <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs] + + ; let locals = mkOccSet $ map (rdrNameOcc . hsLTyVarName) tvs + ; return $ + FKTV (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_kvs) ++ acc_kvs) + ((body_k_set `minusOccSet` locals) `unionOccSets` acc_k_set `unionOccSets` bndr_k_set) + (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) body_tvs ++ acc_tvs) + ((body_t_set `minusOccSet` locals) `unionOccSets` acc_t_set) + (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_all) ++ acc_all) } + +extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_tv t_or_k ltv@(L _ tv) acc + | isRdrTyVar tv = case acc of + FKTV kvs k_set tvs t_set all + | isTypeLevel t_or_k + -> do { when (occ `elemOccSet` k_set) $ + mixedVarsErr ltv + ; return (FKTV kvs k_set (ltv : tvs) (t_set `extendOccSet` occ) + (ltv : all)) } + | otherwise + -> do { when (occ `elemOccSet` t_set) $ + mixedVarsErr ltv + ; return (FKTV (ltv : kvs) (k_set `extendOccSet` occ) tvs t_set + (ltv : all)) } + | otherwise = return acc where - local_tvs = map hsLTyVarName tvs - (_, bndr_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs] - -extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_tv tv acc - | isRdrTyVar tv = add_tv tv acc - | otherwise = acc - -add_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars -add_tv tv (kvs,tvs) = (kvs, tv : tvs) + occ = rdrNameOcc tv + +mixedVarsErr :: Located RdrName -> RnM () +mixedVarsErr (L loc tv) + = do { typeintype <- xoptM Opt_TypeInType + ; unless typeintype $ + addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+> + text "used as both a kind and a type" $$ + text "Did you intend to use TypeInType?" } + +-- just used in this module; seemed convenient here +nubL :: Eq a => [Located a] -> [Located a] +nubL = nubBy eqLocated diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 7d43d54682..6a6cceb694 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -177,8 +177,8 @@ cseRhs env (id',rhs) | always_active -> (extendCSEnv env rhs' id', (zapped_id, rhs')) | otherwise -> (env, (id', rhs')) Just id - | always_active -> (extendCSSubst env id' id, (id', mkTicks ticks $ Var id)) - | otherwise -> (env, (id', mkTicks ticks $ Var id)) + | always_active -> (extendCSSubst env id' id, (id', mkTicks ticks $ varToCoreExpr id)) + | otherwise -> (env, (id', mkTicks ticks $ varToCoreExpr id)) -- In the Just case, we have -- x = rhs -- ... diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index fa72834ef9..5e2de54180 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -106,7 +106,6 @@ restoreLinkerGlobals :: () -> IO () restoreLinkerGlobals () = return () #endif - {- ************************************************************************ * * diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs index c1147eb446..e92db9fd1c 100644 --- a/compiler/simplCore/FloatIn.hs +++ b/compiler/simplCore/FloatIn.hs @@ -20,15 +20,14 @@ module FloatIn ( floatInwards ) where import CoreSyn import MkCore -import CoreUtils ( exprIsDupable, exprIsExpandable, exprType, +import CoreUtils ( exprIsDupable, exprIsExpandable, exprOkForSideEffects, mkTicks ) -import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) +import CoreFVs import Id ( isOneShotBndr, idType ) import Var -import Type ( Type, isUnLiftedType, isFunTy, splitFunTy, applyTy ) +import Type ( isUnLiftedType ) import VarSet import Util -import UniqDFM (UniqDFM, udfmToUfm) import DynFlags import Outputable import Data.List( mapAccumL ) @@ -118,8 +117,8 @@ the closure for a is not built. ************************************************************************ -} -type FreeVarSet = IdSet -type BoundVarSet = IdSet +type FreeVarSet = DIdSet +type BoundVarSet = DIdSet data FloatInBind = FB BoundVarSet FreeVarSet FloatBind -- The FreeVarSet is the free variables of the binding. In the case @@ -139,11 +138,15 @@ fiExpr _ to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit fiExpr _ to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr dflags to_drop (_, AnnCast expr (fvs_co, co)) +fiExpr dflags to_drop (_, AnnCast expr (co_ann, co)) = wrapFloats (drop_here ++ co_drop) $ Cast (fiExpr dflags e_drop expr) co where - [drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [udfmToUfm $ freeVarsOf expr, udfmToUfm fvs_co] to_drop + [drop_here, e_drop, co_drop] + = sepBindsByDropPoint dflags False + [freeVarsOf expr, freeVarsOfAnn co_ann] + (freeVarsOfType expr `unionDVarSet` freeVarsOfTypeAnn co_ann) + to_drop {- Applications: we do float inside applications, mainly because we @@ -156,28 +159,22 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {}) mkApps (fiExpr dflags fun_drop ann_fun) (zipWith (fiExpr dflags) arg_drops ann_args) where - (ann_fun@(fun_fvs, _), ann_args, ticks) - = collectAnnArgsTicks tickishFloatable ann_expr - fun_ty = exprType (deAnnotate ann_fun) - ((_,extra_fvs), arg_fvs) = mapAccumL mk_arg_fvs (fun_ty, emptyVarSet) ann_args - - -- All this faffing about is so that we can get hold of - -- the types of the arguments, to pass to noFloatIntoRhs - mk_arg_fvs :: (Type, FreeVarSet) -> CoreExprWithFVs -> ((Type, FreeVarSet), FreeVarSet) - mk_arg_fvs (fun_ty, extra_fvs) (_, AnnType ty) - = ((applyTy fun_ty ty, extra_fvs), emptyVarSet) - - mk_arg_fvs (fun_ty, extra_fvs) (arg_dfvs, ann_arg) - | ASSERT( isFunTy fun_ty ) noFloatIntoRhs ann_arg arg_ty - = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet) + (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr + (extra_fvs, arg_fvs) = mapAccumL mk_arg_fvs emptyDVarSet ann_args + + mk_arg_fvs :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet, FreeVarSet) + mk_arg_fvs extra_fvs ann_arg + | noFloatIntoRhs ann_arg + = (extra_fvs `unionDVarSet` freeVarsOf ann_arg, emptyDVarSet) | otherwise - = ((res_ty, extra_fvs), arg_fvs) - where - arg_fvs = udfmToUfm arg_dfvs - (arg_ty, res_ty) = splitFunTy fun_ty + = (extra_fvs, freeVarsOf ann_arg) drop_here : extra_drop : fun_drop : arg_drops - = sepBindsByDropPoint dflags False (extra_fvs : udfmToUfm fun_fvs : arg_fvs) to_drop + = sepBindsByDropPoint dflags False + (extra_fvs : freeVarsOf ann_fun : arg_fvs) + (freeVarsOfType ann_fun `unionDVarSet` + mapUnionDVarSet freeVarsOfType ann_args) + to_drop {- Note [Do not destroy the let/app invariant] @@ -304,58 +301,64 @@ idRuleAndUnfoldingVars of x. No need for type variables, hence not using idFreeVars. -} -fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_dfvs, ann_rhs)) body) +fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs) body) = fiExpr dflags new_to_drop body where - body_fvs = udfmToUfm (freeVarsOf body) `delVarSet` id - rhs_ty = idType id - rhs_fvs = udfmToUfm rhs_dfvs - rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] - extra_fvs | noFloatIntoRhs ann_rhs rhs_ty = rule_fvs `unionVarSet` rhs_fvs - | otherwise = rule_fvs + body_fvs = freeVarsOf body `delDVarSet` id + rhs_fvs = freeVarsOf rhs + + rule_fvs = idRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] + extra_fvs | noFloatIntoRhs rhs = rule_fvs `unionDVarSet` freeVarsOf rhs + | otherwise = rule_fvs -- See Note [extra_fvs (1): avoid floating into RHS] -- No point in floating in only to float straight out again -- Ditto ok-for-speculation unlifted RHSs [shared_binds, extra_binds, rhs_binds, body_binds] - = sepBindsByDropPoint dflags False [extra_fvs, rhs_fvs, body_fvs] to_drop + = sepBindsByDropPoint dflags False + [extra_fvs, rhs_fvs, body_fvs] + (freeVarsOfType rhs `unionDVarSet` freeVarsOfType body) + to_drop new_to_drop = body_binds ++ -- the bindings used only in the body - [FB (unitVarSet id) rhs_fvs' + [FB (unitDVarSet id) rhs_fvs' (FloatLet (NonRec id rhs'))] ++ -- the new binding itself extra_binds ++ -- bindings from extra_fvs shared_binds -- the bindings used both in rhs and body -- Push rhs_binds into the right hand side of the binding rhs' = fiExpr dflags rhs_binds rhs - rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs + rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs -- Don't forget the rule_fvs; the binding mentions them! fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body) = fiExpr dflags new_to_drop body where (ids, rhss) = unzip bindings - rhss_fvs = map (udfmToUfm . freeVarsOf) rhss - body_fvs = udfmToUfm $ freeVarsOf body + rhss_fvs = map freeVarsOf rhss + body_fvs = freeVarsOf body -- See Note [extra_fvs (1,2)] - rule_fvs = mapUnionVarSet idRuleAndUnfoldingVars ids - extra_fvs = rule_fvs `unionVarSet` - unionVarSets [ udfmToUfm fvs | (fvs, rhs) <- rhss - , noFloatIntoExpr rhs ] + rule_fvs = mapUnionDVarSet idRuleAndUnfoldingVarsDSet ids + extra_fvs = rule_fvs `unionDVarSet` + unionDVarSets [ freeVarsOf rhs | rhs@(_, rhs') <- rhss + , noFloatIntoExpr rhs' ] (shared_binds:extra_binds:body_binds:rhss_binds) - = sepBindsByDropPoint dflags False (extra_fvs:body_fvs:rhss_fvs) to_drop + = sepBindsByDropPoint dflags False + (extra_fvs:body_fvs:rhss_fvs) + (freeVarsOfType body `unionDVarSet` mapUnionDVarSet freeVarsOfType rhss) + to_drop new_to_drop = body_binds ++ -- the bindings used only in the body - [FB (mkVarSet ids) rhs_fvs' + [FB (mkDVarSet ids) rhs_fvs' (FloatLet (Rec (fi_bind rhss_binds bindings)))] ++ -- The new binding itself extra_binds ++ -- Note [extra_fvs (1,2)] shared_binds -- Used in more than one place - rhs_fvs' = unionVarSets rhss_fvs `unionVarSet` - unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet` + rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` + unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` rule_fvs -- Don't forget the rule variables! -- Push rhs_binds into the right hand side of the binding @@ -388,13 +391,17 @@ fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) = wrapFloats shared_binds $ fiExpr dflags (case_float : rhs_binds) rhs where - case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs + case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs (FloatCase scrut' case_bndr con alt_bndrs) scrut' = fiExpr dflags scrut_binds scrut [shared_binds, scrut_binds, rhs_binds] - = sepBindsByDropPoint dflags False [scrut_fvs, rhs_fvs] to_drop - rhs_fvs = udfmToUfm (freeVarsOf rhs) `delVarSetList` (case_bndr : alt_bndrs) - scrut_fvs = udfmToUfm $ freeVarsOf scrut + = sepBindsByDropPoint dflags False + [scrut_fvs, rhs_fvs] + (freeVarsOfType scrut `unionDVarSet` rhs_ty_fvs) + to_drop + rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) + rhs_ty_fvs = freeVarsOfType rhs `delDVarSetList` (case_bndr : alt_bndrs) + scrut_fvs = freeVarsOf scrut fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) = wrapFloats drop_here1 $ @@ -404,15 +411,24 @@ fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts) where -- Float into the scrut and alts-considered-together just like App [drop_here1, scrut_drops, alts_drops] - = sepBindsByDropPoint dflags False [scrut_fvs, all_alts_fvs] to_drop + = sepBindsByDropPoint dflags False + [scrut_fvs, all_alts_fvs] + (freeVarsOfType scrut `unionDVarSet` all_alts_ty_fvs) + to_drop -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) = sepBindsByDropPoint dflags True alts_fvs alts_drops - - scrut_fvs = udfmToUfm $ freeVarsOf scrut - alts_fvs = map alt_fvs alts - all_alts_fvs = unionVarSets alts_fvs - alt_fvs (_con, args, rhs) = foldl delVarSet (udfmToUfm $ freeVarsOf rhs) (case_bndr:args) + (drop_here2 : alts_drops_s) + = sepBindsByDropPoint dflags True alts_fvs all_alts_ty_fvs alts_drops + + scrut_fvs = freeVarsOf scrut + alts_fvs = map alt_fvs alts + all_alts_fvs = unionDVarSets alts_fvs + alts_ty_fvs = map alt_ty_fvs alts + all_alts_ty_fvs = unionDVarSets alts_ty_fvs + alt_fvs (_con, args, rhs) + = foldl delDVarSet (freeVarsOf rhs) (case_bndr:args) + alt_ty_fvs (_con, args, rhs) + = foldl delDVarSet (freeVarsOfType rhs) (case_bndr:args) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt @@ -424,14 +440,16 @@ okToFloatInside bndrs = all ok bndrs ok b = not (isId b) || isOneShotBndr b -- Push the floats inside there are no non-one-shot value binders -noFloatIntoRhs :: AnnExpr' Var (UniqDFM Var) -> Type -> Bool +noFloatIntoRhs :: CoreExprWithFVs -> Bool -- ^ True if it's a bad idea to float bindings into this RHS -- Preconditio: rhs :: rhs_ty -noFloatIntoRhs rhs rhs_ty +noFloatIntoRhs rhs@(_, rhs') = isUnLiftedType rhs_ty -- See Note [Do not destroy the let/app invariant] - || noFloatIntoExpr rhs + || noFloatIntoExpr rhs' + where + rhs_ty = exprTypeFV rhs -noFloatIntoExpr :: AnnExpr' Var (UniqDFM Var) -> Bool +noFloatIntoExpr :: CoreExprWithFVs' -> Bool noFloatIntoExpr (AnnLam bndr e) = not (okToFloatInside (bndr:bndrs)) -- NB: Must line up with fiExpr (AnnLam...); see Trac #7088 @@ -470,6 +488,15 @@ in it goes. If a binding is used inside {\em multiple} drop points, then it has to go in a you-must-drop-it-above-all-these-drop-points point. +But, with coercions appearing in types, there is a complication: we +might be floating in a "strict let" -- that is, a case. Case expressions +mention their return type. We absolutely can't float a coercion binding +inward to the point that the type of the expression it's about to wrap +mentions the coercion. So we include the union of the sets of free variables +of the types of all the drop points involved. If any of the floaters +bind a coercion variable mentioned in any of the types, that binder must +be dropped right away. + We have to maintain the order on these drop-point-related lists. -} @@ -477,6 +504,7 @@ sepBindsByDropPoint :: DynFlags -> Bool -- True <=> is case expression -> [FreeVarSet] -- One set of FVs per drop point + -> FreeVarSet -- Vars free in all the types of the drop points -> FloatInBinds -- Candidate floaters -> [FloatInBinds] -- FIRST one is bindings which must not be floated -- inside any drop point; the rest correspond @@ -490,11 +518,11 @@ sepBindsByDropPoint type DropBox = (FreeVarSet, FloatInBinds) -sepBindsByDropPoint _ _is_case drop_pts [] +sepBindsByDropPoint _ _is_case drop_pts _ty_fvs [] = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens -sepBindsByDropPoint dflags is_case drop_pts floaters - = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) +sepBindsByDropPoint dflags is_case drop_pts ty_fvs floaters + = go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts)) where go :: FloatInBinds -> [DropBox] -> [FloatInBinds] -- The *first* one in the argument list is the drop_here set @@ -508,10 +536,11 @@ sepBindsByDropPoint dflags is_case drop_pts floaters where -- "here" means the group of bindings dropped at the top of the fork - (used_here : used_in_flags) = [ fvs `intersectsVarSet` bndrs + (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs | (fvs, _) <- drop_boxes] + used_in_ty = ty_fvs `intersectsDVarSet` bndrs - drop_here = used_here || not can_push + drop_here = used_here || not can_push || used_in_ty -- For case expressions we duplicate the binding if it is -- reasonably small, and if it is not used in all the RHSs @@ -537,7 +566,7 @@ sepBindsByDropPoint dflags is_case drop_pts floaters new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags insert :: DropBox -> DropBox - insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops) + insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops) insert_maybe box True = insert box insert_maybe box False = box @@ -546,9 +575,9 @@ sepBindsByDropPoint dflags is_case drop_pts floaters floatedBindsFVs :: FloatInBinds -> FreeVarSet -floatedBindsFVs binds = mapUnionVarSet fbFVs binds +floatedBindsFVs binds = mapUnionDVarSet fbFVs binds -fbFVs :: FloatInBind -> VarSet +fbFVs :: FloatInBind -> DVarSet fbFVs (FB _ fvs _) = fvs wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 1e485aee1e..16f819241a 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -1755,7 +1755,7 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr , Just (localise v, rhs) ) case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings] - localise scrut_var = mkLocalId (localiseName (idName scrut_var)) (idType scrut_var) + localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) (idType scrut_var) -- Localise the scrut_var before shadowing it; we're making a -- new binding for it, and it might have an External Name, or -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs index dc76df0e08..ac8da3f45b 100644 --- a/compiler/simplCore/SAT.hs +++ b/compiler/simplCore/SAT.hs @@ -145,7 +145,7 @@ mergeSATInfo l r = zipWith mergeSA l r | t `eqType` t' = Static (TypeApp t) | otherwise = NotStatic mergeSA (Static (CoApp c)) (Static (CoApp c')) - | c `coreEqCoercion` c' = Static (CoApp c) + | c `eqCoercion` c' = Static (CoApp c) | otherwise = NotStatic mergeSA _ _ = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 65a36c3b46..b742a291fc 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -60,10 +60,7 @@ import CoreMonad ( FloatOutSwitches(..) ) import CoreUtils ( exprType, exprOkForSpeculation, exprIsBottom ) import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it -import Coercion ( isCoVar ) -import CoreSubst ( Subst, emptySubst, substBndrs, substRecBndrs, - extendIdSubst, extendSubstWithVar, cloneBndrs, - cloneRecIdBndrs, substTy, substCo, substDVarSet ) +import CoreSubst import MkCore ( sortQuantVars ) import Id import IdInfo @@ -358,16 +355,16 @@ lvlExpr env (_, AnnLet bind body) -- float, then neither will the body ; return (Let bind' body') } -lvlExpr env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts) +lvlExpr env (_, AnnCase scrut case_bndr ty alts) = do { scrut' <- lvlMFE True env scrut - ; lvlCase env scrut_fvs scrut' case_bndr ty alts } + ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts } ------------------------------------------- lvlCase :: LevelEnv -- Level of in-scope names/tyvars -> DVarSet -- Free vars of input scrutinee -> LevelledExpr -- Processed scrutinee -> Id -> Type -- Case binder and result type - -> [AnnAlt Id DVarSet] -- Input alternatives + -> [CoreAltWithFVs] -- Input alternatives -> LvlM LevelledExpr -- Result expression lvlCase env scrut_fvs scrut' case_bndr ty alts | [(con@(DataAlt {}), bs, body)] <- alts @@ -472,7 +469,7 @@ lvlMFE strict_ctxt env (_, AnnCast e (_, co)) lvlMFE True env e@(_, AnnCase {}) = lvlExpr env e -- Don't share cases -lvlMFE strict_ctxt env ann_expr@(fvs, _) +lvlMFE strict_ctxt env ann_expr | isUnLiftedType (exprType expr) -- Can't let-bind it; see Note [Unlifted MFEs] -- This includes coercions, which we don't want to float anyway @@ -489,6 +486,7 @@ lvlMFE strict_ctxt env ann_expr@(fvs, _) (mkVarApps (Var var) abs_vars)) } where expr = deAnnotate ann_expr + fvs = freeVarsOf ann_expr is_bot = exprIsBottom expr -- Note [Bottoming floats] dest_lvl = destLevel env fvs (isFunction ann_expr) is_bot abs_vars = abstractVars dest_lvl env fvs @@ -679,7 +677,7 @@ lvlBind :: LevelEnv -> CoreBindWithFVs -> LvlM (LevelledBind, LevelEnv) -lvlBind env (AnnNonRec bndr rhs@(rhs_fvs,_)) +lvlBind env (AnnNonRec bndr rhs) | isTyVar bndr -- Don't do anything for TyVar binders -- (simplifier gets rid of them pronto) || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) @@ -709,7 +707,8 @@ lvlBind env (AnnNonRec bndr rhs@(rhs_fvs,_)) ; return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', env') } where - bind_fvs = rhs_fvs `unionDVarSet` runFVDSet (idFreeVarsAcc bndr) + rhs_fvs = freeVarsOf rhs + bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr abs_vars = abstractVars dest_lvl env bind_fvs dest_lvl = destLevel env bind_fvs (isFunction rhs) is_bot is_bot = exprIsBottom (deAnnotate rhs) @@ -769,7 +768,7 @@ lvlBind env (AnnRec pairs) (bndrs,rhss) = unzip pairs -- Finding the free vars of the binding group is annoying - bind_fvs = ((unionDVarSets [ rhs_fvs | (_, (rhs_fvs,_)) <- pairs]) + bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) `unionDVarSet` (runFVDSet $ unionsFV [ idFreeVarsAcc bndr | (bndr, (_,_)) <- pairs])) @@ -1006,7 +1005,8 @@ abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar] -- See Note [Unique Determinism] in Unique for explanation of why -- Uniques are not deterministic. abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs - = map zap $ sortQuantVars $ uniq + = -- NB: sortQuantVars might not put duplicates next to each other + map zap $ sortQuantVars $ uniq [out_var | out_fv <- dVarSetElems (substDVarSet subst in_fvs) , out_var <- dVarSetElems (close out_fv) , abstract_me out_var ] @@ -1033,7 +1033,7 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs -- Result includes the input variable itself close v = foldDVarSet (unionDVarSet . close) (unitDVarSet v) - (runFVDSet $ varTypeTyVarsAcc v) + (runFVDSet $ varTypeTyCoVarsAcc v) type LvlM result = UniqSM result @@ -1060,7 +1060,7 @@ newPolyBndrs dest_lvl add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.hs - mkSysLocal (mkFastString str) uniq poly_ty + mkSysLocalOrCoVar (mkFastString str) uniq poly_ty where str = "poly_" ++ occNameString (getOccName bndr) poly_ty = mkPiTypes abs_vars (substTy subst (idType bndr)) @@ -1070,7 +1070,7 @@ newLvlVar :: LevelledExpr -- The RHS of the new binding -> LvlM Id newLvlVar lvld_rhs is_bot = do { uniq <- getUniqueM - ; return (add_bot_info (mkLocalId (mk_name uniq) rhs_ty)) } + ; return (add_bot_info (mkLocalIdOrCoVar (mk_name uniq) rhs_ty)) } where add_bot_info var -- We could call annotateBotStr always, but the is_bot -- flag just tells us when we don't need to do so diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index 17367ef74f..2f2dea660f 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -16,7 +16,7 @@ module SimplEnv ( -- Environments SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract - mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, + mkSimplEnv, extendIdSubst, SimplEnv.extendTCvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, getSimplRules, @@ -25,8 +25,8 @@ module SimplEnv ( simplNonRecBndr, simplRecBndrs, simplBinder, simplBinders, - substTy, substTyVar, getTvSubst, - getCvSubst, substCo, substCoVar, + substTy, substTyVar, getTCvSubst, + substCo, substCoVar, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -48,9 +48,9 @@ import Id import MkCore ( mkWildValBinder ) import TysWiredIn import qualified Type -import Type hiding ( substTy, substTyVarBndr, substTyVar ) +import Type hiding ( substTy, substTyVar, substTyVarBndr ) import qualified Coercion -import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr ) +import Coercion hiding ( substCo, substCoVar, substCoVarBndr ) import BasicTypes import MonadUtils import Outputable @@ -127,6 +127,7 @@ pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), + ptext (sLit "CvSubst:") <+> ppr (seCvSubst env), ptext (sLit "IdSubst:") <+> ppr (seIdSubst env), ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars) ] @@ -271,13 +272,14 @@ extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res = ASSERT2( isId var && not (isCoVar var), ppr var ) env {seIdSubst = extendVarEnv subst var res} -extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res - = env {seTvSubst = extendVarEnv subst var res} - -extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv -extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res - = env {seCvSubst = extendVarEnv subst var res} +extendTCvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTCvSubst env@(SimplEnv {seTvSubst = tsubst, seCvSubst = csubst}) var res + | isTyVar var + = env {seTvSubst = extendVarEnv tsubst var res} + | Just co <- isCoercionTy_maybe res + = env {seCvSubst = extendVarEnv csubst var co} + | otherwise + = pprPanic "SimplEnv.extendTCvSubst" (ppr res) --------------------- getInScope :: SimplEnv -> InScopeSet @@ -685,44 +687,42 @@ the letrec. ************************************************************************ -} -getTvSubst :: SimplEnv -> TvSubst -getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) - = mkTvSubst in_scope tv_env - -getCvSubst :: SimplEnv -> CvSubst -getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) - = CvSubst in_scope tv_env cv_env +getTCvSubst :: SimplEnv -> TCvSubst +getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = mkTCvSubst in_scope (tv_env, cv_env) substTy :: SimplEnv -> Type -> Type -substTy env ty = Type.substTy (getTvSubst env) ty +substTy env ty = Type.substTy (getTCvSubst env) ty substTyVar :: SimplEnv -> TyVar -> Type -substTyVar env tv = Type.substTyVar (getTvSubst env) tv +substTyVar env tv = Type.substTyVar (getTCvSubst env) tv substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv - = case Type.substTyVarBndr (getTvSubst env) tv of - (TvSubst in_scope' tv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv') + = case Type.substTyVarBndr (getTCvSubst env) tv of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') substCoVar :: SimplEnv -> CoVar -> Coercion -substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv +substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) substCoVarBndr env cv - = case Coercion.substCoVarBndr (getCvSubst env) cv of - (CvSubst in_scope' tv_env' cv_env', cv') + = case Coercion.substCoVarBndr (getTCvSubst env) cv of + (TCvSubst in_scope' tv_env' cv_env', cv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') substCo :: SimplEnv -> Coercion -> Coercion -substCo env co = Coercion.substCo (getCvSubst env) co +substCo env co = Coercion.substCo (getTCvSubst env) co ------------------ substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id - | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id - | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) - -- The tyVarsOfType is cheaper than it looks +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) + || isEmptyVarSet (tyCoVarsOfType old_ty) + = id + | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty) + -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself where diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs index b8453581de..8835494d64 100644 --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -19,7 +19,7 @@ module SimplMonad ( plusSimplCount, isZeroSimplCount ) where -import Id ( Id, mkSysLocal ) +import Id ( Id, mkSysLocalOrCoVar ) import Type ( Type ) import FamInstEnv ( FamInstEnv ) import CoreSyn ( RuleEnv(..) ) @@ -176,7 +176,7 @@ getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc)) newId :: FastString -> Type -> SimplM Id newId fs ty = do uniq <- getUniqueM - return (mkSysLocal fs uniq ty) + return (mkSysLocalOrCoVar fs uniq ty) {- ************************************************************************ diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 4a5604196b..29336c17d9 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -37,7 +37,6 @@ module SimplUtils ( import SimplEnv import CoreMonad ( SimplifierMode(..), Tick(..) ) -import MkCore ( sortQuantVars ) import DynFlags import CoreSyn import qualified CoreSubst @@ -52,7 +51,7 @@ import Var import Demand import SimplMonad import Type hiding( substTy ) -import Coercion hiding( substCo, substTy ) +import Coercion hiding( substCo ) import DataCon ( dataConWorkId ) import VarEnv import VarSet @@ -248,11 +247,11 @@ instance Outputable ArgSpec where addValArgTo :: ArgInfo -> OutExpr -> ArgInfo addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai - , ai_type = funResultTy (ai_type ai) } + , ai_type = applyTypeToArg (ai_type ai) arg } addTyArgTo :: ArgInfo -> OutType -> ArgInfo addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai - , ai_type = applyTy poly_fun_ty arg_ty } + , ai_type = piResultTy poly_fun_ty arg_ty } where poly_fun_ty = ai_type ai arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty } @@ -1572,7 +1571,7 @@ abstractFloats main_tvs body_env body rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = varSetElemsKvsFirst $ + tvs_here = varSetElemsWellScoped $ intersectVarSet main_tv_set $ closeOverKinds $ exprSomeFreeVars isTyVar rhs' @@ -1598,14 +1597,14 @@ abstractFloats main_tvs body_env body -- If you ever want to be more selective, remember this bizarre case too: -- x::a = x -- Here, we must abstract 'x' over 'a'. - tvs_here = sortQuantVars main_tvs + tvs_here = toposortTyVars main_tvs mk_poly tvs_here var = do { uniq <- getUniqueM ; let poly_name = setNameUnique (idName var) uniq -- Keep same name - poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course + poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs - mkLocalId poly_name poly_ty + mkLocalIdOrCoVar poly_name poly_ty ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } -- In the olden days, it was crucial to copy the occInfo of the original var, -- because we were looking at occurrence-analysed but as yet unsimplified code! @@ -1817,7 +1816,7 @@ mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _) -- Identity case = do { tick (CaseIdentity case_bndr) ; return (mkTicks ticks $ re_cast scrut rhs1) } where - ticks = concatMap (stripTicksT tickishFloatable . thirdOf3) (tail alts) + ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts) identity_alt (con, args, rhs) = check_eq rhs con args check_eq (Cast rhs co) con args diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 2c73f8e119..2b2b4358bc 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -12,7 +12,7 @@ module Simplify ( simplTopBinds, simplExpr, simplRules ) where import DynFlags import SimplMonad -import Type hiding ( substTy, extendTvSubst, substTyVar ) +import Type hiding ( substTy, substTyVar, extendTCvSubst ) import SimplEnv import SimplUtils import FamInstEnv ( FamInstEnv ) @@ -22,11 +22,11 @@ import MkId ( seqId, voidPrimId ) import MkCore ( mkImpossibleExpr, castBottomExpr ) import IdInfo import Name ( Name, mkSystemVarName, isExternalName ) -import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst ) +import Coercion hiding ( substCo, substCoVar ) import OptCoercion ( optCoercion ) import FamInstEnv ( topNormaliseType_maybe ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness - , isMarkedStrict ) --, dataConTyCon, dataConTag, fIRST_TAG ) + , isMarkedStrict, dataConRepArgTys ) --, dataConTyCon, dataConTag, fIRST_TAG ) --import TyCon ( isEnumerationTyCon ) -- temporalily commented out. See #8326 import CoreMonad ( Tick(..), SimplifierMode(..) ) import CoreSyn @@ -325,13 +325,16 @@ simplLazyBind :: SimplEnv simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ do { let rhs_env = rhs_se `setInScope` env - (tvs, body) = case collectTyBinders rhs of - (tvs, body) | not_lam body -> (tvs,body) - | otherwise -> ([], rhs) - not_lam (Lam _ _) = False - not_lam (Tick t e) | not (tickishFloatable t) - = not_lam e -- eta-reduction could float - not_lam _ = True + (tvs, body) = case collectTyAndValBinders rhs of + (tvs, [], body) + | surely_not_lam body -> (tvs, body) + _ -> ([], rhs) + + surely_not_lam (Lam {}) = False + surely_not_lam (Tick t e) + | not (tickishFloatable t) = surely_not_lam e + -- eta-reduction could float + surely_not_lam _ = True -- Do not do the "abstract tyyvar" thing if there's -- a lambda inside, because it defeats eta-reduction -- f = /\a. \x. g a x @@ -382,7 +385,7 @@ simplNonRecX env bndr new_rhs -- the binding c = (a,b) | Coercion co <- new_rhs - = return (extendCvSubst env bndr co) + = return (extendTCvSubst env bndr (mkCoercionTy co)) | otherwise = do { (env', bndr') <- simplBinder env bndr @@ -577,7 +580,7 @@ makeTrivialWithInfo top_lvl env info expr | otherwise -- See Note [Take care] below = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "a") - var = mkLocalIdWithInfo name expr_ty info + var = mkLocalIdOrCoVarWithInfo name expr_ty info ; env' <- completeNonRecX top_lvl env False var var expr ; expr' <- simplVar env' var ; return (env', expr') } @@ -662,7 +665,7 @@ completeBind :: SimplEnv completeBind env top_lvl old_bndr new_bndr new_rhs | isCoVar old_bndr = case new_rhs of - Coercion co -> return (extendCvSubst env old_bndr co) + Coercion co -> return (extendTCvSubst env old_bndr (mkCoercionTy co)) _ -> return (addNonRec env new_bndr new_rhs) | otherwise @@ -932,7 +935,7 @@ simplCoercionF env co cont simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = let opt_co = optCoercion (getCvSubst env) co + = let opt_co = optCoercion (getTCvSubst env) co in seqCo opt_co `seq` return opt_co ----------------------------------- @@ -1157,12 +1160,11 @@ simplCast env body co0 cont0 add_coerce co (Pair s1s2 _t1t2) cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) -- (f |> g) ty ---> (f ty) |> (g @ ty) -- This implements the PushT rule from the paper - | Just (tyvar,_) <- splitForAllTy_maybe s1s2 - = ASSERT( isTyVar tyvar ) - do { cont' <- addCoerce new_cast tail + | isForAllTy s1s2 + = do { cont' <- addCoerce new_cast tail ; return (cont { sc_cont = cont' }) } where - new_cast = mkInstCo co arg_ty + new_cast = mkInstCo co (mkNomReflCo arg_ty) add_coerce co (Pair s1s2 t1t2) (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = cont }) @@ -1235,13 +1237,18 @@ simplLam env [] body cont = simplExprF env body cont simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) = do { tick (BetaReduction bndr) - ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } + ; simplLam (extendTCvSubst env bndr arg_ty) bndrs body cont } simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont }) = do { tick (BetaReduction bndr) - ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont } + ; simplNonRecE env' (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont } where + env' | Coercion co <- arg + = extendTCvSubst env bndr (mkCoercionTy co) + | otherwise + = env + zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing] | isId bndr, isStableUnfolding (realIdUnfolding bndr) = setIdUnfolding bndr NoUnfolding @@ -1314,7 +1321,7 @@ simplNonRecE :: SimplEnv simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont = ASSERT( isTyVar bndr ) do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg - ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } + ; simplLam (extendTCvSubst env bndr ty_arg') bndrs body cont } simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont = do dflags <- getDynFlags @@ -1894,7 +1901,7 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont out_args = [ TyArg { as_arg_ty = scrut_ty , as_hole_ty = seq_id_ty } , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = applyTy seq_id_ty scrut_ty } + , as_hole_ty = piResultTy seq_id_ty scrut_ty } , ValArg scrut] rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs , sc_env = env, sc_cont = cont } @@ -2127,13 +2134,22 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) go [] [] = [] go (v:vs') strs | isTyVar v = v : go vs' strs go (v:vs') (str:strs) - | isMarkedStrict str = evald_v : go vs' strs - | otherwise = zapped_v : go vs' strs + | isMarkedStrict str = eval v : go vs' strs + | otherwise = zap v : go vs' strs + go _ _ = pprPanic "cat_evals" + (ppr con $$ + ppr vs $$ + ppr_with_length the_strs $$ + ppr_with_length (dataConRepArgTys con) $$ + ppr_with_length (dataConRepStrictness con)) where - zapped_v = zapIdOccInfo v -- See Note [Case alternative occ info] - evald_v = zapped_v `setIdUnfolding` evaldUnfolding - go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs) + ppr_with_length list + = ppr list <+> parens (text "length =" <+> ppr (length list)) + -- NB: If this panic triggers, note that + -- NoStrictnessMark doesn't print! + zap v = zapIdOccInfo v -- See Note [Case alternative occ info] + eval v = zap v `setIdUnfolding` evaldUnfolding addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv addAltUnfoldings env scrut case_bndr con_app @@ -2244,7 +2260,11 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont bind_args env' (b:bs') (Type ty : args) = ASSERT( isTyVar b ) - bind_args (extendTvSubst env' b ty) bs' args + bind_args (extendTCvSubst env' b ty) bs' args + + bind_args env' (b:bs') (Coercion co : args) + = ASSERT( isCoVar b ) + bind_args (extendTCvSubst env' b (mkCoercionTy co)) bs' args bind_args env' (b:bs') (arg : args) = ASSERT( isId b ) diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index 81de31b86b..b16220134d 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -210,7 +210,7 @@ unariseIdBinder us rho x = case repType (idType x) of in (us1, rho', ys) unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id] -unboxedTupleBindersFrom us x tys = zipWith (mkSysLocal fs) (uniqsFromSupply us) tys +unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys where fs = occNameFS (getOccName x) concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index f7a67ea8bd..531b13166c 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -37,7 +37,7 @@ import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, stripTicksTopT, stripTicksTopE ) import PprCore ( pprRules ) -import Type ( Type, substTy, mkTvSubst ) +import Type ( Type, substTy, mkTCvSubst ) import TcType ( tcSplitTyConApp_maybe ) import TysPrim ( anyTypeOfKind ) import Coercion @@ -50,7 +50,7 @@ import VarSet import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import NameSet import NameEnv -import Unify ( ruleMatchTyX, MatchEnv(..) ) +import Unify ( ruleMatchTyX ) import BasicTypes ( Activation, CompilerPhase, isActive, pprRuleName ) import StaticFlags ( opt_PprStyle_Debug ) import DynFlags ( DynFlags ) @@ -61,6 +61,7 @@ import Bag import Util import Data.List import Data.Ord +import Control.Monad ( guard ) {- Note [Overall plumbing for rules] @@ -561,7 +562,17 @@ matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es -- See Note [Unbound template type variables] where fake_ty = anyTypeOfKind kind - kind = Type.substTy (mkTvSubst in_scope tv_subst) (tyVarKind tmpl_var) + cv_subst = to_co_env id_subst + kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst)) + (tyVarKind tmpl_var) + + to_co_env env = foldVarEnv_Directly to_co emptyVarEnv env + to_co uniq expr env + | Just co <- exprToCoercion_maybe expr + = extendVarEnv_Directly env uniq co + + | otherwise + = env unbound var = pprPanic "Template variable unbound in rewrite rule" $ vcat [ ptext (sLit "Variable:") <+> ppr var @@ -779,19 +790,20 @@ match_co :: RuleMatchEnv -> Coercion -> Coercion -> Maybe RuleSubst -match_co renv subst (CoVarCo cv) co - = match_var renv subst cv (Coercion co) -match_co renv subst (Refl r1 ty1) co - = case co of - Refl r2 ty2 - | r1 == r2 -> match_ty renv subst ty1 ty2 - _ -> Nothing -match_co renv subst (TyConAppCo r1 tc1 cos1) co2 - = case co2 of - TyConAppCo r2 tc2 cos2 - | r1 == r2 && tc1 == tc2 - -> match_cos renv subst cos1 cos2 - _ -> Nothing +match_co renv subst co1 co2 + | Just cv <- getCoVar_maybe co1 + = match_var renv subst cv (Coercion co2) + | Just (ty1, r1) <- isReflCo_maybe co1 + = do { (ty2, r2) <- isReflCo_maybe co2 + ; guard (r1 == r2) + ; match_ty renv subst ty1 ty2 } +match_co renv subst co1 co2 + | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 + = case splitTyConAppCo_maybe co2 of + Just (tc2, cos2) + | tc1 == tc2 + -> match_cos renv subst cos1 cos2 + _ -> Nothing match_co _ _ _co1 _co2 -- Currently just deals with CoVarCo, TyConAppCo and Refl #ifdef DEBUG @@ -806,13 +818,11 @@ match_cos :: RuleMatchEnv -> [Coercion] -> Maybe RuleSubst match_cos renv subst (co1:cos1) (co2:cos2) = - case match_co renv subst co1 co2 of - Just subst' -> match_cos renv subst' cos1 cos2 - Nothing -> Nothing + do { subst' <- match_co renv subst co1 co2 + ; match_cos renv subst' cos1 cos2 } match_cos _ subst [] [] = Just subst match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing - ------------- rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv rnMatchBndr2 renv subst x1 x2 @@ -932,11 +942,11 @@ match_ty :: RuleMatchEnv -- We only want to replace (f T) with f', not (f Int). match_ty renv subst ty1 ty2 - = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2 + = do { tv_subst' + <- Unify.ruleMatchTyX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 ; return (subst { rs_tv_subst = tv_subst' }) } where tv_subst = rs_tv_subst subst - menv = ME { me_tmpls = rv_tmpls renv, me_env = rv_lcl renv } {- Note [Expanding variables] diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 1760b0e596..ff4613448e 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -31,13 +31,13 @@ import Literal ( litIsLifted ) import HscTypes ( ModGuts(..) ) import WwLib ( mkWorkerArgs ) import DataCon -import Coercion hiding( substTy, substCo ) +import Coercion hiding( substCo ) import Rules import Type hiding ( substTy ) import TyCon ( isRecursiveTyCon, tyConName ) import Id import PprCore ( pprParendExpr ) -import MkCore ( mkImpossibleExpr, sortQuantVars ) +import MkCore ( mkImpossibleExpr ) import Var import VarEnv import VarSet @@ -1643,7 +1643,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) -- return () -- And build the results - ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) + ; let spec_id = mkLocalIdOrCoVar spec_name (mkPiTypes spec_lam_args body_ty) -- See Note [Transfer strictness] `setIdStrictness` spec_str `setIdArity` count isId spec_lam_args @@ -1850,7 +1850,7 @@ callToPats env bndr_occs (Call _ args con_env) -- See Note [Shadowing] at the top (ktvs, ids) = partition isTyVar qvars - qvars' = sortQuantVars ktvs ++ map sanitise ids + qvars' = toposortTyVars ktvs ++ map sanitise ids -- Order into kind variables, type variables, term variables -- The kind of a type variable may mention a kind variable -- and the type of a term variable may mention a type variable @@ -2001,7 +2001,7 @@ argToPat _env _in_scope _val_env arg _arg_occ wildCardPat :: Type -> UniqSM (Bool, CoreArg) wildCardPat ty = do { uniq <- getUniqueM - ; let id = mkSysLocal (fsLit "sc") uniq ty + ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty ; return (False, varToCoreExpr id) } argsToPats :: ScEnv -> InScopeSet -> ValueEnv diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index cb671be7a5..d45b72a718 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -10,8 +10,8 @@ module Specialise ( specProgram, specUnfolding ) where #include "HsVersions.h" import Id -import TcType hiding( substTy, extendTvSubstList ) -import Type hiding( substTy, extendTvSubstList ) +import TcType hiding( substTy, extendTCvSubstList ) +import Type hiding( substTy, extendTCvSubstList ) import Coercion( Coercion ) import Module( Module, HasModule(..) ) import CoreMonad @@ -21,7 +21,7 @@ import VarSet import VarEnv import CoreSyn import Rules -import CoreUtils ( exprIsTrivial, applyTypeToArgs ) +import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) import UniqSupply import Name @@ -858,7 +858,7 @@ specExpr env (Var v) = return (specVar env v, emptyUDs) specExpr _ (Lit lit) = return (Lit lit, emptyUDs) specExpr env (Cast e co) = do { (e', uds) <- specExpr env e - ; return ((Cast e' (substCo env co)), uds) } + ; return ((mkCast e' (substCo env co)), uds) } specExpr env (Tick tickish body) = do { (body', uds) <- specExpr env body ; return (Tick (specTickish env tickish) body', uds) } @@ -959,7 +959,7 @@ specCase env scrut' case_bndr [(con, args, rhs)] sc_args' = filter is_flt_sc_arg args' clone_me bndr = do { uniq <- getUniqueM - ; return (mkUserLocal occ uniq ty loc) } + ; return (mkUserLocalOrCoVar occ uniq ty loc) } where name = idName bndr ty = idType bndr @@ -970,7 +970,7 @@ specCase env scrut' case_bndr [(con, args, rhs)] is_flt_sc_arg var = isId var && not (isDeadBinder var) && isDictTy var_ty - && not (tyVarsOfType var_ty `intersectsVarSet` arg_set) + && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set) where var_ty = idType var @@ -1182,15 +1182,15 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs , ppr rhs_ids, ppr n_dicts , ppr (idInlineActivation fn) ] - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here - (tyvars, theta, _) = tcSplitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta - inl_prag = idInlinePragma fn - inl_act = inlinePragmaActivation inl_prag - is_local = isLocalId fn + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + (tyvars, theta, _) = tcSplitSigmaTy fn_type + n_tyvars = length tyvars + n_dicts = length theta + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_local = isLocalId fn -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] @@ -1244,7 +1244,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs -- spec_tyvars = [a,c] -- ty_args = [t1,b,t3] spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] - env1 = extendTvSubstList env spec_tv_binds + env1 = extendTCvSubstList env spec_tv_binds (rhs_env, poly_tyvars) = substBndrs env1 [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] @@ -1775,7 +1775,7 @@ singleCall id tys dicts Map.singleton (CallKey tys) (dicts, call_fvs) } where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs - tys_fvs = tyVarsOfTypes (catMaybes tys) + tys_fvs = tyCoVarsOfTypes (catMaybes tys) -- The type args (tys) are guaranteed to be part of the dictionary -- types, because they are just the constrained types, -- and the dictionary is therefore sure to be bound @@ -1812,14 +1812,20 @@ mkCallUDs' env f args where _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts , ppr (map (interestingDict env) dicts)] - (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = closeOverKinds (tyVarsOfTypes theta) - n_tyvars = length tyvars - n_dicts = length theta + (tyvars, theta, _) = tcSplitSigmaTy (idType f) + constrained_tyvars = tyCoVarsOfTypes theta + n_tyvars = length tyvars + n_dicts = length theta - spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args] + spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args] dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] + -- ignores Coercion arguments + type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)] + type_zip tvs (Coercion _ : args) = type_zip tvs args + type_zip (tv:tvs) (Type ty : args) = (tv, ty) : type_zip tvs args + type_zip _ _ = [] + mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars = Just ty | otherwise = Nothing @@ -2131,9 +2137,9 @@ mapAndCombineSM f (x:xs) = do (y, uds1) <- f x (ys, uds2) <- mapAndCombineSM f xs return (y:ys, uds1 `plusUDs` uds2) -extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv -extendTvSubstList env tv_binds - = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds } +extendTCvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv +extendTCvSubstList env tv_binds + = env { se_subst = CoreSubst.extendTCvSubstList (se_subst env) tv_binds } substTy :: SpecEnv -> Type -> Type substTy env ty = CoreSubst.substTy (se_subst env) ty @@ -2175,7 +2181,7 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr newDictBndr env b = do { uniq <- getUniqueM ; let n = idName b ty' = substTy env (idType b) - ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) } + ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) } newSpecIdSM :: Id -> Type -> SpecM Id -- Give the new Id a similar occurrence name to the old one @@ -2183,7 +2189,7 @@ newSpecIdSM old_id new_ty = do { uniq <- getUniqueM ; let name = idName old_id new_occ = mkSpecOcc (nameOccName name) - new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + new_id = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name) ; return new_id } {- diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index ef5dd9237a..f95ca60289 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -20,7 +20,6 @@ import Literal ( literalType ) import Maybes import Name ( getSrcLoc ) import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) -import TypeRep import Type import TyCon import Util diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index 5836bfd6af..49368cd1db 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -31,7 +31,7 @@ import Coercion ( Coercion, coVarsOfCo ) import FamInstEnv import Util import Maybes ( isJust ) -import TysWiredIn ( unboxedPairDataCon ) +import TysWiredIn import TysPrim ( realWorldStatePrimTy ) import ErrUtils ( dumpIfSet_dyn ) import Name ( getName, stableNameCmp ) @@ -296,7 +296,7 @@ io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool -- See Note [IO hack in the demand analyser] io_hack_reqd scrut con bndrs | (bndr:_) <- bndrs - , con == unboxedPairDataCon + , con == tupleDataCon Unboxed 2 , idType bndr `eqType` realWorldStatePrimTy , (fun, _) <- collectArgs scrut = case fun of diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index 02ef6ca4c2..1ee3e1b6ac 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -14,19 +14,16 @@ module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs import CoreSyn import CoreUtils ( exprType, mkCast ) -import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, - setIdUnfolding, - setIdInfo, idOneShotInfo, setIdOneShotInfo - ) +import Id import IdInfo ( vanillaIdInfo ) import DataCon import Demand -import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID ) +import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID, mkCoreUbxTup ) import MkId ( voidArgId, voidPrimId ) import TysPrim ( voidPrimTy ) import TysWiredIn ( tupleDataCon ) import Type -import Coercion hiding ( substTy, substTyVarBndr ) +import Coercion import FamInstEnv import BasicTypes ( Boxity(..), OneShotInfo(..), worstOneShot ) import Literal ( absentLiteralOf ) @@ -38,6 +35,7 @@ import Util import Outputable import DynFlags import FastString +import ListSetOps {- ************************************************************************ @@ -132,7 +130,7 @@ mkWwBodies :: DynFlags mkWwBodies dflags fam_envs fun_ty demands res_info one_shots = do { let arg_info = demands `zip` (one_shots ++ repeat NoOneShotInfo) all_one_shots = foldr (worstOneShot . snd) OneShotLam arg_info - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info + ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTCvSubst fun_ty arg_info ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args -- Do CPR w/w. See Note [Always do CPR w/w] @@ -291,7 +289,7 @@ the \x to get what we want. -- It chomps bites off foralls, arrows, newtypes -- and keeps repeating that until it's satisfied the supplied arity -mkWWargs :: TvSubst -- Freshening substitution to apply to the type +mkWWargs :: TCvSubst -- Freshening substitution to apply to the type -- See Note [Freshen type variables] -> Type -- The type of the function -> [(Demand,OneShotInfo)] -- Demands and one-shot info for value arguments @@ -324,7 +322,7 @@ mkWWargs subst fun_ty arg_info <- mkWWargs subst' fun_ty' arg_info ; return (tv' : wrap_args, Lam tv' . wrap_fn_args, - work_fn_args . (`App` Type (mkTyVarTy tv')), + work_fn_args . (`mkTyApps` [mkTyVarTy tv']), res_ty) } | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty @@ -352,7 +350,7 @@ applyToVars vars fn = mkVarApps fn vars mk_wrap_arg :: Unique -> Type -> Demand -> OneShotInfo -> Id mk_wrap_arg uniq ty dmd one_shot - = mkSysLocal (fsLit "w") uniq ty + = mkSysLocalOrCoVar (fsLit "w") uniq ty `setIdDemandInfo` dmd `setIdOneShotInfo` one_shot @@ -366,7 +364,7 @@ which is obviously wrong. Type variables can can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a). But type variables *are* mentioned in <blah>, so we must substitute. -That's why we carry the TvSubst through mkWWargs +That's why we carry the TCvSubst through mkWWargs ************************************************************************ * * @@ -541,7 +539,7 @@ deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Ty -- co :: ty ~ rep_ty deepSplitProductType_maybe fam_envs ty | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkReflCo Representational ty, ty) + `orElse` (mkRepReflCo ty, ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 , Just con <- isDataProductTyCon_maybe tc , not (isClassTyCon tc) -- See Note [Do not unpack class dictionaries] @@ -554,13 +552,13 @@ deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe (DataCon, [Type -- co :: ty ~ rep_ty deepSplitCprType_maybe fam_envs con_tag ty | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkReflCo Representational ty, ty) + `orElse` (mkRepReflCo ty, ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 , isDataTyCon tc , let cons = tyConDataCons tc , cons `lengthAtLeast` con_tag -- This might not be true if we import the -- type constructor via a .hs-bool file (#8743) - , let con = cons !! (con_tag - fIRST_TAG) + , let con = cons `getNth` (con_tag - fIRST_TAG) = Just (con, tc_args, dataConInstArgTys con tc_args, co) deepSplitCprType_maybe _ _ _ = Nothing @@ -569,9 +567,6 @@ findTypeShape :: FamInstEnvs -> Type -> TypeShape -- The data type TypeShape is defined in Demand -- See Note [Trimming a demand to a type] in Demand findTypeShape fam_envs ty - | Just (_, ty') <- splitForAllTy_maybe ty - = findTypeShape fam_envs ty' - | Just (tc, tc_args) <- splitTyConApp_maybe ty , Just con <- isDataProductTyCon_maybe tc = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args) @@ -579,6 +574,9 @@ findTypeShape fam_envs ty | Just (_, res) <- splitFunTy_maybe ty = TsFun (findTypeShape fam_envs res) + | Just (_, ty') <- splitForAllTy_maybe ty + = findTypeShape fam_envs ty' + | Just (_, ty') <- topNormaliseType_maybe fam_envs ty = findTypeShape fam_envs ty' @@ -651,13 +649,12 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co) -- Worker: case ( ...body... ) of C a b -> (# a, b #) = do { (work_uniq : uniqs) <- getUniquesM ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys) - ubx_tup_con = tupleDataCon Unboxed (length arg_tys) ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkConApp2 ubx_tup_con arg_tys args + ubx_tup_app = mkCoreUbxTup arg_tys (map varToCoreExpr args) con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co ; return (True - , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)] + , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)] , \ body -> mkUnpackCase body co work_uniq data_con args ubx_tup_app , ubx_tup_ty ) } @@ -775,4 +772,4 @@ sanitiseCaseBndr :: Id -> Id sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo mk_ww_local :: Unique -> Type -> Id -mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty +mk_ww_local uniq ty = mkSysLocalOrCoVar (fsLit "ww") uniq ty diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 26db100726..07a06d73ec 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -5,7 +5,6 @@ module FamInst ( FamInstEnvs, tcGetFamInstEnvs, checkFamInstConsistency, tcExtendLocalFamInstEnv, - tcLookupFamInst, tcLookupDataFamInst, tcLookupDataFamInst_maybe, tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, newFamInst, @@ -17,12 +16,13 @@ module FamInst ( import HscTypes import FamInstEnv import InstEnv( roughMatchTcs ) -import Coercion hiding ( substTy ) +import Coercion import TcEvidence import LoadIface import TcRnMonad import SrcLoc import TyCon +import TcType import CoAxiom import DynFlags import Module @@ -34,15 +34,20 @@ import RdrName import DataCon ( dataConName ) import Maybes import Type -import TypeRep +import TyCoRep import TcMType import Name +import Pair import Panic import VarSet import Control.Monad import Data.Map (Map) import qualified Data.Map as Map -import Control.Arrow ( first, second ) + +#if __GLASGOW_HASKELL__ < 709 +import Prelude hiding ( and ) +import Data.Foldable ( and ) +#endif #include "HsVersions.h" @@ -64,15 +69,18 @@ newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst -- Called from the vectoriser monad too, hence the rather general type newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) = do { (subst, tvs') <- freshenTyVarBndrs tvs + ; (subst, cvs') <- freshenCoVarBndrsX subst cvs ; return (FamInst { fi_fam = tyConName fam_tc , fi_flavor = flavor , fi_tcs = roughMatchTcs lhs , fi_tvs = tvs' + , fi_cvs = cvs' , fi_tys = substTys subst lhs , fi_rhs = substTy subst rhs , fi_axiom = axiom }) } where CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs , cab_lhs = lhs , cab_rhs = rhs } = coAxiomSingleBranch axiom @@ -193,36 +201,8 @@ getFamInsts hpt_fam_insts mod * * ************************************************************************ -Look up the instance tycon of a family instance. - -The match may be ambiguous (as we know that overlapping instances have -identical right-hand sides under overlapping substitutions - see -'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used -for matching must be equal to or be more specific than those of the family -instance declaration. We pick one of the matches in case of ambiguity; as -the right-hand sides are identical under the match substitution, the choice -does not matter. - -Return the instance tycon and its type instance. For example, if we have - - tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int') - -then we have a coercion (ie, type instance of family instance coercion) - - :Co:R42T Int :: T [Int] ~ :R42T Int - -which implies that :R42T was declared as 'data instance T [a]'. -} -tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch -tcLookupFamInst fam_envs tycon tys - | not (isOpenFamilyTyCon tycon) - = Nothing - | otherwise - = case lookupFamInstEnv fam_envs tycon tys of - match : _ -> Just match - [] -> Nothing - -- | If @co :: T ts ~ rep_ty@ then: -- -- > instNewTyCon_maybe T ts = Just (rep_ty, co) @@ -230,8 +210,7 @@ tcLookupFamInst fam_envs tycon tys -- Checks for a newtype, and for being saturated -- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) -tcInstNewTyCon_maybe tc tys = fmap (second TcCoercion) $ - instNewTyCon_maybe tc tys +tcInstNewTyCon_maybe = instNewTyCon_maybe -- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if -- there is no data family to unwrap. @@ -243,21 +222,24 @@ tcLookupDataFamInst fam_inst_envs tc tc_args <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args = (rep_tc, rep_args, co) | otherwise - = (tc, tc_args, mkReflCo Representational (mkTyConApp tc tc_args)) + = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args)) tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType] -> Maybe (TyCon, [TcType], Coercion) -- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a) --- and returns a coercion between the two: co :: F [a] ~R FList a +-- and returns a coercion between the two: co :: F [a] ~R FList a. tcLookupDataFamInst_maybe fam_inst_envs tc tc_args | isDataFamilyTyCon tc , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args - , FamInstMatch { fim_instance = rep_fam - , fim_tys = rep_args } <- match - , let ax = famInstAxiom rep_fam - rep_tc = dataFamInstRepTyCon rep_fam + , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax + , fi_cvs = cvs }) + , fim_tys = rep_args + , fim_cos = rep_cos } <- match + , let rep_tc = dataFamInstRepTyCon rep_fam co = mkUnbranchedAxInstCo Representational ax rep_args - = Just (rep_tc, rep_args, co) + (mkCoVarCos cvs) + = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv + Just (rep_tc, rep_args, co) | otherwise = Nothing @@ -266,7 +248,7 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args -- potentially looking through newtype instances. -- -- It is only used by the type inference engine (specifically, when --- soliving 'Coercible' instances), and hence it is careful to unwrap +-- solving representational equality), and hence it is careful to unwrap -- only if the relevant data constructor is in scope. That's why -- it get a GlobalRdrEnv argument. -- @@ -284,7 +266,7 @@ tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs -> Maybe (TcCoercion, Type) tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty -- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe - = fmap (first TcCoercion) $ topNormaliseTypeX_maybe stepper ty + = topNormaliseTypeX_maybe stepper ty where stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance @@ -429,8 +411,8 @@ makeInjectivityErrors fi_ax axiom inj conflicts rhs = coAxBranchRHS axiom are_conflicts = not $ null conflicts - unused_inj_tvs = unusedInjTvsInRHS inj lhs rhs - inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs + unused_inj_tvs = unusedInjTvsInRHS (coAxiomTyCon fi_ax) inj lhs rhs + inj_tvs_unused = not $ and (isEmptyVarSet <$> unused_inj_tvs) tf_headed = isTFHeaded rhs bare_variables = bareTvInRHSViolated lhs rhs wrong_bare_rhs = not $ null bare_variables @@ -448,8 +430,8 @@ makeInjectivityErrors fi_ax axiom inj conflicts -- | Return a list of type variables that the function is injective in and that -- do not appear on injective positions in the RHS of a family instance --- declaration. -unusedInjTvsInRHS :: [Bool] -> [Type] -> Type -> TyVarSet +-- declaration. The returned Pair includes invisible vars followed by visible ones +unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet -- INVARIANT: [Bool] list contains at least one True value -- See Note [Verifying injectivity annotation]. This function implements fourth -- check described there. @@ -457,37 +439,46 @@ unusedInjTvsInRHS :: [Bool] -> [Type] -> Type -> TyVarSet -- attempt to unify equation with itself. We would reject exactly the same -- equations but this method gives us more precise error messages by returning -- precise names of variables that are not mentioned in the RHS. -unusedInjTvsInRHS injList lhs rhs = - injLHSVars `minusVarSet` injRhsVars +unusedInjTvsInRHS tycon injList lhs rhs = + (`minusVarSet` injRhsVars) <$> injLHSVars where -- set of type and kind variables in which type family is injective - injLHSVars = tyVarsOfTypes (filterByList injList lhs) + (invis_pairs, vis_pairs) + = partitionInvisibles tycon snd (zipEqual "unusedInjTvsInRHS" injList lhs) + invis_lhs = uncurry filterByList $ unzip invis_pairs + vis_lhs = uncurry filterByList $ unzip vis_pairs + + invis_vars = tyCoVarsOfTypes invis_lhs + Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs + injLHSVars + = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars') + vis_vars -- set of type variables appearing in the RHS on an injective position. -- For all returned variables we assume their associated kind variables -- also appear in the RHS. - injRhsVars = closeOverKinds $ collectInjVars rhs + injRhsVars = collectInjVars rhs -- Collect all type variables that are either arguments to a type -- constructor or to injective type families. collectInjVars :: Type -> VarSet - collectInjVars ty | Just (ty1, ty2) <- splitAppTy_maybe ty - = collectInjVars ty1 `unionVarSet` collectInjVars ty2 collectInjVars (TyVarTy v) - = unitVarSet v + = unitVarSet v `unionVarSet` collectInjVars (tyVarKind v) collectInjVars (TyConApp tc tys) | isTypeFamilyTyCon tc = collectInjTFVars tys (familyTyConInjectivityInfo tc) | otherwise = mapUnionVarSet collectInjVars tys collectInjVars (LitTy {}) = emptyVarSet - collectInjVars (FunTy arg res) + collectInjVars (ForAllTy (Anon arg) res) = collectInjVars arg `unionVarSet` collectInjVars res collectInjVars (AppTy fun arg) = collectInjVars fun `unionVarSet` collectInjVars arg -- no forall types in the RHS of a type family collectInjVars (ForAllTy _ _) = panic "unusedInjTvsInRHS.collectInjVars" + collectInjVars (CastTy ty _) = collectInjVars ty + collectInjVars (CoercionTy {}) = emptyVarSet collectInjTFVars :: [Type] -> Injectivity -> VarSet collectInjTFVars _ NotInjective @@ -559,15 +550,15 @@ conflictInjInstErr conflictingEqns errorBuilder tyfamEqn -- | Build error message for equation with injective type variables unused in -- the RHS. -unusedInjectiveVarsErr :: TyVarSet -> InjErrorBuilder -> CoAxBranch +unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch -> (SDoc, SrcSpan) -unusedInjectiveVarsErr unused_tyvars errorBuilder tyfamEqn - = errorBuilder (injectivityErrorHerald True $$ unusedInjectiveVarsErr) +unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn + = errorBuilder (injectivityErrorHerald True $$ msg) [tyfamEqn] where - tvs = varSetElemsKvsFirst unused_tyvars - has_types = any isTypeVar tvs - has_kinds = any isKindVar tvs + tvs = varSetElemsWellScoped (invis_vars `unionVarSet` vis_vars) + has_types = not $ isEmptyVarSet vis_vars + has_kinds = not $ isEmptyVarSet invis_vars doc = sep [ what <+> text "variable" <> plural tvs <+> pprQuotedList tvs @@ -576,14 +567,13 @@ unusedInjectiveVarsErr unused_tyvars errorBuilder tyfamEqn (True, True) -> text "Type and kind" (True, False) -> text "Type" (False, True) -> text "Kind" - (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ - ppr unused_tyvars + (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs print_kinds_info = sdocWithDynFlags $ \ dflags -> if has_kinds && not (gopt Opt_PrintExplicitKinds dflags) then text "(enabling -fprint-explicit-kinds might help)" else empty - unusedInjectiveVarsErr = doc $$ print_kinds_info $$ - text "In the type family equation:" + msg = doc $$ print_kinds_info $$ + text "In the type family equation:" -- | Build error message for equation that has a type family call at the top -- level of RHS diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index fd347a1c15..3e9e9fd07f 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -37,6 +37,13 @@ import FastString import Pair ( Pair(..) ) import Data.List ( nubBy ) import Data.Maybe +import Data.Foldable ( fold ) + +#if __GLASGOW_HASKELL__ < 709 +import Prelude hiding ( and ) +import Control.Applicative ( (<$>) ) +import Data.Foldable ( and ) +#endif {- ************************************************************************ @@ -104,8 +111,8 @@ data FunDepEqn loc -- Non-empty only for FunDepEqns arising from instance decls , fd_eqs :: [Pair Type] -- Make these pairs of types equal - , fd_pred1 :: PredType -- The FunDepEqn arose from - , fd_pred2 :: PredType -- combining these two constraints + , fd_pred1 :: PredType -- The FunDepEqn arose from + , fd_pred2 :: PredType -- combining these two constraints , fd_loc :: loc } {- @@ -185,7 +192,7 @@ improveFromAnother _ _ _ = [] pprEquation :: FunDepEqn a -> SDoc pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 + nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 | Pair t1 t2 <- pairs])] improveFromInstEnv :: InstEnvs @@ -221,10 +228,10 @@ improveFromInstEnv inst_env mk_loc pred improveFromInstEnv _ _ _ = [] -improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class - -> ClsInst -- An instance template - -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate - -> [([TyVar], [Pair Type])] -- Empty or singleton +improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class + -> ClsInst -- An instance template + -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -> [([TyCoVar], [Pair Type])] -- Empty or singleton improveClsFD clas_tvs fd (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) @@ -295,7 +302,7 @@ improveClsFD clas_tvs fd -- equation in there is useful) meta_tvs = [ setVarType tv (substTy subst (varType tv)) - | tv <- qtvs, tv `notElemTvSubst` subst ] + | tv <- qtvs, tv `notElemTCvSubst` subst ] -- meta_tvs are the quantified type variables -- that have not been substituted out -- @@ -318,8 +325,8 @@ improveClsFD clas_tvs fd (ltys2, rtys2) = instFD fd clas_tvs tys_actual {- -************************************************************************ -* * +%************************************************************************ +%* * The Coverage condition for instance declarations * * ************************************************************************ @@ -368,21 +375,21 @@ checkInstCoverage be_liberal clas theta inst_taus where (tyvars, fds) = classTvsFds clas fundep_ok fd - | isEmptyVarSet undetermined_tvs = IsValid - | otherwise = NotValid msg + | and (isEmptyVarSet <$> undetermined_tvs) = IsValid + | otherwise = NotValid msg where (ls,rs) = instFD fd tyvars inst_taus - ls_tvs = tyVarsOfTypes ls - rs_tvs = tyVarsOfTypes rs + ls_tvs = tyCoVarsOfTypes ls + rs_tvs = splitVisVarsOfTypes rs undetermined_tvs | be_liberal = liberal_undet_tvs | otherwise = conserv_undet_tvs - liberal_undet_tvs = rs_tvs `minusVarSet`oclose theta (closeOverKinds ls_tvs) - conserv_undet_tvs = rs_tvs `minusVarSet` closeOverKinds ls_tvs - -- closeOverKinds: see Note [Closing over kinds in coverage] + closed_ls_tvs = oclose theta ls_tvs + liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs + conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs - undet_list = varSetElemsKvsFirst undetermined_tvs + undet_list = varSetElemsWellScoped (fold undetermined_tvs) msg = vcat [ -- text "ls_tvs" <+> ppr ls_tvs -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) @@ -404,9 +411,10 @@ checkInstCoverage be_liberal clas theta inst_taus <+> pprQuotedList rs ] , ptext (sLit "Un-determined variable") <> plural undet_list <> colon <+> pprWithCommas ppr undet_list - , ppWhen (all isKindVar undet_list) $ + , ppWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ ptext (sLit "(Use -fprint-explicit-kinds to see the kind variables in the types)") - , ppWhen (not be_liberal && isEmptyVarSet liberal_undet_tvs) $ + , ppWhen (not be_liberal && + and (isEmptyVarSet <$> liberal_undet_tvs)) $ ptext (sLit "Using UndecidableInstances might help") ] {- Note [Closing over kinds in coverage] @@ -471,7 +479,8 @@ closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all the variables free in (Succ {k3} ab). Bottom line: - * closeOverKinds on initial seeds (in checkInstCoverage) + * closeOverKinds on initial seeds (done automatically + by tyCoVarsOfTypes in checkInstCoverage) * and closeOverKinds whenever extending those seeds (in oclose) Note [The liberal coverage condition] @@ -493,7 +502,7 @@ oclose is used (only) when checking the coverage condition for an instance declaration -} -oclose :: [PredType] -> TyVarSet -> TyVarSet +oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet -- See Note [The liberal coverage condition] oclose preds fixed_tvs | null tv_fds = fixed_tvs -- Fast escape hatch for common case. @@ -506,8 +515,8 @@ oclose preds fixed_tvs | otherwise = fixed_tvs -- closeOverKinds: see Note [Closing over kinds in coverage] - tv_fds :: [(TyVarSet,TyVarSet)] - tv_fds = [ (tyVarsOfTypes ls, tyVarsOfTypes rs) + tv_fds :: [(TyCoVarSet,TyCoVarSet)] + tv_fds = [ (tyCoVarsOfTypes ls, tyCoVarsOfTypes rs) | pred <- preds , (ls, rs) <- determined pred ] @@ -593,10 +602,11 @@ checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls = False | otherwise = case tcUnifyTys bind_fn ltys1 ltys2 of - Nothing -> False - Just subst -> isNothing $ -- Bogus legacy test (Trac #10675) - -- See Note [Bogus consistency check] - tcUnifyTys bind_fn (substTys subst rtys1) (substTys subst rtys2) + Nothing -> False + Just subst + -> isNothing $ -- Bogus legacy test (Trac #10675) + -- See Note [Bogus consistency check] + tcUnifyTys bind_fn (substTys subst rtys1) (substTys subst rtys2) where trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 6e918edf2f..bd27a1812d 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -6,13 +6,12 @@ The @Inst@ type: dictionaries or method instances -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MultiWayIf #-} module Inst ( deeplySkolemise, deeplyInstantiate, instCall, instDFunType, instStupidTheta, newWanted, newWanteds, - emitWanted, emitWanteds, newOverloadedLit, mkOverLit, @@ -23,15 +22,14 @@ module Inst ( tcSyntaxName, -- Simple functions over evidence variables - tyVarsOfWC, tyVarsOfBag, - tyVarsOfCt, tyVarsOfCts, - tyVarsOfCtList, tyVarsOfCtsList, + tyCoVarsOfWC, + tyCoVarsOfCt, tyCoVarsOfCts, ) where #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} TcUnify( unifyType ) +import {-# SOURCE #-} TcUnify( unifyType, noThing ) import FastString import HsSyn @@ -40,6 +38,8 @@ import TcRnMonad import TcEnv import TcEvidence import InstEnv +import DataCon ( dataConWrapId ) +import TysWiredIn ( heqDataCon ) import FunDeps import TcMType import Type @@ -52,16 +52,13 @@ import Id import Name import Var ( EvVar ) import VarEnv -import VarSet import PrelNames import SrcLoc import DynFlags -import Bag import Util import Outputable import Control.Monad( unless ) import Data.Maybe( isJust ) -import FV {- ************************************************************************ @@ -71,28 +68,6 @@ import FV ************************************************************************ -} -newWanted :: CtOrigin -> PredType -> TcM CtEvidence -newWanted orig pty - = do loc <- getCtLocM orig - v <- newEvVar pty - return $ CtWanted { ctev_evar = v - , ctev_pred = pty - , ctev_loc = loc } - -newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] -newWanteds orig = mapM (newWanted orig) - -emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar] -emitWanteds origin theta = mapM (emitWanted origin) theta - -emitWanted :: CtOrigin -> TcPredType -> TcM EvVar -emitWanted origin pred - = do { loc <- getCtLocM origin - ; ev <- newEvVar pred - ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc } - ; return ev } - newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) -- Used when Name is the wired-in name for a wired-in class method, -- so the caller knows its type for sure, which should be of form @@ -107,12 +82,11 @@ newMethodFromName origin name inst_ty -- meant to find whatever thing is in scope, and that may -- be an ordinary function. - ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id) - (the_tv:rest) = tvs - subst = zipOpenTvSubst [the_tv] [inst_ty] + ; let ty = piResultTy (idType id) inst_ty + (theta, _caller_knows_this) = tcSplitPhiTy ty + ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) + instCall origin [inst_ty] theta - ; wrap <- ASSERT( null rest && isSingleton theta ) - instCall origin [inst_ty] (substTheta subst theta) ; return (mkHsWrap wrap (HsVar (noLoc id))) } {- @@ -150,7 +124,10 @@ ToDo: this eta-abstraction plays fast and loose with termination, deeplySkolemise :: TcSigmaType - -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType) + -> TcM ( HsWrapper + , [TyVar] -- all skolemised variables + , [EvVar] -- all "given"s + , TcRhoType) deeplySkolemise ty | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty @@ -203,6 +180,16 @@ deeplyInstantiate orig ty Instantiating a call * * ************************************************************************ + +Note [Handling boxed equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The solver deals entirely in terms of unboxed (primitive) equality. +There should never be a boxed Wanted equality. Ever. But, what if +we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality +is boxed, so naive treatment here would emit a boxed Wanted equality. + +So we simply check for this case and make the right boxing of evidence. + -} ---------------- @@ -231,25 +218,33 @@ instCallConstraints orig preds ; return (mkWpEvApps evs) } where go pred - | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut - = do { co <- unifyType ty1 ty2 + | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 + = do { co <- unifyType noThing ty1 ty2 ; return (EvCoercion co) } + + -- Try short-cut #2 + | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred + , tc `hasKey` heqTyConKey + = do { co <- unifyType noThing ty1 ty2 + ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) } + | otherwise - = do { ev_var <- emitWanted orig pred - ; return (EvId ev_var) } + = emitWanted orig pred -instDFunType :: DFunId -> [DFunInstType] -> TcM ([TcType], TcThetaType) +instDFunType :: DFunId -> [DFunInstType] + -> TcM ( [TcType] -- instantiated argument types + , TcThetaType ) -- instantiated constraint -- See Note [DFunInstType: instantiating types] in InstEnv instDFunType dfun_id dfun_inst_tys - = do { (subst, inst_tys) <- go (mkTopTvSubst []) dfun_tvs dfun_inst_tys + = do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys ; return (inst_tys, substTheta subst dfun_theta) } where (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id) - go :: TvSubst -> [TyVar] -> [DFunInstType] -> TcM (TvSubst, [TcType]) + go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) go subst [] [] = return (subst, []) go subst (tv:tvs) (Just ty : mb_tys) - = do { (subst', tys) <- go (extendTvSubst subst tv ty) tvs mb_tys + = do { (subst', tys) <- go (extendTCvSubst subst tv ty) tvs mb_tys ; return (subst', ty : tys) } go subst (tv:tvs) (Nothing : mb_tys) = do { (subst', tv') <- tcInstTyVarX subst tv @@ -376,8 +371,8 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do std_id <- tcLookupId std_nm let -- C.f. newMethodAtLoc - ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - sigma1 = substTyWith [tv] [ty] tau + ([tv], _, tau) = tcSplitSigmaTy (idType std_id) + sigma1 = substTyWith [tv] [ty] tau -- Actually, the "tau-type" might be a sigma-type in the -- case of locally-polymorphic methods. @@ -393,7 +388,7 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv -> TcRn (TidyEnv, SDoc) syntaxNameCtxt name orig ty tidy_env - = do { inst_loc <- getCtLocM orig + = do { inst_loc <- getCtLocM orig (Just TypeLevel) ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name) <+> ptext (sLit "(needed by a syntactic construct)") , nest 2 (ptext (sLit "has the required type:") @@ -478,21 +473,6 @@ addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) -- If overwrite_inst, then we can overwrite a direct match addLocalInst (home_ie, my_insts) ispec = do { - -- Instantiate the dfun type so that we extend the instance - -- envt with completely fresh template variables - -- This is important because the template variables must - -- not overlap with anything in the things being looked up - -- (since we do unification). - -- - -- We use tcInstSkolType because we don't want to allocate fresh - -- *meta* type variables. - -- - -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because - -- these variables must be bindable by tcUnifyTys. See - -- the call to tcUnifyTys in InstEnv, and the special - -- treatment that instanceBindFun gives to isOverlappableTyVar - -- This is absurdly delicate. - -- Load imported instances, so that we report -- duplicates correctly @@ -615,67 +595,3 @@ addClsInstsErr herald ispecs -- The sortWith just arranges that instances are dislayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users - -{- -************************************************************************ -* * - Simple functions over evidence variables -* * -************************************************************************ --} - ----------------- Getting free tyvars ------------------------- - --- | Returns free variables of constraints as a non-deterministic set -tyVarsOfCt :: Ct -> TcTyVarSet -tyVarsOfCt = runFVSet . tyVarsOfCtAcc - --- | Returns free variables of constraints as a deterministically ordered. --- list. See Note [Deterministic FV] in FV. -tyVarsOfCtList :: Ct -> [TcTyVar] -tyVarsOfCtList = runFVList . tyVarsOfCtAcc - --- | Returns free variables of constraints as a composable FV computation. --- See Note [Deterministic FV] in FV. -tyVarsOfCtAcc :: Ct -> FV -tyVarsOfCtAcc (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) - = tyVarsOfTypeAcc xi `unionFV` oneVar tv -tyVarsOfCtAcc (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) - = tyVarsOfTypesAcc tys `unionFV` oneVar fsk -tyVarsOfCtAcc (CDictCan { cc_tyargs = tys }) = tyVarsOfTypesAcc tys -tyVarsOfCtAcc (CIrredEvCan { cc_ev = ev }) = tyVarsOfTypeAcc (ctEvPred ev) -tyVarsOfCtAcc (CHoleCan { cc_ev = ev }) = tyVarsOfTypeAcc (ctEvPred ev) -tyVarsOfCtAcc (CNonCanonical { cc_ev = ev }) = tyVarsOfTypeAcc (ctEvPred ev) - --- | Returns free variables of a bag of constraints as a non-deterministic --- set. See Note [Deterministic FV] in FV. -tyVarsOfCts :: Cts -> TcTyVarSet -tyVarsOfCts = runFVSet . tyVarsOfCtsAcc - --- | Returns free variables of a bag of constraints as a deterministically --- odered list. See Note [Deterministic FV] in FV. -tyVarsOfCtsList :: Cts -> [TcTyVar] -tyVarsOfCtsList = runFVList . tyVarsOfCtsAcc - --- | Returns free variables of a bag of constraints as a composable FV --- computation. See Note [Deterministic FV] in FV. -tyVarsOfCtsAcc :: Cts -> FV -tyVarsOfCtsAcc = foldrBag (unionFV . tyVarsOfCtAcc) noVars - - -tyVarsOfWC :: WantedConstraints -> TyVarSet --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol }) - = tyVarsOfCts simple `unionVarSet` - tyVarsOfBag tyVarsOfImplic implic `unionVarSet` - tyVarsOfCts insol - -tyVarsOfImplic :: Implication -> TyVarSet --- Only called on *zonked* things, hence no need to worry about flatten-skolems -tyVarsOfImplic (Implic { ic_skols = skols - , ic_given = givens, ic_wanted = wanted }) - = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens)) - `delVarSetList` skols - -tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet -tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 47ee88cde3..f078403e68 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -89,7 +89,8 @@ tcProc pat cmd exp_ty ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ tcCmdTop cmd_env cmd (unitTy, res_ty) - ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) + ; let res_co = mkTcTransCo co + (mkTcAppCo co1 (mkTcNomReflCo res_ty)) ; return (pat', cmd', res_co) } {- @@ -160,14 +161,14 @@ tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' } tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if - = do { pred_ty <- newFlexiTyVarTy openTypeKind + = do { pred_ty <- newOpenFlexiTyVarTy -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty - ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty)) + ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) (ptext (sLit "Predicate type of `ifThenElse' depends on result type")) ; fun' <- tcSyntaxOp IfOrigin fun if_ty ; pred' <- tcMonoExpr pred pred_ty @@ -194,7 +195,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newFlexiTyVarTy openTypeKind + do { arg_ty <- newOpenFlexiTyVarTy ; let fun_ty = mkCmdArrTy env arg_ty res_ty ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) @@ -221,7 +222,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newFlexiTyVarTy openTypeKind + do { arg_ty <- newOpenFlexiTyVarTy ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) ; arg' <- tcMonoExpr arg arg_ty ; return (HsCmdApp fun' arg') } @@ -270,7 +271,7 @@ tc_cmd env -- Do notation tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) - = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack + = do { co <- unifyType noThing unitTy cmd_stk -- Expecting empty argument stack ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty ; return (mkHsCmdCast co (HsCmdDo (L l stmts') res_ty)) } @@ -292,7 +293,8 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args - ; let e_ty = mkForAllTy alphaTyVar $ -- We use alphaTyVar for 'w' + -- We use alphaTyVar for 'w' + ; let e_ty = mkNamedForAllTy alphaTyVar Invisible $ mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcPolyExpr expr e_ty @@ -408,7 +410,7 @@ mkPairTy :: Type -> Type -> Type mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] arrowTyConKind :: Kind -- *->*->* -arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind +arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind {- ************************************************************************ diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 1254b786c2..8c577d85a7 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -212,7 +212,8 @@ tcHsBootSigs (ValBindsOut binds sigs) tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames where f (L _ name) - = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty + = do { sigma_ty <- solveEqualities $ + tcHsSigWcType (FunSigCtxt name False) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) @@ -252,7 +253,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside -- Consider ?x = 4 -- ?y = ?x + 1 tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr) - = do { ty <- newFlexiTyVarTy openTypeKind + = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcMonoExpr expr ty @@ -262,7 +263,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside -- Coerces a `t` into a dictionry for `IP "x" t`. -- co : t -> IP "x" t - toDict ipClass x ty = HsWrap $ mkWpCastR $ TcCoercion $ + toDict ipClass x ty = HsWrap $ mkWpCastR $ wrapIP $ mkClassPred ipClass [x,ty] {- @@ -387,7 +388,7 @@ tcValBinds top_lvl binds sigs thing_inside ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] ; return (extra_binds, thing) } - ; return (binds' ++ extra_binds', thing) }} + ; return (binds' ++ extra_binds', thing) }} where patsyns = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds] patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds] @@ -719,7 +720,7 @@ mkExport prag_fn qtvs theta mono_info@(poly_name, mb_sig, mono_id) -- See Note [Impedence matching] -- NB: we have already done checkValidType, including an ambiguity check, -- on the type; either when we checked the sig or in mkInferredPolyId - ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty + ; let sel_poly_ty = mkInvSigmaTy qtvs theta mono_ty poly_ty = idType poly_id ; wrap <- if sel_poly_ty `eqType` poly_ty then return idHsWrapper -- Fast path; also avoids complaint when we infer @@ -756,10 +757,10 @@ mkInferredPolyId qtvs inferred_theta poly_name mb_sig mono_ty -- it in the call to tcSubType below ; (my_tvs, theta') <- chooseInferredQuantifiers - inferred_theta (tyVarsOfType mono_ty') mb_sig + inferred_theta (tyCoVarsOfType mono_ty') mb_sig ; let qtvs' = filter (`elemVarSet` my_tvs) qtvs -- Maintain original order - inferred_poly_ty = mkSigmaTy qtvs' theta' mono_ty' + inferred_poly_ty = mkInvSigmaTy qtvs' theta' mono_ty' ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr my_tvs, ppr theta' , ppr inferred_poly_ty]) @@ -767,7 +768,7 @@ mkInferredPolyId qtvs inferred_theta poly_name mb_sig mono_ty checkValidType (InfSigCtxt poly_name) inferred_poly_ty -- See Note [Validity of inferred types] - ; return (mkLocalId poly_name inferred_poly_ty) } + ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) } chooseInferredQuantifiers :: TcThetaType -> TcTyVarSet -> Maybe TcIdSigInfo @@ -775,8 +776,7 @@ chooseInferredQuantifiers :: TcThetaType -> TcTyVarSet -> Maybe TcIdSigInfo chooseInferredQuantifiers inferred_theta tau_tvs Nothing = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) -- Include kind variables! Trac #7916 - - ; my_theta <- pickQuantifiablePreds free_tvs inferred_theta + my_theta = pickQuantifiablePreds free_tvs inferred_theta ; return (free_tvs, my_theta) } chooseInferredQuantifiers inferred_theta tau_tvs @@ -785,24 +785,26 @@ chooseInferredQuantifiers inferred_theta tau_tvs , sig_theta = annotated_theta })) | PartialSig { sig_cts = extra } <- bndr_info , Nothing <- extra - = do { annotated_theta <- zonkTcThetaType annotated_theta - ; let free_tvs = closeOverKinds (tyVarsOfTypes annotated_theta + = do { annotated_theta <- zonkTcTypes annotated_theta + ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta `unionVarSet` tau_tvs) ; traceTc "ciq" (vcat [ ppr bndr_info, ppr annotated_theta, ppr free_tvs]) ; return (free_tvs, annotated_theta) } | PartialSig { sig_cts = extra } <- bndr_info , Just loc <- extra - = do { annotated_theta <- zonkTcThetaType annotated_theta - ; let free_tvs = closeOverKinds (tyVarsOfTypes annotated_theta + = do { annotated_theta <- zonkTcTypes annotated_theta + ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta `unionVarSet` tau_tvs) - ; my_theta <- pickQuantifiablePreds free_tvs inferred_theta + my_theta = pickQuantifiablePreds free_tvs inferred_theta -- Report the inferred constraints for an extra-constraints wildcard/hole as -- an error message, unless the PartialTypeSignatures flag is enabled. In this -- case, the extra inferred constraints are accepted without complaining. -- Returns the annotated constraints combined with the inferred constraints. - ; let inferred_diff = minusList my_theta annotated_theta + inferred_diff = [ pred + | pred <- my_theta + , all (not . (`eqType` pred)) annotated_theta ] final_theta = annotated_theta ++ inferred_diff ; partial_sigs <- xoptM Opt_PartialTypeSignatures ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures @@ -970,8 +972,7 @@ recoveryCode binder_names sig_fn = mkLocalId name forall_a_a forall_a_a :: TcType -forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar) - +forall_a_a = mkInvForAllTys [levity1TyVar, openAlphaTyVar] openAlphaTy {- ********************************************************************* * * @@ -1175,7 +1176,7 @@ tcSpecWrapper ctxt poly_ty spec_ty = do { (sk_wrap, inst_wrap) <- tcGen ctxt spec_ty $ \ _ spec_tau -> do { (inst_wrap, tau) <- deeplyInstantiate orig poly_ty - ; _ <- unifyType spec_tau tau + ; _ <- unifyType noThing spec_tau tau -- Deliberately ignore the evidence -- See Note [Handling SPECIALISE pragmas], -- wrinkle (2) @@ -1404,7 +1405,9 @@ tcMonoBinds is_rec sig_fn no_gen -- e.g. f = \(x::forall a. a->a) -> <body> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { rhs_ty <- newFlexiTyVarTy openTypeKind + do { (rhs_tv, _) <- newOpenReturnTyVar + -- use ReturnTv to allow impredicativity + ; let rhs_ty = mkTyVarTy rhs_tv ; mono_id <- newNoSigLetBndr no_gen name rhs_ty ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $ -- We extend the error context even for a non-recursive @@ -1471,11 +1474,11 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches }) -- see Note [Partial type signatures and generalisation] -- Both InferGen and CheckGen gives rise to LetLclBndr do { mono_name <- newLocalName name - ; let mono_id = mkLocalId mono_name tau + ; let mono_id = mkLocalIdOrCoVar mono_name tau ; return (TcFunBind (name, Just sig, mono_id) nm_loc matches) } | otherwise - = do { mono_ty <- newFlexiTyVarTy openTypeKind + = do { mono_ty <- newOpenFlexiTyVarTy ; mono_id <- newNoSigLetBndr no_gen name mono_ty ; return (TcFunBind (name, Nothing, mono_id) nm_loc matches) } @@ -1680,28 +1683,33 @@ tcTySig (L loc (TypeSig names sig_ty)) ; return (map TcIdSig sigs) } tcTySig (L loc (PatSynSig (L _ name) sig_ty)) - | HsIB { hsib_kvs = sig_kvs - , hsib_tvs = sig_tvs + | HsIB { hsib_vars = sig_vars , hsib_body = hs_ty } <- sig_ty , (tv_bndrs, req, prov, body_ty) <- splitLHsPatSynTy hs_ty = setSrcSpan loc $ - tcImplicitTKBndrs sig_kvs sig_tvs $ \ _ tvs1 -> - tcHsTyVarBndrs tv_bndrs $ \ tvs2 -> - do { req' <- tcHsContext req - ; prov' <- tcHsContext prov - ; ty' <- tcHsLiftedType body_ty + do { (tvs1, (req', prov', ty', tvs2)) + <- tcImplicitTKBndrs sig_vars $ + tcHsTyVarBndrs tv_bndrs $ \ tvs2 -> + do { req' <- tcHsContext req + ; prov' <- tcHsContext prov + ; ty' <- tcHsLiftedType body_ty + ; let bound_tvs + = unionVarSets [ allBoundVariabless req' + , allBoundVariabless prov' + , allBoundVariables ty' ] + ; return ((req', prov', ty', tvs2), bound_tvs) } -- These are /signatures/ so we zonk to squeeze out any kind -- unification variables. ToDo: checkValidType? - ; qtvs' <- mapM zonkQuantifiedTyVar (tvs1 ++ tvs2) - ; req' <- zonkTcThetaType req' - ; prov' <- zonkTcThetaType prov' - ; ty' <- zonkTcType ty' + ; qtvs' <- mapMaybeM zonkQuantifiedTyVar (tvs1 ++ tvs2) + ; req' <- zonkTcTypes req' + ; prov' <- zonkTcTypes prov' + ; ty' <- zonkTcType ty' ; let (_, pat_ty) = tcSplitFunTys ty' - univ_set = tyVarsOfType pat_ty + univ_set = tyCoVarsOfType pat_ty (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs' - bad_tvs = varSetElems (tyVarsOfTypes req' `minusVarSet` univ_set) + bad_tvs = varSetElems (tyCoVarsOfTypes req' `minusVarSet` univ_set) ; unless (null bad_tvs) $ addErr $ hang (ptext (sLit "The 'required' context") <+> quotes (pprTheta req')) @@ -1748,35 +1756,50 @@ tcUserTypeSig hs_sig_ty mb_name , sig_loc = loc } } -- Partial sig with wildcards - | HsIB { hsib_kvs = kvs, hsib_tvs = tvs, hsib_body = wc_ty } <- hs_sig_ty + | HsIB { hsib_vars = vars, hsib_body = wc_ty } <- hs_sig_ty , HsWC { hswc_wcs = wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty , (hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty - = pushTcLevelM_ $ -- When instantiating the signature, do so "one level in" - -- so that they can be unified under the forall - tcImplicitTKBndrs kvs tvs $ \ kvs1 tvs1 -> - tcWildCardBinders wcs $ \ wcs -> - tcHsTyVarBndrs hs_tvs $ \ tvs2 -> - do { -- Instantiate the type-class context; but if there - -- is an extra-constraints wildcard, just discard it here - traceTc "tcPartial" (ppr name $$ ppr tvs $$ ppr tvs1 $$ ppr wcs) - ; theta <- mapM tcLHsPredType $ - case extra of - Nothing -> hs_ctxt - Just _ -> dropTail 1 hs_ctxt - - ; tau <- tcHsOpenType hs_tau - - -- Check for validity (eg rankN etc) - -- The ambiguity check will happen (from checkValidType), - -- but unnecessarily; it will always succeed because there - -- is no quantification - ; _ <- zonkAndCheckValidity ctxt_F (mkPhiTy theta tau) + = do { (vars1, (wcs, tvs2, theta, tau)) + <- pushTcLevelM_ $ + -- When instantiating the signature, do so "one level in" + -- so that they can be unified under the forall + tcImplicitTKBndrs vars $ + tcWildCardBinders wcs $ \ wcs -> + tcHsTyVarBndrs hs_tvs $ \ tvs2 -> + do { -- Instantiate the type-class context; but if there + -- is an extra-constraints wildcard, just discard it here + traceTc "tcPartial" (ppr name $$ ppr vars $$ ppr wcs) + ; theta <- mapM tcLHsPredType $ + case extra of + Nothing -> hs_ctxt + Just _ -> dropTail 1 hs_ctxt + + ; tau <- tcHsOpenType hs_tau + + -- zonking is necessary to establish type representation + -- invariants + ; theta <- zonkTcTypes theta + ; tau <- zonkTcType tau + + -- Check for validity (eg rankN etc) + -- The ambiguity check will happen (from checkValidType), + -- but unnecessarily; it will always succeed because there + -- is no quantification + ; checkValidType ctxt_F (mkPhiTy theta tau) + -- NB: Do this in the context of the pushTcLevel so that + -- the TcLevel invariant is respected + + ; let bound_tvs + = unionVarSets [ allBoundVariabless theta + , allBoundVariables tau + , mkVarSet (map snd wcs) ] + ; return ((wcs, tvs2, theta, tau), bound_tvs) } ; loc <- getSrcSpanM ; return $ TISI { sig_bndr = PartialSig { sig_name = name, sig_hs_ty = hs_ty , sig_cts = extra, sig_wcs = wcs } - , sig_skols = [ (tyVarName tv, tv) | tv <- kvs1 ++ tvs1 ++ tvs2 ] + , sig_skols = [ (tyVarName tv, tv) | tv <- vars1 ++ tvs2 ] , sig_theta = theta , sig_tau = tau , sig_ctxt = ctxt_F @@ -1815,7 +1838,7 @@ instTcTySig :: UserTypeCtxt -> TcM TcIdSigInfo instTcTySig ctxt hs_ty sigma_ty name = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty - ; return (TISI { sig_bndr = CompleteSig (mkLocalId name sigma_ty) + ; return (TISI { sig_bndr = CompleteSig (mkLocalIdOrCoVar name sigma_ty) , sig_skols = findScopedTyVars sigma_ty inst_tvs , sig_theta = theta , sig_tau = tau diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index bc485d7ac8..7ac2a9a3ab 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -12,13 +12,12 @@ module TcCanonical( import TcRnTypes import TcType import Type -import Kind import TcFlatten import TcSMonad import TcEvidence import Class import TyCon -import TypeRep +import TyCoRep -- cleverly decomposes types, good for completeness checking import Coercion import FamInstEnv ( FamInstEnvs ) import FamInst ( tcTopNormaliseNewTypeTF_maybe ) @@ -33,11 +32,20 @@ import RdrName import Pair import Util import Bag -import MonadUtils ( zipWith3M, zipWith3M_ ) -import Data.List ( zip4 ) +import MonadUtils +import Control.Monad +import Data.List ( zip4, foldl' ) import BasicTypes import FastString +#if __GLASGOW_HASKELL__ < 709 +bimap :: (a -> b) -> (c -> d) -> Either a c -> Either b d +bimap f _ (Left x) = Left (f x) +bimap _ f (Right x) = Right (f x) +#else +import Data.Bifunctor ( bimap ) +#endif + {- ************************************************************************ * * @@ -206,7 +214,7 @@ canClass ev cls tys mk_ct new_ev = CDictCan { cc_ev = new_ev , cc_tyargs = xis, cc_class = cls } ; mb <- rewriteEvidence ev xi co - ; traceTcS "canClass" (vcat [ ppr ev <+> ppr cls <+> ppr tys + ; traceTcS "canClass" (vcat [ ppr ev , ppr xi, ppr mb ]) ; return (fmap mk_ct mb) } @@ -334,7 +342,7 @@ newSCWorkFromFlavored flavor cls xis (mkEvScSelectors (EvId evar) cls xis) ; emitWorkNC given_evs } - | isEmptyVarSet (tyVarsOfTypes xis) + | isEmptyVarSet (tyCoVarsOfTypes xis) = return () -- Wanteds with no variables yield no deriveds. -- See Note [Improvement from Ground Wanteds] @@ -420,7 +428,10 @@ is flattened, but this is left as future work. (Mar '15) canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) canEqNC ev eq_rel ty1 ty2 - = can_eq_nc False ev eq_rel ty1 ty1 ty2 ty2 + = do { result <- zonk_eq_types ty1 ty2 + ; case result of + Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 + Right ty -> canEqReflexive ev eq_rel ty } can_eq_nc :: Bool -- True => both types are flat @@ -453,7 +464,9 @@ can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 -- need to check for reflexivity in the ReprEq case. -- See Note [Eager reflexivity check] -can_eq_nc' _flat _rdr_env _envs ev ReprEq ty1 _ ty2 _ +-- Check only when flat because the zonk_eq_types check in canEqNC takes +-- care of the non-flat case. +can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _ | ty1 `eqType` ty2 = canEqReflexive ev ReprEq ty1 @@ -465,6 +478,12 @@ can_eq_nc' _flat rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _ | Just (co, ty2') <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 = can_eq_newtype_nc rdr_env ev IsSwapped co ty2 ty2' ty1 ps_ty1 +-- Then, get rid of casts +can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 + = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 +can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ + = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 + ---------------------- -- Otherwise try to decompose ---------------------- @@ -472,34 +491,36 @@ can_eq_nc' _flat rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _ -- Literals can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ | l1 == l2 - = do { setEvBindIfWanted ev (EvCoercion $ - mkTcReflCo (eqRelRole eq_rel) ty1) + = do { setEqIfWanted ev (mkReflCo (eqRelRole eq_rel) ty1) ; stopWith ev "Equal LitTy" } -- 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) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2 + | 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 can_eq_nc' _flat _rdr_env _envs ev eq_rel - s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ - | CtWanted { ctev_loc = loc, ctev_evar = orig_ev } <- ev - = do { let (tvs1,body1) = tcSplitForAllTys s1 - (tvs2,body2) = tcSplitForAllTys s2 - ; if not (equalLength tvs1 tvs2) then - canEqHardFailure ev eq_rel s1 s2 + s1@(ForAllTy (Named {}) _) _ s2@(ForAllTy (Named {}) _) _ + | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev + = do { let (bndrs1,body1) = tcSplitNamedPiTys s1 + (bndrs2,body2) = tcSplitNamedPiTys s2 + ; if not (equalLength bndrs1 bndrs2) + || not (map binderVisibility bndrs1 == map binderVisibility bndrs2) + then canEqHardFailure ev s1 s2 else do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; ev_term <- deferTcSForAllEq (eqRelRole eq_rel) - loc (tvs1,body1) (tvs2,body2) - ; setWantedEvBind orig_ev ev_term + ; kind_cos <- zipWithM (unifyWanted loc Nominal) + (map binderType bndrs1) (map binderType bndrs2) + ; all_co <- deferTcSForAllEq (eqRelRole eq_rel) loc + kind_cos (bndrs1,body1) (bndrs2,body2) + ; setWantedEq orig_dest all_co ; stopWith ev "Deferred polytype equality" } } | otherwise - = do { traceTcS "Ommitting decomposition of given polytype equality" $ + = do { traceTcS "Omitting decomposition of given polytype equality" $ pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] ; stopWith ev "Discard given polytype equality" } @@ -511,11 +532,11 @@ can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _ | Just (t1, s1) <- tcSplitAppTy_maybe ty1 = can_eq_app ev eq_rel t1 s1 t2 s2 --- No similarity in type structure detected. Flatten and try again! +-- No similarity in type structure detected. Flatten and try again. can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1 ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 - ; rewriteEqEvidence ev eq_rel NotSwapped xi1 xi2 co1 co2 + ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 `andWhenContinue` \ new_ev -> can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } @@ -528,8 +549,111 @@ can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 (TyVarTy tv2) _ = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty1 -- We've flattened and the types don't match. Give up. -can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 - = canEqHardFailure ev eq_rel ps_ty1 ps_ty2 +can_eq_nc' True _rdr_env _envs ev _eq_rel _ ps_ty1 _ ps_ty2 + = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) + ; canEqHardFailure ev ps_ty1 ps_ty2 } + +--------------------------------- +-- | Compare types for equality, while zonking as necessary. Gives up +-- as soon as it finds that two types are not equal. +-- This is quite handy when some unification has made two +-- types in an inert wanted to be equal. We can discover the equality without +-- flattening, which is sometimes very expensive (in the case of type functions). +-- In particular, this function makes a ~20% improvement in test case +-- perf/compiler/T5030. +-- +-- Returns either the (partially zonked) types in the case of +-- inequality, or the one type in the case of equality. canEqReflexive is +-- a good next step in the 'Right' case. Returning 'Left' is always safe. +-- +-- NB: This does *not* look through type synonyms. In fact, it treats type +-- synonyms as rigid constructors. In the future, it might be convenient +-- to look at only those arguments of type synonyms that actually appear +-- in the synonym RHS. But we're not there yet. +zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) +zonk_eq_types = go + where + go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 + go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 + go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 + + go ty1 ty2 + | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2 + , tc1 == tc2 + = tycon tc1 tys1 tys2 + + go ty1 ty2 + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = do { res_a <- go ty1a ty2a + ; res_b <- go ty1b ty2b + ; return $ combine_rev mkAppTy res_b res_a } + + go ty1@(LitTy lit1) (LitTy lit2) + | lit1 == lit2 + = return (Right ty1) + + go ty1 ty2 = return $ Left (Pair ty1 ty2) + -- we don't handle more complex forms here + + tyvar :: SwapFlag -> TcTyVar -> TcType + -> TcS (Either (Pair TcType) TcType) + -- try to do as little as possible, as anything we do here is redundant + -- with flattening. In particular, no need to zonk kinds. That's why + -- we don't use the already-defined zonking functions + tyvar swapped tv ty + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> give_up + Indirect ty' -> unSwap swapped go ty' ty } + _ -> give_up + where + give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty + + tyvar_tyvar tv1 tv2 + | tv1 == tv2 = return (Right (mkTyVarTy tv1)) + | otherwise = do { (ty1', progress1) <- quick_zonk tv1 + ; (ty2', progress2) <- quick_zonk tv2 + ; if progress1 || progress2 + then go ty1' ty2' + else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } + + quick_zonk tv = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> return (TyVarTy tv, False) + Indirect ty' -> return (ty', True) } + _ -> return (TyVarTy tv, False) + + -- This happens for type families, too. But recall that failure + -- here just means to try harder, so it's OK if the type function + -- isn't injective. + tycon :: TyCon -> [TcType] -> [TcType] + -> TcS (Either (Pair TcType) TcType) + tycon tc tys1 tys2 + = do { results <- zipWithM go tys1 tys2 + ; return $ case combine_results results of + Left tys -> Left (mkTyConApp tc <$> tys) + Right tys -> Right (mkTyConApp tc tys) } + + combine_results :: [Either (Pair TcType) TcType] + -> Either (Pair [TcType]) [TcType] + combine_results = bimap (fmap reverse) reverse . + foldl' (combine_rev (:)) (Right []) + + -- combine (in reverse) a new result onto an already-combined result + combine_rev :: (a -> b -> c) + -> Either (Pair b) b + -> Either (Pair a) a + -> Either (Pair c) c + combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) + combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) + combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) + combine_rev f (Right tys) (Right ty) = Right (f ty tys) {- Note [Newtypes can blow the stack] @@ -602,7 +726,7 @@ can_eq_newtype_nc rdr_env ev swapped co ty1 ty1' ty2 ps_ty2 -- we have actually used the newtype constructor here, so -- make sure we don't warn about importing it! - ; rewriteEqEvidence ev ReprEq swapped ty1' ps_ty2 + ; rewriteEqEvidence ev swapped ty1' ps_ty2 (mkTcSymCo co) (mkTcReflCo Representational ps_ty2) `andWhenContinue` \ new_ev -> can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 } @@ -627,25 +751,49 @@ can_eq_app ev ReprEq _ _ _ _ can_eq_app ev NomEq s1 t1 s2 t2 | CtDerived { ctev_loc = loc } <- ev - = do { emitNewDerivedEq loc (mkTcEqPred t1 t2) - ; canEqNC ev NomEq s1 s2 } - | CtWanted { ctev_evar = evar, ctev_loc = loc } <- ev - = do { ev_s <- newWantedEvVarNC loc (mkTcEqPred s1 s2) + = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2] + ; stopWith ev "Decomposed [D] AppTy" } + | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev + = do { co_s <- unifyWanted loc Nominal s1 s2 ; co_t <- unifyWanted loc Nominal t1 t2 - ; let co = mkTcAppCo (ctEvCoercion ev_s) co_t - ; setWantedEvBind evar (EvCoercion co) - ; canEqNC ev_s NomEq s1 s2 } + ; let co = mkAppCo co_s co_t + ; setWantedEq dest co + ; stopWith ev "Decomposed [W] AppTy" } | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev = do { let co = mkTcCoVarCo evar co_s = mkTcLRCo CLeft co co_t = mkTcLRCo CRight co - ; evar_s <- newGivenEvVar loc (mkTcEqPred s1 s2, EvCoercion co_s) - ; evar_t <- newGivenEvVar loc (mkTcEqPred t1 t2, EvCoercion co_t) + ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 + , EvCoercion co_s ) + ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 + , EvCoercion co_t ) ; emitWorkNC [evar_t] ; canEqNC evar_s NomEq s1 s2 } | otherwise -- Can't happen = error "can_eq_app" +----------------------- +-- | Break apart an equality over a casted type +canEqCast :: Bool -- are both types flat? + -> CtEvidence + -> EqRel + -> SwapFlag + -> TcType -> Coercion -- LHS (res. RHS), the casted type + -> TcType -> TcType -- RHS (res. LHS), both normal and pretty + -> TcS (StopOrContinue Ct) +canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2 + = do { traceTcS "Decomposing cast" (vcat [ ppr ev + , ppr ty1 <+> text "|>" <+> ppr co1 + , ppr ps_ty2 ]) + ; rewriteEqEvidence ev swapped ty1 ps_ty2 + (mkTcReflCo role ty1 + `mkTcCoherenceRightCo` co1) + (mkTcReflCo role ps_ty2) + `andWhenContinue` \ new_ev -> + can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 } + where + role = eqRelRole eq_rel + ------------------------ canTyConApp :: CtEvidence -> EqRel -> TyCon -> [TcType] @@ -669,7 +817,7 @@ canTyConApp ev eq_rel tc1 tys1 tc2 tys2 isGenerativeTyCon tc2 Representational) = canEqFailure ev eq_rel ty1 ty2 | otherwise - = canEqHardFailure ev eq_rel ty1 ty2 + = canEqHardFailure ev ty1 ty2 where ty1 = mkTyConApp tc1 tys1 ty2 = mkTyConApp tc2 tys2 @@ -835,7 +983,7 @@ Conclusion: It all comes from the fact that newtypes aren't necessarily injective w.r.t. representational equality. -Furthermore, as explained in Note [NthCo and newtypes] in Coercion, we can't use +Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use NthCo on representational coercions over newtypes. NthCo comes into play only when decomposing givens. @@ -871,24 +1019,37 @@ canDecomposableTyConAppOK :: CtEvidence -> EqRel -- Precondition: tys1 and tys2 are the same length, hence "OK" canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 = case ev of - CtDerived { ctev_loc = loc } + CtDerived {} -> unifyDeriveds loc tc_roles tys1 tys2 - CtWanted { ctev_evar = evar, ctev_loc = loc } - -> do { cos <- zipWith3M (unifyWanted loc) tc_roles tys1 tys2 - ; setWantedEvBind evar (EvCoercion (mkTcTyConAppCo role tc cos)) } + CtWanted { ctev_dest = dest } + -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2 + ; setWantedEq dest (mkTyConAppCo role tc cos) } - CtGiven { ctev_evar = evar, ctev_loc = loc } - -> do { let ev_co = mkTcCoVarCo evar + CtGiven { ctev_evar = evar } + -> do { let ev_co = mkCoVarCo evar ; given_evs <- newGivenEvVars loc $ - [ ( mkTcEqPredRole r ty1 ty2 - , EvCoercion (mkTcNthCo i ev_co) ) + [ ( mkPrimEqPredRole r ty1 ty2 + , EvCoercion (mkNthCo i ev_co) ) | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom ] + , r /= Phantom + , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] ; emitWorkNC given_evs } where - role = eqRelRole eq_rel - tc_roles = tyConRolesX role tc + loc = ctEvLoc ev + role = eqRelRole eq_rel + tc_roles = tyConRolesX role tc + + -- the following makes a better distinction between "kind" and "type" + -- in error messages + (bndrs, _) = splitPiTys (tyConKind tc) + kind_loc = toKindLoc loc + is_kinds = map isNamedBinder bndrs + new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc + = repeat loc + | otherwise + = map (\is_kind -> if is_kind then kind_loc else loc) is_kinds + -- | Call when canonicalizing an equality fails, but if the equality is -- representational, there is some hope for the future. @@ -896,7 +1057,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 canEqFailure :: CtEvidence -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) canEqFailure ev NomEq ty1 ty2 - = canEqHardFailure ev NomEq ty1 ty2 + = canEqHardFailure ev ty1 ty2 canEqFailure ev ReprEq ty1 ty2 = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1 ; (xi2, co2) <- flatten FM_FlattenAll ev ty2 @@ -905,18 +1066,18 @@ canEqFailure ev ReprEq ty1 ty2 -- new equalities become available ; traceTcS "canEqFailure with ReprEq" $ vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ] - ; rewriteEqEvidence ev ReprEq NotSwapped xi1 xi2 co1 co2 + ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2 `andWhenContinue` \ new_ev -> continueWith (CIrredEvCan { cc_ev = new_ev }) } -- | Call when canonicalizing an equality fails with utterly no hope. -canEqHardFailure :: CtEvidence -> EqRel +canEqHardFailure :: CtEvidence -> TcType -> TcType -> TcS (StopOrContinue Ct) -- See Note [Make sure that insolubles are fully rewritten] -canEqHardFailure ev eq_rel ty1 ty2 +canEqHardFailure ev ty1 ty2 = do { (s1, co1) <- flatten FM_SubstOnly ev ty1 ; (s2, co2) <- flatten FM_SubstOnly ev ty2 - ; rewriteEqEvidence ev eq_rel NotSwapped s1 s2 co1 co2 + ; rewriteEqEvidence ev NotSwapped s1 s2 co1 co2 `andWhenContinue` \ new_ev -> do { emitInsoluble (mkNonCanonical new_ev) ; stopWith new_ev "Definitely not equal" }} @@ -1023,6 +1184,19 @@ a bit verbose. And the shorter name gets the point across.) See also #10715, which induced this addition. +Note [No derived kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we're working with a heterogeneous derived equality + + [D] (t1 :: k1) ~ (t2 :: k2) + +we want to homogenise to establish the kind invariant on CTyEqCans. +But we can't emit [D] k1 ~ k2 because we wouldn't then be able to +use the evidence in the homogenised types. So we emit a wanted +constraint, because we do really need the evidence here. + +Thus: no derived kind equalities. + -} canCFunEqCan :: CtEvidence @@ -1040,7 +1214,7 @@ canCFunEqCan ev fn tys fsk -- :: F tys' ~ F tys new_lhs = mkTyConApp fn tys' fsk_ty = mkTyVarTy fsk - ; rewriteEqEvidence ev NomEq NotSwapped new_lhs fsk_ty + ; rewriteEqEvidence ev NotSwapped new_lhs fsk_ty lhs_co (mkTcNomReflCo fsk_ty) `andWhenContinue` \ ev' -> do { extendFlatCache fn tys' (ctEvCoercion ev', fsk_ty, ctEvFlavour ev') @@ -1074,48 +1248,40 @@ canEqTyVar2 :: DynFlags -- preserved as much as possible canEqTyVar2 dflags ev eq_rel swapped tv1 xi2 - | Just tv2 <- getTyVar_maybe xi2 - = canEqTyVarTyVar ev eq_rel swapped tv1 tv2 + | Just (tv2, kco2) <- getCastedTyVar_maybe xi2 + = canEqTyVarTyVar ev eq_rel swapped tv1 tv2 kco2 | OC_OK xi2' <- occurCheckExpand dflags tv1 xi2 -- No occurs check -- We use xi2' on the RHS of the new CTyEqCan, a ~ xi2' -- to establish the invariant that a does not appear in the -- rhs of the CTyEqCan. This is guaranteed by occurCheckExpand; -- see Note [Occurs check expansion] in TcType - = do { let k1 = tyVarKind tv1 - k2 = typeKind xi2' - ; rewriteEqEvidence ev eq_rel swapped xi1 xi2' co1 (mkTcReflCo role xi2') - `andWhenContinue` \ new_ev -> - if k2 `isSubKind` k1 - then -- Establish CTyEqCan kind invariant - -- Reorientation has done its best, but the kinds might - -- simply be incompatible - continueWith (CTyEqCan { cc_ev = new_ev - , cc_tyvar = tv1, cc_rhs = xi2' - , cc_eq_rel = eq_rel }) - else incompatibleKind new_ev xi1 k1 xi2' k2 } + = rewriteEqEvidence ev swapped xi1 xi2' co1 (mkTcReflCo role xi2') + `andWhenContinue` \ new_ev -> + homogeniseRhsKind new_ev eq_rel xi1 xi2' $ \new_new_ev xi2'' -> + CTyEqCan { cc_ev = new_new_ev, cc_tyvar = tv1 + , cc_rhs = xi2'', cc_eq_rel = eq_rel } | otherwise -- Occurs check error - = rewriteEqEvidence ev eq_rel swapped xi1 xi2 co1 co2 - `andWhenContinue` \ new_ev -> - if eq_rel == NomEq || isTyVarUnderDatatype tv1 xi2 - -- See Note [Occurs check error] - - then do { emitInsoluble (mkNonCanonical new_ev) - -- If we have a ~ [a], it is not canonical, and in particular - -- we don't want to rewrite existing inerts with it, otherwise - -- we'd risk divergence in the constraint solver - ; stopWith new_ev "Occurs check" } - - -- A representational equality with an occurs-check problem isn't - -- insoluble! For example: - -- a ~R b a - -- We might learn that b is the newtype Id. - -- But, the occurs-check certainly prevents the equality from being - -- canonical, and we might loop if we were to use it in rewriting. - else do { traceTcS "Occurs-check in representational equality" - (ppr xi1 $$ ppr xi2) - ; continueWith (CIrredEvCan { cc_ev = new_ev }) } + = do { traceTcS "canEqTyVar2 occurs check error" (ppr tv1 $$ ppr xi2) + ; rewriteEqEvidence ev swapped xi1 xi2 co1 co2 + `andWhenContinue` \ new_ev -> + if eq_rel == NomEq || isTyVarUnderDatatype tv1 xi2 + then do { emitInsoluble (mkNonCanonical new_ev) + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver + ; stopWith new_ev "Occurs check" } + + -- A representational equality with an occurs-check problem isn't + -- insoluble! For example: + -- a ~R b a + -- We might learn that b is the newtype Id. + -- But, the occurs-check certainly prevents the equality from being + -- canonical, and we might loop if we were to use it in rewriting. + else do { traceTcS "Occurs-check in representational equality" + (ppr xi1 $$ ppr xi2) + ; continueWith (CIrredEvCan { cc_ev = new_ev }) } } where role = eqRelRole eq_rel xi1 = mkTyVarTy tv1 @@ -1126,46 +1292,50 @@ canEqTyVarTyVar :: CtEvidence -- tv1 ~ rhs (or rhs ~ tv1, if swapped) -> EqRel -> SwapFlag -> TcTyVar -> TcTyVar -- tv1, tv2 + -> Coercion -- the co in (rhs = tv2 |> co) -> TcS (StopOrContinue Ct) -- Both LHS and RHS rewrote to a type variable -- See Note [Canonical orientation for tyvar/tyvar equality constraints] -canEqTyVarTyVar ev eq_rel swapped tv1 tv2 +canEqTyVarTyVar ev eq_rel swapped tv1 tv2 kco2 | tv1 == tv2 - = do { setEvBindIfWanted ev (EvCoercion $ mkTcReflCo role xi1) + = do { let mk_coh = case swapped of IsSwapped -> mkTcCoherenceLeftCo + NotSwapped -> mkTcCoherenceRightCo + ; setEvBindIfWanted ev (EvCoercion $ mkTcReflCo role xi1 `mk_coh` kco2) ; stopWith ev "Equal tyvars" } - | incompat_kind = incompatibleKind ev xi1 k1 xi2 k2 - -- We don't do this any more -- See Note [Orientation of equalities with fmvs] in TcFlatten -- | isFmvTyVar tv1 = do_fmv swapped tv1 xi1 xi2 co1 co2 -- | isFmvTyVar tv2 = do_fmv (flipSwap swapped) tv2 xi2 xi1 co2 co1 - | same_kind = if swap_over then do_swap else no_swap - | k1_sub_k2 = do_swap -- Note [Kind orientation for CTyEqCan] - | otherwise = no_swap -- k2_sub_k1 + | swap_over = do_swap + | otherwise = no_swap where role = eqRelRole eq_rel xi1 = mkTyVarTy tv1 co1 = mkTcReflCo role xi1 xi2 = mkTyVarTy tv2 - co2 = mkTcReflCo role xi2 - k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - k1_sub_k2 = k1 `isSubKind` k2 - k2_sub_k1 = k2 `isSubKind` k1 - same_kind = k1_sub_k2 && k2_sub_k1 - incompat_kind = not (k1_sub_k2 || k2_sub_k1) + co2 = mkTcReflCo role xi2 `mkTcCoherenceRightCo` kco2 no_swap = canon_eq swapped tv1 xi1 xi2 co1 co2 do_swap = canon_eq (flipSwap swapped) tv2 xi2 xi1 co2 co1 - canon_eq swapped tv1 xi1 xi2 co1 co2 - -- ev : tv1 ~ rhs (not swapped) or rhs ~ tv1 (swapped) - = rewriteEqEvidence ev eq_rel swapped xi1 xi2 co1 co2 - `andWhenContinue` \ new_ev -> - continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1 - , cc_rhs = xi2, cc_eq_rel = eq_rel }) + canon_eq swapped tv1 ty1 ty2 co1 co2 + -- ev : tv1 ~ orhs (not swapped) or orhs ~ tv1 (swapped) + -- co1 : xi1 ~ tv1 + -- co2 : xi2 ~ tv2 + = do { traceTcS "canEqTyVarTyVar" + (vcat [ ppr swapped + , ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + , ppr ty1 <+> dcolon <+> ppr (typeKind ty1) + , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) + , ppr co1 <+> dcolon <+> ppr (tcCoercionKind co1) + , ppr co2 <+> dcolon <+> ppr (tcCoercionKind co2) ]) + ; rewriteEqEvidence ev swapped ty1 ty2 co1 co2 + `andWhenContinue` \ new_ev -> + homogeniseRhsKind new_ev eq_rel ty1 ty2 $ \new_new_ev ty2' -> + CTyEqCan { cc_ev = new_new_ev, cc_tyvar = tv1 + , cc_rhs = ty2', cc_eq_rel = eq_rel } } {- We don't do this any more See Note [Orientation of equalities with fmvs] in TcFlatten @@ -1187,8 +1357,8 @@ canEqTyVarTyVar ev eq_rel swapped tv1 tv2 ASSERT2( isWanted ev, ppr ev ) -- Only wanteds have flatten meta-vars do { tv_ty <- newFlexiTcSTy (tyVarKind tv1) ; new_ev <- newWantedEvVarNC (ctEvLoc ev) - (mkTcEqPredRole (eqRelRole eq_rel) - tv_ty xi2) + (mkPrimEqPredRole (eqRelRole eq_rel) + g tv_ty xi2) ; emitWorkNC [new_ev] ; canon_eq swapped tv1 xi1 tv_ty co1 (ctEvCoercion new_ev) } -} @@ -1232,30 +1402,75 @@ canEqReflexive ev eq_rel ty mkTcReflCo (eqRelRole eq_rel) ty) ; stopWith ev "Solved by reflexivity" } -incompatibleKind :: CtEvidence -- t1~t2 - -> TcType -> TcKind - -> TcType -> TcKind -- s1~s2, flattened and zonked - -> TcS (StopOrContinue Ct) --- LHS and RHS have incompatible kinds, so emit an "irreducible" constraint --- CIrredEvCan (NOT CTyEqCan or CFunEqCan) --- for the type equality; and continue with the kind equality constraint. --- When the latter is solved, it'll kick out the irreducible equality for --- a second attempt at solving --- -- See Note [Equalities with incompatible kinds] +homogeniseRhsKind :: CtEvidence -- ^ the evidence to homogenise + -> EqRel + -> TcType -- ^ original LHS + -> Xi -- ^ original RHS + -> (CtEvidence -> Xi -> Ct) + -- ^ how to build the homogenised constraint; + -- the 'Xi' is the new RHS + -> TcS (StopOrContinue Ct) +homogeniseRhsKind ev eq_rel lhs rhs build_ct + | k1 `eqType` k2 + = continueWith (build_ct ev rhs) + + | CtGiven { ctev_evar = evar } <- ev + -- tm :: (lhs :: k1) ~ (rhs :: k2) + = do { kind_ev_id <- newBoundEvVarId kind_pty + (EvCoercion $ + mkTcKindCo $ mkTcCoVarCo evar) + -- kind_ev_id :: (k1 :: *) ~# (k2 :: *) + ; let kind_ev = CtGiven { ctev_pred = kind_pty + , ctev_evar = kind_ev_id + , ctev_loc = kind_loc } + homo_co = mkSymCo $ mkCoVarCo kind_ev_id + rhs' = mkCastTy rhs homo_co + ; traceTcS "Hetero equality gives rise to given kind equality" + (ppr kind_ev_id <+> dcolon <+> ppr kind_pty) + ; emitWorkNC [kind_ev] + ; type_ev <- newGivenEvVar loc + ( mkTcEqPredLikeEv ev lhs rhs' + , EvCoercion $ + mkTcCoherenceRightCo (mkTcCoVarCo evar) homo_co ) + -- type_ev :: (lhs :: k1) ~ ((rhs |> sym kind_ev_id) :: k1) + ; continueWith (build_ct type_ev rhs') } + + | otherwise -- Wanted and Derived. See Note [No derived kind equalities] + -- evar :: (lhs :: k1) ~ (rhs :: k2) + = do { (kind_ev, kind_co) <- newWantedEq kind_loc Nominal k1 k2 + -- kind_ev :: (k1 :: *) ~ (k2 :: *) + ; traceTcS "Hetero equality gives rise to wanted kind equality" $ + ppr (kind_ev) + ; emitWorkNC [kind_ev] + ; let homo_co = mkSymCo kind_co + -- homo_co :: k2 ~ k1 + rhs' = mkCastTy rhs homo_co + ; case ev of + CtGiven {} -> panic "homogeniseRhsKind" + CtDerived {} -> continueWith (build_ct (ev { ctev_pred = homo_pred }) + rhs') + where homo_pred = mkTcEqPredLikeEv ev lhs rhs' + CtWanted { ctev_dest = dest } -> do + { (type_ev, hole_co) <- newWantedEq loc role lhs rhs' + -- type_ev :: (lhs :: k1) ~ (rhs |> sym kind_ev :: k1) + ; setWantedEq dest + (hole_co `mkTransCo` + (mkReflCo role rhs + `mkCoherenceLeftCo` homo_co)) + + -- dest := hole ; <rhs> |> homo_co :: (lhs :: k1) ~ (rhs :: k2) + ; continueWith (build_ct type_ev rhs') }} -incompatibleKind new_ev s1 k1 s2 k2 -- See Note [Equalities with incompatible kinds] - = ASSERT( isKind k1 && isKind k2 ) - do { traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr k1, ppr k2]) + where + k1 = typeKind lhs + k2 = typeKind rhs - -- Create a derived kind-equality, and solve it - ; emitNewDerivedEq kind_co_loc (mkTcEqPred k1 k2) + kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind k1 k2 + kind_loc = mkKindLoc lhs rhs loc - -- Put the not-currently-soluble thing into the inert set - ; continueWith (CIrredEvCan { cc_ev = new_ev }) } - where - loc = ctEvLoc new_ev - kind_co_loc = setCtLocOrigin loc (KindEqOrigin s1 s2 (ctLocOrigin loc)) + loc = ctev_loc ev + role = eqRelRole eq_rel {- Note [Canonical orientation for tyvar/tyvar equality constraints] @@ -1337,24 +1552,8 @@ for a~b, then we might well *substitute* 'b' for 'a', and that might make a well-kinded type ill-kinded; and that is bad (eg typeKind can crash, see Trac #7696). -So instead for these ill-kinded equalities we generate a CIrredCan, -and put it in the inert set, which keeps it out of the way until a -subsequent substitution (on kind variables, say) re-activates it. - -NB: it is important that the types s1,s2 are flattened and zonked - so that their kinds k1, k2 are inert wrt the substitution. That - means that they can only become the same if we change the inert - set, which in turn will kick out the irreducible equality - E.g. it is WRONG to make an irred (a:k1)~(b:k2) - if we already have a substitution k1:=k2 - -NB: it's important that the new CIrredCan goes in the inert set rather -than back into the work list. We used to do the latter, but that led -to an infinite loop when we encountered it again, and put it back in -the work list again. - -See also Note [Kind orientation for CTyEqCan] and - Note [Kind orientation for CFunEqCan] in TcRnTypes +So instead for these ill-kinded equalities we homogenise the RHS of the +equality, emitting new constraints as necessary. Note [Type synonyms and canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1501,19 +1700,20 @@ rewriteEvidence ev@(CtGiven { ctev_evar = old_evar , ctev_loc = loc }) new_pred (ctEvRole ev) (mkTcSymCo co)) -rewriteEvidence ev@(CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co - = do { (new_ev, freshness) <- newWantedEvVar loc new_pred +rewriteEvidence ev@(CtWanted { ctev_dest = dest + , ctev_loc = loc }) new_pred co + = do { mb_new_ev <- newWanted loc new_pred ; MASSERT( tcCoercionRole co == ctEvRole ev ) - ; setWantedEvBind evar (mkEvCast (ctEvTerm new_ev) - (tcDowngradeRole Representational (ctEvRole ev) co)) - ; case freshness of - Fresh -> continueWith new_ev - Cached -> stopWith ev "Cached wanted" } + ; setWantedEvTerm dest + (mkEvCast (getEvTerm mb_new_ev) + (tcDowngradeRole Representational (ctEvRole ev) co)) + ; case mb_new_ev of + Fresh new_ev -> continueWith new_ev + Cached _ -> stopWith ev "Cached wanted" } rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) -- or orhs ~ olhs (swapped) - -> EqRel -> SwapFlag -> TcType -> TcType -- New predicate nlhs ~ nrhs -- Should be zonked, because we use typeKind on nlhs/nrhs @@ -1535,7 +1735,7 @@ rewriteEqEvidence :: CtEvidence -- Old evidence :: olhs ~ orhs (not swap -- w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co -- -- It's all a form of rewwriteEvidence, specialised for equalities -rewriteEqEvidence old_ev eq_rel swapped nlhs nrhs lhs_co rhs_co +rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co | CtDerived {} <- old_ev -- Don't force the evidence for a Derived = continueWith (old_ev { ctev_pred = new_pred }) @@ -1551,25 +1751,26 @@ rewriteEqEvidence old_ev eq_rel swapped nlhs nrhs lhs_co rhs_co ; new_ev <- newGivenEvVar loc' (new_pred, new_tm) ; continueWith new_ev } - | CtWanted { ctev_evar = evar } <- old_ev - = do { new_evar <- newWantedEvVarNC loc' new_pred + | CtWanted { ctev_dest = dest } <- old_ev + = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs ; let co = maybeSym swapped $ - mkTcSymCo lhs_co - `mkTcTransCo` ctEvCoercion new_evar - `mkTcTransCo` rhs_co - ; setWantedEvBind evar (EvCoercion co) + mkSymCo lhs_co + `mkTransCo` hole_co + `mkTransCo` rhs_co + ; setWantedEq dest co ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co]) - ; continueWith new_evar } + ; continueWith new_ev } | otherwise = panic "rewriteEvidence" where - new_pred = mkTcEqPredRole (eqRelRole eq_rel) nlhs nrhs + new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs -- equality is like a type class. Bumping the depth is necessary because -- of recursive newtypes, where "reducing" a newtype can actually make -- it bigger. See Note [Newtypes can blow the stack]. - loc' = bumpCtLocDepth (ctEvLoc old_ev) + loc = ctEvLoc old_ev + loc' = bumpCtLocDepth loc {- Note [unifyWanted and unifyDerived] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1584,28 +1785,33 @@ But where it succeeds in finding common structure, it just builds a coercion to reflect it. -} -unifyWanted :: CtLoc -> Role -> TcType -> TcType -> TcS TcCoercion +unifyWanted :: CtLoc -> Role + -> TcType -> TcType -> TcS Coercion -- Return coercion witnessing the equality of the two types, -- emitting new work equalities where necessary to achieve that -- Very good short-cut when the two types are equal, or nearly so -- See Note [unifyWanted and unifyDerived] -- The returned coercion's role matches the input parameter -unifyWanted _ Phantom ty1 ty2 = return (mkTcPhantomCo ty1 ty2) -unifyWanted loc role orig_ty1 orig_ty2 +unifyWanted loc Phantom ty1 ty2 + = do { kind_co <- unifyWanted loc Nominal (typeKind ty1) (typeKind ty2) + ; return (mkPhantomCo kind_co ty1 ty2) } + +unifyWanted loc role orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 where go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' - go (FunTy s1 t1) (FunTy s2 t2) + go (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2) = do { co_s <- unifyWanted loc role s1 s2 ; co_t <- unifyWanted loc role t1 t2 - ; return (mkTcTyConAppCo role funTyCon [co_s,co_t]) } + ; return (mkTyConAppCo role funTyCon [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 - = do { cos <- zipWith3M (unifyWanted loc) (tyConRolesX role tc1) tys1 tys2 - ; return (mkTcTyConAppCo role tc1 cos) } + = do { cos <- zipWith3M (unifyWanted loc) + (tyConRolesX role tc1) tys1 tys2 + ; return (mkTyConAppCo role tc1 cos) } go (TyVarTy tv) ty2 = do { mb_ty <- isFilledMetaTyVar_maybe tv ; case mb_ty of @@ -1616,12 +1822,15 @@ unifyWanted loc role orig_ty1 orig_ty2 ; case mb_ty of Just ty2' -> go ty1 ty2' Nothing -> bale_out } + + go ty1@(CoercionTy {}) (CoercionTy {}) + = return (mkReflCo role ty1) -- we just don't care about coercions! + go _ _ = bale_out - bale_out = do { ev <- newWantedEvVarNC loc (mkTcEqPredRole role - orig_ty1 orig_ty2) - ; emitWorkNC [ev] - ; return (ctEvCoercion ev) } + bale_out = do { (new_ev, co) <- newWantedEq loc role orig_ty1 orig_ty2 + ; emitWorkNC [new_ev] + ; return co } unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS () -- See Note [unifyWanted and unifyDerived] @@ -1642,7 +1851,7 @@ unify_derived loc role orig_ty1 orig_ty2 go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' - go (FunTy s1 t1) (FunTy s2 t2) + go (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2) = do { unify_derived loc role s1 s2 ; unify_derived loc role t1 t2 } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) @@ -1661,7 +1870,8 @@ unify_derived loc role orig_ty1 orig_ty2 Nothing -> bale_out } go _ _ = bale_out - bale_out = emitNewDerivedEq loc (mkTcEqPredRole role orig_ty1 orig_ty2) + -- no point in having *boxed* deriveds. + bale_out = emitNewDerivedEq loc role orig_ty1 orig_ty2 maybeSym :: SwapFlag -> TcCoercion -> TcCoercion maybeSym IsSwapped co = mkTcSymCo co diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 8e6007b97d..521390b0f0 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -26,7 +26,7 @@ import TcBinds import TcUnify import TcHsType import TcMType -import Type ( getClassPredTys_maybe ) +import Type ( getClassPredTys_maybe, varSetElemsWellScoped ) import TcType import TcRnMonad import BuildTyCl( TcMethInfo ) @@ -45,7 +45,6 @@ import VarSet import Outputable import SrcLoc import TyCon -import TypeRep import Maybes import BasicTypes import Bag @@ -209,7 +208,8 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here - ; spec_prags <- tcSpecPrags global_dm_id prags + ; spec_prags <- discardConstraints $ + tcSpecPrags global_dm_id prags ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") <+> quotes (ppr sel_name)) @@ -436,7 +436,7 @@ warningMinimalDefIncomplete mindef tcATDefault :: Bool -- If a warning should be emitted when a default instance -- definition is not provided by the user -> SrcSpan - -> TvSubst + -> TCvSubst -> NameSet -> ClassATItem -> TcM [FamInst] @@ -456,10 +456,12 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs) = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst (tyConTyVars fam_tc) rhs' = substTy subst' rhs_ty - tv_set' = tyVarsOfTypes pat_tys' - tvs' = varSetElemsKvsFirst tv_set' + tcv_set' = tyCoVarsOfTypes pat_tys' + (tv_set', cv_set') = partitionVarSet isTyVar tcv_set' + tvs' = varSetElemsWellScoped tv_set' + cvs' = varSetElemsWellScoped cv_set' ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' + ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs' fam_tc pat_tys' rhs' -- NB: no validity check. We check validity of default instances -- in the class definition. Because type instance arguments cannot @@ -468,7 +470,7 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs) ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty , pprCoAxiom axiom ]) - ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + ; fam_inst <- ASSERT( tyCoVarsOfType rhs' `subVarSet` tv_set' ) newFamInst SynFamilyInst axiom ; return [fam_inst] } @@ -481,7 +483,7 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs) | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty) | otherwise - = (extendTvSubst subst tc_tv ty', ty') + = (extendTCvSubst subst tc_tv ty', ty') where ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index 62325a0b54..fc62fe361a 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -14,6 +14,7 @@ import TcRnMonad import TcEnv import TcHsType import TcSimplify +import TcMType import TcType import PrelNames import DynFlags @@ -62,7 +63,9 @@ tcDefaults decls@(L locn (DefaultDecl _) : _) tc_default_ty :: [Class] -> LHsType Name -> TcM Type tc_default_ty deflt_clss hs_ty - = do { ty <- tcHsLiftedType hs_ty + = do { ty <- solveEqualities $ + tcHsLiftedType hs_ty + ; ty <- zonkTcType ty -- establish Type invariants ; checkTc (isTauTy ty) (polyDefErr hs_ty) -- Check that the type is an instance of at least one of the deflt_clss diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 107648dbb9..d8245acb2c 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -42,6 +42,7 @@ import Avail import Unify( tcUnifyTy ) import Class import Type +import Coercion import ErrUtils import DataCon import Maybes @@ -90,23 +91,22 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan , ds_cls :: Class , ds_tys :: [Type] , ds_tc :: TyCon - , ds_tc_args :: [Type] , ds_overlap :: Maybe OverlapMode - , ds_newtype :: Bool } + , ds_newtype :: Maybe Type } -- The newtype rep type -- This spec implies a dfun declaration of the form -- df :: forall tvs. theta => C tys -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the theta -- For type families, the tycon in -- in ds_tys is the *family* tycon - -- in ds_tc, ds_tc_args is the *representation* tycon + -- in ds_tc is the *representation* type -- For non-family tycons, both are the same -- the theta is either the given and final theta, in standalone deriving, -- or the not-yet-simplified list of constraints together with their origin - -- ds_newtype = True <=> Generalised Newtype Deriving (GND) - -- False <=> Vanilla deriving + -- ds_newtype = Just rep_ty <=> Generalised Newtype Deriving (GND) + -- Nothing <=> Vanilla deriving {- Example: @@ -117,22 +117,21 @@ Example: axiom :RTList a = Tree a DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]] - , ds_tc = :RTList, ds_tc_args = [a] - , ds_newtype = True } + , ds_tc = :RTList, ds_newtype = Just (Tree a) } -} type DerivContext = Maybe ThetaType -- Nothing <=> Vanilla deriving; infer the context of the instance decl -- Just theta <=> Standalone deriving: context supplied by programmer -data PredOrigin = PredOrigin PredType CtOrigin +data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind type ThetaOrigin = [PredOrigin] -mkPredOrigin :: CtOrigin -> PredType -> PredOrigin -mkPredOrigin origin pred = PredOrigin pred origin +mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin +mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k -mkThetaOrigin :: CtOrigin -> ThetaType -> ThetaOrigin -mkThetaOrigin origin = map (mkPredOrigin origin) +mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin +mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k) data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin) | GivenTheta (DerivSpec ThetaType) @@ -161,8 +160,13 @@ splitEarlyDerivSpec (GivenTheta spec : specs) = pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c, ds_tys = tys, ds_theta = rhs }) - = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys] - <+> equals <+> ppr rhs) + = hang (text "DerivSpec") + 2 (vcat [ text "ds_loc =" <+> ppr l + , text "ds_name =" <+> ppr n + , text "ds_tvs =" <+> ppr tvs + , text "ds_cls =" <+> ppr c + , text "ds_tys =" <+> ppr tys + , text "ds_theta =" <+> ppr rhs ]) instance Outputable theta => Outputable (DerivSpec theta) where ppr = pprDerivSpec @@ -172,7 +176,7 @@ instance Outputable EarlyDerivSpec where ppr (GivenTheta spec) = ppr spec <+> ptext (sLit "(Given)") instance Outputable PredOrigin where - ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging + ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging {- Note [Inferring the instance context] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -542,7 +546,8 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) | isAlgTyCon tc || isDataFamilyTyCon tc -- All other classes -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode) - tvs cls cls_tys tc tc_args (Just theta) + tvs cls cls_tys tc tc_args + (Just theta) ; return [spec] } _ -> -- Complain about functions, primitive types, etc, @@ -550,7 +555,6 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) ptext (sLit "The last argument of the instance must be a data or newtype application") } - warnUselessTypeable :: TcM () warnUselessTypeable = do { warn <- woptM Opt_WarnDerivingTypeable @@ -585,29 +589,31 @@ deriveTyData tvs tc tc_args deriv_pred do { -- Given data T a b c = ... deriving( C d ), -- we want to drop type variables from T so that (C d (T a)) is well-kinded - let (arg_kinds, _) = splitKindFunTys cls_arg_kind + let (arg_kinds, _) = splitFunTys cls_arg_kind n_args_to_drop = length arg_kinds n_args_to_keep = tyConArity tc - n_args_to_drop (tc_args_to_keep, args_to_drop) = splitAt n_args_to_keep tc_args inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) - dropped_tvs = tyVarsOfTypes args_to_drop + dropped_tvs = tyCoVarsOfTypes args_to_drop -- Match up the kinds, and apply the resulting kind substitution -- to the types. See Note [Unify kinds in deriving] -- We are assuming the tycon tyvars and the class tyvars are distinct mb_match = tcUnifyTy inst_ty_kind cls_arg_kind Just kind_subst = mb_match - (univ_kvs, univ_tvs) = partition isKindVar $ varSetElems $ - mkVarSet deriv_tvs `unionVarSet` - tyVarsOfTypes tc_args_to_keep - univ_kvs' = filter (`notElemTvSubst` kind_subst) univ_kvs - (subst', univ_tvs') = mapAccumL substTyVarBndr kind_subst univ_tvs - final_tc_args = substTys subst' tc_args_to_keep - final_cls_tys = substTys subst' cls_tys + + all_tkvs = varSetElemsWellScoped $ + mkVarSet deriv_tvs `unionVarSet` + tyCoVarsOfTypes tc_args_to_keep + unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs + (subst, tkvs) = mapAccumL substTyVarBndr + kind_subst unmapped_tkvs + final_tc_args = substTys subst tc_args_to_keep + final_cls_tys = substTys subst cls_tys ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred - , pprTvBndrs (tyVarsOfTypesList tc_args) + , pprTvBndrs (tyCoVarsOfTypesList tc_args) , ppr n_args_to_keep, ppr n_args_to_drop , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match , ppr final_tc_args, ppr final_cls_tys ]) @@ -616,10 +622,10 @@ deriveTyData tvs tc tc_args deriv_pred ; checkTc (n_args_to_keep >= 0 && isJust mb_match) (derivingKindErr tc cls cls_tys cls_arg_kind) - ; traceTc "derivTyData2" (vcat [ ppr univ_tvs ]) + ; traceTc "derivTyData2" (vcat [ ppr tkvs ]) ; checkTc (allDistinctTyVars args_to_drop && -- (a) and (b) - not (any (`elemVarSet` dropped_tvs) univ_tvs)) -- (c) + not (any (`elemVarSet` dropped_tvs) tkvs)) -- (c) (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args)) -- Check that -- (a) The args to drop are all type variables; eg reject: @@ -632,7 +638,7 @@ deriveTyData tvs tc tc_args deriv_pred -- newtype T a s = ... deriving( ST s ) -- newtype K a a = ... deriving( Monad ) - ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs') + ; spec <- mkEqnHelp Nothing tkvs cls final_cls_tys tc final_tc_args Nothing ; traceTc "derivTyData" (ppr spec) ; return [spec] } } @@ -712,7 +718,6 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta -- Note [Looking up family instances for deriving] fam_envs <- tcGetFamInstEnvs ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args - -- If it's still a data family, the lookup failed; i.e no instance exists ; when (isDataFamilyTyCon rep_tc) (bale_out (ptext (sLit "No family instance for") <+> quotes (pprTypeApp tycon tc_args))) @@ -799,9 +804,8 @@ write it out See Note [Eta reduction for data families] in FamInstEnv - -************************************************************************ -* * +%************************************************************************ +%* * Deriving data types * * ************************************************************************ @@ -809,7 +813,7 @@ See Note [Eta reduction for data families] in FamInstEnv mkDataTypeEqn :: DynFlags -> Maybe OverlapMode - -> [Var] -- Universally quantified type variables in the instance + -> [TyVar] -- Universally quantified type variables in the instance -> Class -- Class for which we need to derive an instance -> [Type] -- Other parameters to the class except the last -> TyCon -- Type constructor for which the instance is requested @@ -845,19 +849,19 @@ mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tc, ds_tc_args = rep_tc_args + , ds_tc = rep_tc , ds_theta = inferred_constraints , ds_overlap = overlap_mode - , ds_newtype = False } + , ds_newtype = Nothing } Just theta -> do -- Specified context return $ GivenTheta $ DS { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tc, ds_tc_args = rep_tc_args + , ds_tc = rep_tc , ds_theta = theta , ds_overlap = overlap_mode - , ds_newtype = False } + , ds_newtype = Nothing } where inst_ty = mkTyConApp tycon tc_args inst_tys = cls_tys ++ [inst_ty] @@ -899,36 +903,46 @@ inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args ++ sc_constraints ++ arg_constraints) } where + (tc_binders, _) = splitPiTys (tyConKind rep_tc) + choose_level bndr + | isNamedBinder bndr = KindLevel + | otherwise = TypeLevel + t_or_ks = map choose_level tc_binders ++ repeat TypeLevel + -- want to report *kind* errors when possible + arg_constraints = con_arg_constraints get_std_constrained_tys -- Constraints arising from the arguments of each constructor - con_arg_constraints :: (CtOrigin -> Type -> [PredOrigin]) -> [PredOrigin] + con_arg_constraints :: (CtOrigin -> TypeOrKind -> Type -> [PredOrigin]) + -> [PredOrigin] con_arg_constraints get_arg_constraints = [ pred | data_con <- tyConDataCons rep_tc - , (arg_n, arg_ty) <- ASSERT( isVanillaDataCon data_con ) - zip [1..] $ -- ASSERT is precondition of dataConInstOrigArgTys - dataConInstOrigArgTys data_con all_rep_tc_args + , (arg_n, arg_t_or_k, arg_ty) + <- zip3 [1..] t_or_ks $ + dataConInstOrigArgTys data_con all_rep_tc_args , not (isUnLiftedType arg_ty) , let orig = DerivOriginDC data_con arg_n - , pred <- get_arg_constraints orig arg_ty ] + , pred <- get_arg_constraints orig arg_t_or_k arg_ty ] + -- No constraints for unlifted types -- See Note [Deriving and unboxed types] -- is_functor_like: see Note [Inferring the instance context] is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind - get_gen1_constraints functor_cls orig ty - = mk_functor_like_constraints orig functor_cls $ + get_gen1_constraints functor_cls orig t_or_k ty + = mk_functor_like_constraints orig t_or_k functor_cls $ get_gen1_constrained_tys last_tv ty - get_std_constrained_tys :: CtOrigin -> Type -> [PredOrigin] - get_std_constrained_tys orig ty - | is_functor_like = mk_functor_like_constraints orig main_cls $ + get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type -> [PredOrigin] + get_std_constrained_tys orig t_or_k ty + | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $ deepSubtypesContaining last_tv ty - | otherwise = [mk_cls_pred orig main_cls ty] + | otherwise = [mk_cls_pred orig t_or_k main_cls ty] - mk_functor_like_constraints :: CtOrigin -> Class -> [Type] -> [PredOrigin] + mk_functor_like_constraints :: CtOrigin -> TypeOrKind + -> Class -> [Type] -> [PredOrigin] -- 'cls' is usually main_cls (Functor or Traversable etc), but if -- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints -- @@ -936,11 +950,12 @@ inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args -- The second constraint checks that the first is well-kinded. -- Lacking that, as Trac #10561 showed, we can just generate an -- ill-kinded instance. - mk_functor_like_constraints orig cls tys - = [ pred + mk_functor_like_constraints orig t_or_k cls tys + = [ pred_o | ty <- tys - , pred <- [ mk_cls_pred orig cls ty - , mkPredOrigin orig (mkEqPred (typeKind ty) typeToTypeKind) ] ] + , pred_o <- [ mk_cls_pred orig t_or_k cls ty + , mkPredOrigin orig KindLevel + (mkPrimEqPred (typeKind ty) typeToTypeKind) ] ] rep_tc_tvs = tyConTyVars rep_tc last_tv = last rep_tc_tvs @@ -952,16 +967,16 @@ inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args cls_tvs = classTyVars main_cls inst_tys = cls_tys ++ [inst_ty] sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc) - mkThetaOrigin DerivOrigin $ + mkThetaOrigin DerivOrigin TypeLevel $ substTheta cls_subst (classSCTheta main_cls) cls_subst = ASSERT( equalLength cls_tvs inst_tys ) - zipOpenTvSubst cls_tvs inst_tys + zipOpenTCvSubst cls_tvs inst_tys -- Stupid constraints - stupid_constraints = mkThetaOrigin DerivOrigin $ + stupid_constraints = mkThetaOrigin DerivOrigin TypeLevel $ substTheta tc_subst (tyConStupidTheta rep_tc) tc_subst = ASSERT( equalLength rep_tc_tvs all_rep_tc_args ) - zipTopTvSubst rep_tc_tvs all_rep_tc_args + zipTopTCvSubst rep_tc_tvs all_rep_tc_args -- Extra Data constraints -- The Data class (only) requires that for @@ -974,13 +989,14 @@ inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args extra_constraints | main_cls `hasKey` dataClassKey , all (isLiftedTypeKind . typeKind) rep_tc_args - = map (mk_cls_pred DerivOrigin main_cls) rep_tc_args + = [ mk_cls_pred DerivOrigin t_or_k main_cls ty + | (t_or_k, ty) <- zip t_or_ks rep_tc_args] | otherwise = [] - mk_cls_pred orig cls ty -- Don't forget to apply to cls_tys too + mk_cls_pred orig t_or_k cls ty -- Don't forget to apply to cls_tys too -- In the awkward Generic1 casde, cls_tys is empty - = mkPredOrigin orig (mkClassPred cls (cls_tys ++ [ty])) + = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys ++ [ty])) {- Note [Getting base classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1140,7 +1156,7 @@ canDeriveAnyClass dflags _tycon clas target_kind = tyVarKind (last (classTyVars clas)) typeToTypeKind :: Kind -typeToTypeKind = liftedTypeKind `mkArrowKind` liftedTypeKind +typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind type Condition = (DynFlags, TyCon, [Type]) -> Validity -- first Bool is whether or not we are allowed to derive Data and Typeable @@ -1268,7 +1284,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _) tc_tvs = tyConTyVars rep_tc Just (_, last_tv) = snocView tc_tvs bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc) - is_bad pred = last_tv `elemVarSet` tyVarsOfType pred + is_bad pred = last_tv `elemVarSet` tyCoVarsOfType pred data_cons = tyConDataCons rep_tc check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) @@ -1280,7 +1296,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _) -- in TcGenDeriv | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) , tv `elem` dataConUnivTyVars con - , not (tv `elemVarSet` tyVarsOfTypes (dataConTheta con)) + , not (tv `elemVarSet` tyCoVarsOfTypes (dataConTheta con)) = IsValid -- See Note [Check that the type variable is truly universal] | otherwise = NotValid (badCon con existential) @@ -1404,7 +1420,7 @@ a context for the Data instances: ************************************************************************ -} -mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -> Class +mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [TyVar] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] -> DerivContext -> TcRn EarlyDerivSpec @@ -1420,20 +1436,20 @@ mkNewTypeEqn dflags overlap_mode tvs case mtheta of Just theta -> return $ GivenTheta $ DS { ds_loc = loc - , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs + , ds_name = dfun_name, ds_tvs = varSetElemsWellScoped dfun_tvs , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tycon, ds_tc_args = rep_tc_args + , ds_tc = rep_tycon , ds_theta = theta , ds_overlap = overlap_mode - , ds_newtype = True } + , ds_newtype = Just rep_inst_ty } Nothing -> return $ InferTheta $ DS { ds_loc = loc - , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs + , ds_name = dfun_name, ds_tvs = varSetElemsWellScoped dfun_tvs , ds_cls = cls, ds_tys = inst_tys - , ds_tc = rep_tycon, ds_tc_args = rep_tc_args + , ds_tc = rep_tycon , ds_theta = all_preds , ds_overlap = overlap_mode - , ds_newtype = True } + , ds_newtype = Just rep_inst_ty } | otherwise = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of -- Error with standard class @@ -1514,7 +1530,7 @@ mkNewTypeEqn dflags overlap_mode tvs rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args rep_tys = cls_tys ++ [rep_inst_ty] rep_pred = mkClassPred cls rep_tys - rep_pred_o = mkPredOrigin DerivOrigin rep_pred + rep_pred_o = mkPredOrigin DerivOrigin TypeLevel rep_pred -- rep_pred is the representation dictionary, from where -- we are gong to get all the methods for the newtype -- dictionary @@ -1524,12 +1540,12 @@ mkNewTypeEqn dflags overlap_mode tvs -- See Note [Newtype deriving superclasses] above cls_tyvars = classTyVars cls - dfun_tvs = tyVarsOfTypes inst_tys + dfun_tvs = tyCoVarsOfTypes inst_tys inst_ty = mkTyConApp tycon tc_args inst_tys = cls_tys ++ [inst_ty] sc_theta = - mkThetaOrigin DerivOrigin $ - substTheta (zipOpenTvSubst cls_tyvars inst_tys) (classSCTheta cls) + mkThetaOrigin DerivOrigin TypeLevel $ + substTheta (zipOpenTCvSubst cls_tyvars inst_tys) (classSCTheta cls) -- Next we collect Coercible constraints between @@ -1537,8 +1553,9 @@ mkNewTypeEqn dflags overlap_mode tvs -- newtype type; precisely the constraints required for the -- calls to coercible that we are going to generate. coercible_constraints = - [ let (Pair t1 t2) = mkCoerceClassMethEqn cls (varSetElemsKvsFirst dfun_tvs) inst_tys rep_inst_ty meth - in mkPredOrigin (DerivOriginCoerce meth t1 t2) (mkCoerciblePred t1 t2) + [ let (Pair t1 t2) = mkCoerceClassMethEqn cls (varSetElemsWellScoped dfun_tvs) inst_tys rep_inst_ty meth + in mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel + (mkReprPrimEqPred t1 t2) | meth <- classMethods cls ] -- If there are no tyvars, there's no need @@ -1801,23 +1818,27 @@ simplifyDeriv pred tvs theta ; let skol_set = mkVarSet tvs_skols doc = ptext (sLit "deriving") <+> parens (ppr pred) - ; wanted <- mapM (\(PredOrigin t o) -> newWanted o (substTy skol_subst t)) theta + ; wanted <- mapM (\(PredOrigin t o t_or_k) + -> newWanted o (Just t_or_k) (substTy skol_subst t)) theta ; traceTc "simplifyDeriv" $ vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] - ; residual_wanted <- solveWantedsTcM wanted + ; residual_wanted <- simplifyWantedsTcM wanted ; residual_simple <- zonkSimples (wc_simple residual_wanted) ; let (good, bad) = partitionBagWith get_good residual_simple -- See Note [Exotic derived instance contexts] + get_good :: Ct -> Either PredType Ct get_good ct | validDerivPred skol_set p - , isWantedCt ct = Left p - -- NB: residual_wanted may contain unsolved - -- Derived and we stick them into the bad set - -- so that reportUnsolved may decide what to do with them - | otherwise = Right ct - where p = ctPred ct + , isWantedCt ct + = Left p + -- NB: residual_wanted may contain unsolved + -- Derived and we stick them into the bad set + -- so that reportUnsolved may decide what to do with them + | otherwise + = Right ct + where p = ctPred ct ; traceTc "simplifyDeriv 2" $ vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ] @@ -1829,7 +1850,7 @@ simplifyDeriv pred tvs theta ; unless defer (reportAllUnsolved (residual_wanted { wc_simple = bad })) ; let min_theta = mkMinimalBySCs (bagToList good) - subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + subst_skol = zipTopTCvSubst tvs_skols $ mkTyVarTys tvs -- The reverse substitution (sigh) ; return (substTheta subst_skol min_theta) } @@ -1983,10 +2004,10 @@ the renamer. What a great hack! -- genInst :: DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) -genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args +genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys , ds_name = dfun_name, ds_cls = clas, ds_loc = loc }) - | is_newtype -- See Note [Bindings for Generalised Newtype Deriving] + | Just rhs_ty <- is_newtype -- See Note [Bindings for Generalised Newtype Deriving] = do { inst_spec <- newDerivClsInst theta spec ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty]) ; return ( InstInfo @@ -2016,8 +2037,6 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ib_extensions = [] , ib_derived = True } } ; return ( inst_info, deriv_stuff, Nothing ) } - where - rhs_ty = newTyConInstRhs rep_tycon rep_tc_args -- Generate the bindings needed for a derived class that isn't handled by -- -XGeneralizedNewtypeDeriving. @@ -2049,7 +2068,8 @@ genDerivStuff loc clas dfun_name tycon inst_tys tyvars -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving -- fell through). let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + mini_subst = mkTCvSubst (mkInScopeSet (mkVarSet tyvars)) + (mini_env, emptyCvSubstEnv) ; tyfam_insts <- ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 368fd178a8..31ddf7dd35 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -48,7 +48,7 @@ module TcEnv( tcGetDefaultTys, -- Global type variables - tcGetGlobalTyVars, + tcGetGlobalTyCoVars, -- Template Haskell stuff checkWellStaged, tcMetaTy, thLevel, @@ -82,7 +82,6 @@ import PatSyn ( PatSyn ) import ConLike import TyCon import CoAxiom -import TypeRep import Class import Name import NameEnv @@ -211,7 +210,7 @@ tcLookupLocatedTyCon :: Located Name -> TcM TyCon tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Find the instance that exactly matches a type class application. The class arguments must be precisely --- the same as in the instance declaration (modulo renaming). +-- the same as in the instance declaration (modulo renaming & casts). -- tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys @@ -225,10 +224,8 @@ tcLookupInstance cls tys where errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)") - uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys) - where - extractTyVar (TyVarTy tv) = tv - extractTyVar _ = panic "TcEnv.tcLookupInstance: extractTyVar" + uniqueTyVars tys = all isTyVarTy tys + && hasNoDups (map (getTyVar "tcLookupInstance") tys) tcGetInstEnvs :: TcM InstEnvs -- Gets both the external-package inst-env @@ -359,7 +356,6 @@ tcLookupLocalIds ns _ -> pprPanic "tcLookupLocalIds" (ppr name) getInLocalScope :: TcM (Name -> Bool) - -- Ids only getInLocalScope = do { lcl_env <- getLclTypeEnv ; return (`elemNameEnv` lcl_env) } @@ -373,8 +369,8 @@ tcExtendKindEnv2 things thing_inside upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r -tcExtendKindEnv name_kind_prs - = tcExtendKindEnv2 [(n, AThing k) | (n,k) <- name_kind_prs] +tcExtendKindEnv nks + = tcExtendKindEnv2 $ mapSnd AThing nks ----------------------- -- Scoped type and kind variables @@ -384,6 +380,8 @@ tcExtendTyVarEnv tvs thing_inside tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r tcExtendTyVarEnv2 binds thing_inside + -- this should be used only for explicitly mentioned scoped variables. + -- thus, no coercion variables = do { tc_extend_local_env NotTopLevel [(name, ATyVar name tv) | (name, tv) <- binds] $ do { env <- getLclEnv @@ -397,7 +395,8 @@ tcExtendTyVarEnv2 binds thing_inside -- OccName that the programmer originally used for them add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv add (env,subst) (name, tyvar) - = case tidyOccName env (nameOccName name) of + = ASSERT( isTyVar tyvar ) + case tidyOccName env (nameOccName name) of (env', occ') -> (env', extendVarEnv subst tyvar tyvar') where tyvar' = setTyVarName tyvar name' @@ -414,8 +413,8 @@ isClosedLetBndr :: Id -> TopLevelFlag -- looking at its type, which is slightly more liberal, and a whole -- lot easier to implement, than looking at its free variables isClosedLetBndr id - | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel - | otherwise = NotTopLevel + | isEmptyVarSet (tyCoVarsOfType (idType id)) = TopLevel + | otherwise = NotTopLevel tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a -- Used for both top-level value bindings and and nested let/where-bindings @@ -465,7 +464,7 @@ tc_extend_local_env top_lvl extra_env thing_inside -- (see Kind.defaultKind, done in zonkQuantifiedTyVar) -- (b) There are no via-Indirect occurrences of the bound variables -- in the types, because instantiation does not look through such things --- (c) The call to tyVarsOfTypes is ok without looking through refs +-- (c) The call to tyCoVarsOfTypes is ok without looking through refs -- The second argument of type TyVarSet is a set of type variables -- that are bound together with extra_env and should not be regarded @@ -507,12 +506,12 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things TopLevel -> ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs NotTopLevel -> tvs `unionVarSet` id_tvs - where id_tvs = tyVarsOfType (idType id) + where id_tvs = tyCoVarsOfType (idType id) get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars] - = tvs `unionVarSet` tyVarsOfType (tyVarKind tv) `extendVarSet` tv + = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv - get_tvs (_, AThing k) tvs = tvs `unionVarSet` tyVarsOfType k + get_tvs (_, AThing k) tvs = tvs `unionVarSet` tyCoVarsOfType k get_tvs (_, AGlobal {}) tvs = tvs get_tvs (_, APromotionErr {}) tvs = tvs @@ -716,7 +715,7 @@ data InstBindings a , ib_derived :: Bool -- True <=> This code was generated by GHC from a deriving clause -- or standalone deriving declaration - -- Used only to improve error messages + -- Used only to improve error messages } instance OutputableBndr a => Outputable (InstInfo a) where @@ -862,7 +861,7 @@ notFound name vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> ptext (sLit "is not in scope during type checking, but it passed the renamer"), ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)] - -- Take case: printing the whole gbl env can + -- Take care: printing the whole gbl env can -- cause an infinite loop, in the case where we -- are in the middle of a recursive TyCon/Class group; -- so let's just not print it! Getting a loop here is diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 05befd5364..94cd9ad433 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -14,21 +14,23 @@ import TcRnMonad import TcMType import TcType import RnEnv( unknownNameSuggestions ) -import TypeRep import Type -import Kind ( isKind ) +import TyCoRep +import Kind import Unify ( tcMatchTys ) import Module import FamInst +import FamInstEnv ( flattenTys ) import Inst import InstEnv import TyCon +import Class import DataCon import TcEvidence import Name import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) -import Class( className ) -import PrelNames( typeableClassName ) +import PrelNames ( typeableClassName, hasKey + , liftedDataConKey, unliftedDataConKey ) import Id import Var import VarSet @@ -44,9 +46,9 @@ import SrcLoc import DynFlags import StaticFlags ( opt_PprStyle_Debug ) import ListSetOps ( equivClasses ) +import Maybes import Control.Monad ( when ) -import Data.Maybe import Data.List ( partition, mapAccumL, nub, sortBy ) #if __GLASGOW_HASKELL__ < 709 @@ -163,8 +165,8 @@ report_unsolved mb_binds_var err_as_warn type_errors expr_holes type_holes wante ; env0 <- tcInitTidyEnv -- If we are deferring we are going to need /all/ evidence around, -- including the evidence produced by unflattening (zonkWC) - ; let tidy_env = tidyFreeTyVars env0 free_tvs - free_tvs = tyVarsOfWC wanted + ; let tidy_env = tidyFreeTyCoVars env0 free_tvs + free_tvs = tyCoVarsOfWC wanted ; traceTc "reportUnsolved (after zonking and tidying):" $ vcat [ pprTvBndrs (varSetElems free_tvs) @@ -280,7 +282,7 @@ Specifically (see reportWanteds) reportImplic :: ReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given - , ic_wanted = wanted, ic_binds = evb + , ic_wanted = wanted, ic_binds = m_evb , ic_status = status, ic_info = info , ic_env = tcl_env, ic_tclvl = tc_lvl }) | BracketSkol <- info @@ -297,7 +299,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given warnRedundantConstraints ctxt' tcl_env info' dead_givens } where insoluble = isInsolubleStatus status - (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs + (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs (env2, info') = tidySkolemInfo env1 info implic' = implic { ic_skols = tvs' , ic_given = map (tidyEvVar env2) given @@ -307,9 +309,11 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given , cec_suppress = insoluble -- Suppress inessential errors if there -- are are insolubles anywhere in the -- tree rooted here - , cec_binds = case cec_binds ctxt of - Nothing -> Nothing - Just {} -> Just evb } + , cec_binds = cec_binds ctxt *> m_evb } + -- if cec_binds ctxt is Nothing, that means + -- we're reporting *all* errors. Don't change + -- that behavior just because we're going into + -- an implication. dead_givens = case status of IC_Solved { ics_dead = dead } -> dead _ -> [] @@ -573,16 +577,23 @@ maybeReportError ctxt err addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct - | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- ctEvidence ct + | CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct -- Only add deferred bindings for Wanted constraints , Just ev_binds_var <- cec_binds ctxt -- We have somewhere to put the bindings = do { dflags <- getDynFlags ; let err_msg = pprLocErrMsg err err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" + err_tm = EvDelayedError pred err_fs - -- Create the binding - ; addTcEvBind ev_binds_var (mkWantedEvBind ev_id (EvDelayedError pred err_fs)) } + ; case dest of + EvVarDest evar + -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm + HoleDest hole + -> do { -- See Note [Deferred errors for coercion holes] + evar <- newEvVar pred + ; addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm + ; fillCoercionHole hole (mkTcCoVarCo evar) }} | otherwise -- Do not set any evidence for Given/Derived = return () @@ -707,6 +718,15 @@ is perhaps a bit *over*-consistent! Again, an easy choice to change. With #10283, you can now opt out of deferred type error warnings. +Note [Deferred errors for coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we need to defer a type error where the destination for the evidence +is a coercion hole. We can't just put the error in the hole, because we can't +make an erroneous coercion. (Remember that coercions are erased for runtime.) +Instead, we invent a new EvVar, bind it to an error and then make a coercion +from that EvVar, filling the hole with that coercion. Because coercions' +types are unlifted, the error is guaranteed to be hit before we get to the +coercion. Note [Do not report derived but soluble errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -798,7 +818,7 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) ct_loc = ctLoc ct lcl_env = ctLocEnv ct_loc hole_ty = ctEvPred (ctEvidence ct) - tyvars = tyVarsOfTypeList hole_ty + tyvars = tyCoVarsOfTypeList hole_ty boring_type = isTyVarTy hole_ty out_of_scope_msg -- Print v :: ty only if the type has structure @@ -834,10 +854,16 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) = empty loc_msg tv + | isTyVar tv = case tcTyVarDetails tv of SkolemTv {} -> pprSkol (cec_encl ctxt) tv MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable") det -> pprTcTyVarDetails det + | otherwise + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitCoercions dflags + then quotes (ppr tv) <+> text "is a coercion variable" + else empty mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) @@ -908,7 +934,8 @@ mkEqErr1 ctxt ct ; rdr_env <- getGlobalRdrEnv ; fam_envs <- tcGetFamInstEnvs ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let (is_oriented, wanted_msg) = mk_wanted_extra (ctOrigin ct) exp_syns + ; let (keep_going, is_oriented, wanted_msg) + = mk_wanted_extra (ctLoc ct) exp_syns coercible_msg = case ctEqRel ct of NomEq -> empty ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 @@ -916,7 +943,9 @@ mkEqErr1 ctxt ct ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) ; let report = mconcat [important wanted_msg, important coercible_msg, relevant_bindings binds_msg] - ; mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 } + ; if keep_going + then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 + else mkErrorMsgFromCt ctxt ct report } where (ty1, ty2) = getEqPredTys (ctPred ct) @@ -930,23 +959,34 @@ mkEqErr1 ctxt ct -- If the types in the error message are the same as the types -- we are unifying, don't add the extra expected/actual message - mk_wanted_extra :: CtOrigin -> Bool -> (Maybe SwapFlag, SDoc) - mk_wanted_extra orig@(TypeEqOrigin {}) expandSyns - = mkExpectedActualMsg ty1 ty2 orig expandSyns - - mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) expandSyns - = (Nothing, msg1 $$ msg2) - where - msg1 = hang (ptext (sLit "When matching types")) - 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1) - , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ]) - msg2 = case sub_o of - TypeEqOrigin {} -> - snd (mkExpectedActualMsg cty1 cty2 sub_o expandSyns) - _ -> - empty - - mk_wanted_extra _ _ = (Nothing, empty) + mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc) + mk_wanted_extra loc expandSyns + = case ctLocOrigin loc of + orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig + t_or_k expandSyns + where + t_or_k = ctLocTypeOrKind_maybe loc + + KindEqOrigin cty1 cty2 sub_o sub_t_or_k + -> (True, Nothing, msg1 $$ msg2) + where + sub_what = case sub_t_or_k of Just KindLevel -> text "kinds" + _ -> text "types" + msg1 = sdocWithDynFlags $ \dflags -> + if not (gopt Opt_PrintExplicitCoercions dflags) && + (cty1 `pickyEqType` cty2) + then text "When matching the kind of" <+> quotes (ppr cty1) + else + hang (text "When matching" <+> sub_what) + 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ]) + msg2 = case sub_o of + TypeEqOrigin {} -> + thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k + expandSyns) + _ -> + empty + _ -> (True, Nothing, empty) -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint -- is left over. @@ -1015,6 +1055,8 @@ mkRoleSigs ty1 ty2 ppr_role_sig tc | null roles -- if there are no parameters, don't bother printing = Nothing + | isBuiltInSyntax (tyConName tc) -- don't print roles for (->), etc. + = Nothing | otherwise = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles where @@ -1060,15 +1102,11 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 -- So tv is a meta tyvar (or started that way before we -- generalised it). So presumably it is an *untouchable* -- meta tyvar or a SigTv, else it'd have been unified - | not (k2 `tcIsSubKind` k1) -- Kind error - = mkErrorMsgFromCt ctxt ct $ - (important $ kindErrorMsg (mkTyVarTy tv1) ty2) `mappend` report - | OC_Occurs <- occ_check_expand , ctEqRel ct == NomEq || isTyVarUnderDatatype tv1 ty2 -- See Note [Occurs check error] in TcCanonical = do { let occCheckMsg = important $ addArising (ctOrigin ct) $ - hang (text "Occurs check: cannot construct the infinite type:") + hang (text "Occurs check: cannot construct the infinite" <+> what <> colon) 2 (sep [ppr ty1, char '~', ppr ty2]) extra2 = important $ mkEqInfoMsg ct ty1 ty2 ; mkErrorMsgFromCt ctxt ct $ mconcat [occCheckMsg, extra2, report] } @@ -1076,7 +1114,7 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 | OC_Forall <- occ_check_expand = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable") <+> quotes (ppr tv1) - , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2) + , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2) , nest 2 (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) ] -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely @@ -1099,10 +1137,10 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic - , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols + , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 - esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols <+> pprQuotedList esc_skols , ptext (sLit "would escape") <+> if isSingleton esc_skols then ptext (sLit "its scope") @@ -1110,8 +1148,10 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 tv_extra = important $ vcat [ nest 2 $ esc_doc , sep [ (if isSingleton esc_skols - then ptext (sLit "This (rigid, skolem) type variable is") - else ptext (sLit "These (rigid, skolem) type variables are")) + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") <+> ptext (sLit "bound by") , nest 2 $ ppr skol_info , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ] @@ -1139,18 +1179,21 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 -- Not an occurs check, because F is a type function. where occ_check_expand = occurCheckExpand dflags tv1 ty2 - k1 = tyVarKind tv1 - k2 = typeKind ty2 ty1 = mkTyVarTy tv1 + what = case ctLocTypeOrKind_maybe (ctLoc ct) of + Just KindLevel -> text "kind" + _ -> text "type" + mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc -- Report (a) ambiguity if either side is a type function application -- e.g. F a0 ~ Int -- (b) warning about injectivity if both sides are the same -- type function application F a ~ F b -- See Note [Non-injective type functions] +-- (c) warning about -fprint-explicit-kinds if that might be helpful mkEqInfoMsg ct ty1 ty2 - = tyfun_msg $$ ambig_msg + = tyfun_msg $$ ambig_msg $$ invis_msg where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2 @@ -1159,6 +1202,15 @@ mkEqInfoMsg ct ty1 ty2 = snd (mkAmbigMsg False ct) | otherwise = empty + invis_msg | Just Invisible <- tcEqTypeVis ty1 ty2 + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitKinds dflags + then text "Use -fprint-explicit-kinds to see the kind arguments" + else empty + + | otherwise + = empty + tyfun_msg | Just tc1 <- mb_fun1 , Just tc2 <- mb_fun2 , tc1 == tc2 @@ -1177,7 +1229,8 @@ isUserSkolem ctxt tv is_user_skol_info (InferSkol {}) = False is_user_skol_info _ = True -misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc +misMatchOrCND :: ReportErrCtxt -> Ct + -> Maybe SwapFlag -> TcType -> TcType -> SDoc -- If oriented then ty1 is actual, ty2 is expected misMatchOrCND ctxt ct oriented ty1 ty2 | null givens || @@ -1252,15 +1305,6 @@ suggestAddSig ctxt ty1 ty2 | otherwise = [] -kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy -kindErrorMsg ty1 ty2 - = vcat [ ptext (sLit "Kind incompatibility when matching types:") - , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 - , ppr ty2 <+> dcolon <+> ppr k2 ]) ] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - -------------------- misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc -- Types are already tidy @@ -1269,6 +1313,13 @@ misMatchMsg ct oriented ty1 ty2 | Just NotSwapped <- oriented = misMatchMsg ct (Just IsSwapped) ty2 ty1 + | Just (tc1, []) <- splitTyConApp_maybe ty1 + , Just (tc2, []) <- splitTyConApp_maybe ty2 + , (tc1 `hasKey` liftedDataConKey && tc2 `hasKey` unliftedDataConKey) || + (tc2 `hasKey` liftedDataConKey && tc1 `hasKey` unliftedDataConKey) + = addArising orig $ + text "Couldn't match a lifted type with an unlifted type" + | otherwise -- So now we have Nothing or (Just IsSwapped) -- For some reason we treat Nothign like IsSwapped = addArising orig $ @@ -1290,8 +1341,9 @@ misMatchMsg ct oriented ty1 ty2 is_oriented = isJust oriented orig = ctOrigin ct - what | isKind ty1 = "kind" - | otherwise = "type" + what = case ctLocTypeOrKind_maybe (ctLoc ct) of + Just KindLevel -> "kind" + _ -> "type" conc :: [String] -> String conc = foldr1 add_space @@ -1301,20 +1353,104 @@ misMatchMsg ct oriented ty1 ty2 | null s2 = s1 | otherwise = s1 ++ (' ' : s2) -mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Bool - -> (Maybe SwapFlag, SDoc) +mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool + -> (Bool, Maybe SwapFlag, SDoc) -- NotSwapped means (actual, expected), IsSwapped is the reverse -mkExpectedActualMsg ty1 ty2 - (TypeEqOrigin { uo_actual = act, uo_expected = exp }) printExpanded - | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just NotSwapped, empty) - | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just IsSwapped, empty) - | otherwise = (Nothing, msg) +-- First return val is whether or not to print a herald above this msg +mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp + , uo_thing = maybe_thing }) + m_level printExpanded + | KindLevel <- level, occurs_check_error = (True, Nothing, empty) + | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2) + | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3) + | isLiftedTypeKind exp && not (isConstraintKind exp) + = (False, Nothing, msg4) + | Just msg <- num_args_msg = (False, Nothing, msg $$ msg1) + | KindLevel <- level, Just th <- maybe_thing = (False, Nothing, msg5 th) + | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty) + | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty) + | otherwise = (True, Nothing, msg1) where - msg = vcat - [ text "Expected type:" <+> ppr exp - , text " Actual type:" <+> ppr act - , if printExpanded then expandedTys else empty - ] + level = m_level `orElse` TypeLevel + + occurs_check_error + | Just act_tv <- tcGetTyVar_maybe act + , act_tv `elemVarSet` tyCoVarsOfType exp + = True + | Just exp_tv <- tcGetTyVar_maybe exp + , exp_tv `elemVarSet` tyCoVarsOfType act + = True + | otherwise + = False + + sort = case level of + TypeLevel -> text "type" + KindLevel -> text "kind" + + msg1 = case level of + KindLevel + | Just th <- maybe_thing + -> msg5 th + + _ | not (act `pickyEqType` exp) + -> vcat [ text "Expected" <+> sort <> colon <+> ppr exp + , text " Actual" <+> sort <> colon <+> ppr act + , if printExpanded then expandedTys else empty ] + + | otherwise + -> empty + + thing_msg = case maybe_thing of + Just thing -> \_ -> quotes (ppr thing) <+> text "is" + Nothing -> \vowel -> text "got a" <> + if vowel then char 'n' else empty + msg2 = sep [ text "Expecting a lifted type, but" + , thing_msg True, text "unlifted" ] + msg3 = sep [ text "Expecting an unlifted type, but" + , thing_msg False, text "lifted" ] + msg4 = maybe_num_args_msg $$ + sep [ text "Expected a type, but" + , maybe (text "found something with kind") + (\thing -> quotes (ppr thing) <+> text "has kind") + maybe_thing + , quotes (ppr act) ] + + msg5 th = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr th) <+> text "has kind" <+> + quotes (ppr act)) + where + kind_desc | isConstraintKind exp = text "a constraint" + | otherwise = text "kind" <+> quotes (ppr exp) + + num_args_msg = case level of + TypeLevel -> Nothing + KindLevel + -> let n_act = count_args act + n_exp = count_args exp in + case n_act - n_exp of + n | n /= 0 + , Just thing <- maybe_thing + , case errorThingNumArgs_maybe thing of + Nothing -> n > 0 + Just num_act_args -> num_act_args >= -n + -- don't report to strip off args that aren't there + -> Just $ text "Expecting" <+> speakN (abs n) <+> + more_or_fewer <+> plural_n (abs n) (text "argument") + <+> text "to" <+> quotes (ppr thing) + where + more_or_fewer | n < 0 = text "fewer" + | otherwise = text "more" + _ -> Nothing + + + maybe_num_args_msg = case num_args_msg of + Nothing -> empty + Just m -> m + + count_args ty = count isVisibleBinder $ fst $ splitPiTys ty + + plural_n 1 doc = doc + plural_n _ doc = doc <> char 's' expandedTys = ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat @@ -1325,34 +1461,7 @@ mkExpectedActualMsg ty1 ty2 (expTy1, expTy2) = expandSynonymsToMatch exp act -mkExpectedActualMsg _ _ _ _ = panic "mkExpectedAcutalMsg" - -pickyEqType :: TcType -> TcType -> Bool --- ^ Check when two types _look_ the same, _including_ synonyms. --- So (pickyEqType String [Char]) returns False -pickyEqType ty1 ty2 - = go init_env ty1 ty2 - where - init_env = - mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) - go env (TyVarTy tv1) (TyVarTy tv2) = - rnOccL env tv1 == rnOccR env tv2 - go _ (LitTy lit1) (LitTy lit2) = - lit1 == lit2 - go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = - go env (tyVarKind tv1) (tyVarKind tv2) && go (rnBndr2 env tv1 tv2) t1 t2 - go env (AppTy s1 t1) (AppTy s2 t2) = - go env s1 s2 && go env t1 t2 - go env (FunTy s1 t1) (FunTy s2 t2) = - go env s1 s2 && go env t1 t2 - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = - (tc1 == tc2) && gos env ts1 ts2 - go _ _ _ = - False - - gos _ [] [] = True - gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 - gos _ _ _ = False +mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg" {- Note [Expanding type synonyms to make types similar] @@ -1451,17 +1560,20 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) (exps2, t1_2', t2_2') = go 0 t1_2 t2_2 in (exps + exps1 + exps2, mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - go exps (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) = + go exps (ForAllTy (Anon t1_1) t1_2) (ForAllTy (Anon t2_1) t2_2) = let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1 (exps2, t1_2', t2_2') = go 0 t1_2 t2_2 - in (exps + exps1 + exps2, FunTy t1_1' t1_2', FunTy t2_1' t2_2') + in (exps + exps1 + exps2, mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2') - go exps (ForAllTy tv1 t1) (ForAllTy tv2 t2) = + go exps (ForAllTy (Named tv1 vis1) t1) (ForAllTy (Named tv2 vis2) t2) = -- NOTE: We may have a bug here, but we just can't reproduce it easily. -- See D1016 comments for details and our attempts at producing a test - -- case. + -- case. Short version: We probably need RnEnv2 to really get this right. let (exps1, t1', t2') = go exps t1 t2 - in (exps1, ForAllTy tv1 t1', ForAllTy tv2 t2') + in (exps1, ForAllTy (Named tv1 vis1) t1', ForAllTy (Named tv2 vis2) t2') + + go exps (CastTy ty1 _) ty2 = go exps ty1 ty2 + go exps ty1 (CastTy ty2 _) = go exps ty1 ty2 go exps t1 t2 = (exps, t1, t2) @@ -1558,8 +1670,8 @@ mkDictErr ctxt cts do { inst_envs <- tcGetInstEnvs ; let (ct1:_) = cts -- ct1 just for its location min_cts = elim_superclasses cts - ; lookups <- mapM (lookup_cls_inst inst_envs) min_cts - ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups + lookups = map (lookup_cls_inst inst_envs) min_cts + (no_inst_cts, overlap_cts) = partition is_no_inst lookups -- Report definite no-instance errors, -- or (iff there are none) overlap errors @@ -1574,12 +1686,11 @@ mkDictErr ctxt cts is_no_inst (ct, (matches, unifiers, _)) = no_givens && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct))) + && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyCoVarsOfCt ct))) lookup_cls_inst inst_envs ct - = do { tys_flat <- mapM quickFlattenTy tys -- Note [Flattening in error message generation] - ; return (ct, lookupInstEnv True inst_envs clas tys_flat) } + = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys)) where (clas, tys) = getClassPredTys (ctPred ct) @@ -1588,7 +1699,7 @@ mkDictErr ctxt cts -- [W] Eq a, [W] Ord a -- but we really only want to report the latter elim_superclasses cts - = filter (\ct -> any (eqPred (ctPred ct)) min_preds) cts + = filter (\ct -> any (eqType (ctPred ct)) min_preds) cts where min_preds = mkMinimalBySCs (map ctPred cts) @@ -1631,7 +1742,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) && not (null unifiers) && null givens (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = getAmbigTkvs ct + ambig_tvs = uncurry (++) (getAmbigTkvs ct) no_inst_msg | lead_with_ambig @@ -1678,14 +1789,15 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) ppr_skol skol_info = ppr skol_info - extra_note | any isFunTy (filterOut isKind tys) + extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) = ptext (sLit "(maybe you haven't applied a function to enough arguments?)") | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) , Just (tc,_) <- tcSplitTyConApp_maybe ty , not (isTypeFamilyTyCon tc) = hang (ptext (sLit "GHC can't yet do polykinded")) - 2 (ptext (sLit "Typeable") <+> parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) + 2 (ptext (sLit "Typeable") <+> + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) | otherwise = empty @@ -1725,7 +1837,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) , ppWhen (isSingleton matches) $ parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+> - quotes (pprWithCommas ppr (tyVarsOfTypesList tys)) + quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) , ppWhen (null (matching_givens)) $ vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances") , ptext (sLit "when compiling the other instance declarations")] @@ -1744,7 +1856,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) ev_var_matches ty = case getClassPredTys_maybe ty of Just (clas', tys') | clas' == clas - , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' + , Just _ <- tcMatchTys (tyCoVarsOfTypes tys) tys tys' -> True | otherwise -> any ev_var_matches (immSuperClasses clas' tys') @@ -1787,7 +1899,7 @@ usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo] usefulContext ctxt pred = go (cec_encl ctxt) where - pred_tvs = tyVarsOfType pred + pred_tvs = tyCoVarsOfType pred go [] = [] go (ic : ics) | implausible ic = rest @@ -1891,32 +2003,9 @@ we want to give it a bit of structure. Here's the plan summary with the full list -} -quickFlattenTy :: TcType -> TcM TcType --- See Note [Flattening in error message generation] -quickFlattenTy ty | Just ty' <- coreView ty = quickFlattenTy ty' -quickFlattenTy ty@(TyVarTy {}) = return ty -quickFlattenTy ty@(ForAllTy {}) = return ty -- See -quickFlattenTy ty@(LitTy {}) = return ty - -- Don't flatten because of the danger or removing a bound variable -quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 - ; fy2 <- quickFlattenTy ty2 - ; return (AppTy fy1 fy2) } -quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 - ; fy2 <- quickFlattenTy ty2 - ; return (FunTy fy1 fy2) } -quickFlattenTy (TyConApp tc tys) - | not (isTypeFamilyTyCon tc) - = do { fys <- mapM quickFlattenTy tys - ; return (TyConApp tc fys) } - | otherwise - = do { let (funtys,resttys) = splitAt (tyConArity tc) tys - -- Ignore the arguments of the type family funtys - ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys)) - ; flat_resttys <- mapM quickFlattenTy resttys - ; return (foldl AppTy (mkTyVarTy v) flat_resttys) } - -{- Note [Flattening in error message generation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- +Note [Flattening in error message generation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (C (Maybe (F x))), where F is a type function, and we have instances C (Maybe Int) and C (Maybe a) @@ -1931,13 +2020,6 @@ Re-flattening is pretty easy, because we don't need to keep track of evidence. We don't re-use the code in TcCanonical because that's in the TcS monad, and we are in TcM here. -Note [Quick-flatten polytypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from -flattening any further. After all, there can be no instance declarations -that match such things. And flattening under a for-all is problematic -anyway; consider C (forall a. F a) - Note [Suggest -fprint-explicit-kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be terribly confusing to get an error message like (Trac #9171) @@ -1952,13 +2034,13 @@ variables are kind variables. mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence -> Ct -> (Bool, SDoc) mkAmbigMsg prepend_msg ct - | null ambig_tkvs = (False, empty) - | otherwise = (True, msg) + | null ambig_kvs && null ambig_tvs = (False, empty) + | otherwise = (True, msg) where - ambig_tkvs = getAmbigTkvs ct - (ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs + (ambig_kvs, ambig_tvs) = getAmbigTkvs ct - msg | any isRuntimeUnkSkol ambig_tkvs -- See Note [Runtime skolems] + msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] + || any isRuntimeUnkSkol ambig_tvs = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs <+> pprQuotedList ambig_tvs , ptext (sLit "Use :print or :force to determine these types")] @@ -1991,7 +2073,8 @@ pprSkol implics tv | (skol_tvs, skol_info) <- getSkolemInfo implics tv = case skol_info of UnkSkol -> pp_tv <+> ptext (sLit "is an unknown type variable") - SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt (mkForAllTys skol_tvs ty)) + SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt + (mkInvForAllTys skol_tvs ty)) _ -> ppr_rigid (pprSkolInfo skol_info) where pp_tv = quotes (ppr tv) @@ -1999,11 +2082,14 @@ pprSkol implics tv 2 (sep [ pp_info , ptext (sLit "at") <+> ppr (getSrcLoc tv) ]) -getAmbigTkvs :: Ct -> [Var] +getAmbigTkvs :: Ct -> ([Var],[Var]) getAmbigTkvs ct - = varSetElems ambig_tkv_set + = partition (`elemVarSet` dep_tkv_set) ambig_tkvs where - ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct) + tkv_set = tyCoVarsOfCt ct + ambig_tkv_set = filterVarSet isAmbiguousTyVar tkv_set + dep_tkv_set = tyCoVarsOfTypes (map tyVarKind (varSetElems tkv_set)) + ambig_tkvs = varSetElems ambig_tkv_set getSkolemInfo :: [Implication] -> TcTyVar -> ([TcTyVar], SkolemInfo) -- Get the skolem info for a type variable @@ -2033,13 +2119,13 @@ relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering relevantBindings want_filtering ctxt ct = do { dflags <- getDynFlags ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - ; let ct_tvs = tyVarsOfCt ct `unionVarSet` extra_tvs + ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs -- For *kind* errors, report the relevant bindings of the -- enclosing *type* equality, because that's more useful for the programmer extra_tvs = case tidy_orig of - KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2] - _ -> emptyVarSet + KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] + _ -> emptyVarSet ; traceTc "relevantBindings" $ vcat [ ppr ct , pprCtOrigin (ctLocOrigin loc) @@ -2085,7 +2171,7 @@ relevantBindings want_filtering ctxt ct go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs) = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyVarsOfType tidy_ty + ; let id_tvs = tyCoVarsOfType tidy_ty doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty , nest 2 (parens (ptext (sLit "bound at") <+> ppr (getSrcLoc id)))] @@ -2118,8 +2204,8 @@ warnDefaulting :: [Ct] -> Type -> TcM () warnDefaulting wanteds default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 $ - foldr (unionVarSet . tyVarsOfCt) emptyVarSet wanteds + ; let tidy_env = tidyFreeTyCoVars env0 $ + foldr (unionVarSet . tyCoVarsOfCt) emptyVarSet wanteds tidy_wanteds = map (tidyCt tidy_env) wanteds (loc, ppr_wanteds) = pprWithArising tidy_wanteds warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") @@ -2147,7 +2233,7 @@ solverDepthErrorTcS loc ty = setCtLocM loc $ do { ty <- zonkTcType ty ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType ty) + ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfType ty) tidy_ty = tidyType tidy_env ty msg = vcat [ text "Reduction stack overflow; size =" <+> ppr depth diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 18f162256d..032cc54730 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -13,50 +13,50 @@ module TcEvidence ( -- Evidence bindings TcEvBinds(..), EvBindsVar(..), EvBindMap(..), emptyEvBindMap, extendEvBinds, - lookupEvBind, evBindMapBinds, foldEvBindMap, + lookupEvBind, evBindMapBinds, foldEvBindMap, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, + sccEvBinds, evBindVar, EvTerm(..), mkEvCast, evVarsOfTerm, mkEvScSelectors, EvLit(..), evTermCoercion, EvCallStack(..), EvTypeable(..), -- TcCoercion - TcCoercion(..), TcCoercionR, TcCoercionN, - LeftOrRight(..), pickLR, + TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, + Role(..), LeftOrRight(..), pickLR, mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, - mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo, + mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, - tcDowngradeRole, mkTcTransAppCo, - mkTcAxiomRuleCo, mkTcPhantomCo, - tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo, - isTcReflCo, getTcCoVar_maybe, - tcCoercionRole, eqVarRole, + tcDowngradeRole, + mkTcAxiomRuleCo, mkTcCoherenceLeftCo, mkTcCoherenceRightCo, mkTcPhantomCo, + mkTcKindCo, + tcCoercionKind, coVarsOfTcCo, + mkTcCoVarCo, + isTcReflCo, + tcCoercionRole, unwrapIP, wrapIP ) where #include "HsVersions.h" import Var +import CoAxiom import Coercion import PprCore () -- Instance OutputableBndr TyVar -import TypeRep -- Knows type representation import TcType import Type import TyCon import Class( Class ) -import CoAxiom import PrelNames +import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) import VarEnv import VarSet import Name +import Pair import Util import Bag -import Pair -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative -import Data.Traversable (traverse, sequenceA) -#endif +import Digraph import qualified Data.Data as Data import Outputable import FastString @@ -71,483 +71,82 @@ Coercions have free variables of type (a ~# b): we call these CoVars. However, the type checker passes around equality evidence (boxed up) at type (a ~ b). -An TcCoercion is simply a Coercion whose free variables have the -boxed type (a ~ b). After we are done with typechecking the -desugarer finds the free variables, unboxes them, and creates a -resulting real Coercion with kosher free variables. - -We can use most of the Coercion "smart constructors" to build TcCoercions. -However, mkCoVarCo will not work! The equivalent is mkTcCoVarCo. - -The data type is similar to Coercion.Coercion, with the following -differences - * Most important, TcLetCo adds let-bindings for coercions. - This is what lets us unify two for-all types and generate - equality constraints underneath - - * The kind of a TcCoercion is t1 ~ t2 (resp. Coercible t1 t2) - of a Coercion is t1 ~# t2 (resp. t1 ~#R t2) - - * UnsafeCo aren't required, but we do have TcPhantomCo - - * Representation invariants are weaker: - - we are allowed to have type synonyms in TcTyConAppCo - - the first arg of a TcAppCo can be a TcTyConAppCo - - TcSubCo is not applied as deep as done with mkSubCo - Reason: they'll get established when we desugar to Coercion - - * TcAxiomInstCo has a [TcCoercion] parameter, and not a [Type] parameter. - This differs from the formalism, but corresponds to AxiomInstCo (see - [Coercion axioms applied to coercions]). - -Note [mkTcTransAppCo] -~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - co1 :: a ~R Maybe - co2 :: b ~R Int - -and we want - - co3 :: a b ~R Maybe Int - -This seems sensible enough. But, we can't let (co3 = co1 co2), because -that's ill-roled! Note that mkTcAppCo requires a *nominal* second coercion. - -The way around this is to use transitivity: - - co3 = (co1 <b>_N) ; (Maybe co2) :: a b ~R Maybe Int - -Or, it's possible everything is the other way around: - - co1' :: Maybe ~R a - co2' :: Int ~R b - -and we want +An TcCoercion is simply a Coercion whose free variables have may be either +boxed or unboxed. After we are done with typechecking the desugarer finds the +boxed free variables, unboxes them, and creates a resulting real Coercion with +kosher free variables. - co3' :: Maybe Int ~R a b - -then - - co3' = (Maybe co2') ; (co1' <b>_N) - -This is exactly what `mkTcTransAppCo` builds for us. Information for all -the arguments tends to be to hand at call sites, so it's quicker than -using, say, tcCoercionKind. -} -type TcCoercionN = TcCoercion -- A Nominal corecion ~N -type TcCoercionR = TcCoercion -- A Representational corecion ~R - -data TcCoercion - = TcRefl Role TcType - | TcTyConAppCo Role TyCon [TcCoercion] - | TcAppCo TcCoercion TcCoercion - | TcForAllCo TyVar TcCoercion - | TcCoVarCo EqVar - | TcAxiomInstCo (CoAxiom Branched) Int -- Int specifies branch number - [TcCoercion] -- See [CoAxiom Index] in Coercion.hs - -- This is number of types and coercions are expected to match to CoAxiomRule - -- (i.e., the CoAxiomRules are always fully saturated) - | TcAxiomRuleCo CoAxiomRule [TcType] [TcCoercion] - | TcPhantomCo TcType TcType - | TcSymCo TcCoercion - | TcTransCo TcCoercion TcCoercion - | TcNthCo Int TcCoercion - | TcLRCo LeftOrRight TcCoercion - | TcSubCo TcCoercion -- Argument is never TcRefl - | TcCastCo TcCoercion TcCoercion -- co1 |> co2 - | TcLetCo TcEvBinds TcCoercion - | TcCoercion Coercion -- embed a Core Coercion - deriving (Data.Data, Data.Typeable) +type TcCoercion = Coercion +type TcCoercionN = CoercionN -- A Nominal corecion ~N +type TcCoercionR = CoercionR -- A Representational corecion ~R +type TcCoercionP = CoercionP -- a phantom coercion + +mkTcReflCo :: Role -> TcType -> TcCoercion +mkTcSymCo :: TcCoercion -> TcCoercion +mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcNomReflCo :: TcType -> TcCoercionN +mkTcRepReflCo :: TcType -> TcCoercionR +mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion +mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion +mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion +mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex + -> [TcType] -> [TcCoercion] -> TcCoercion +mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] + -> [TcCoercion] -> TcCoercionR +mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion +mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion +mkTcNthCo :: Int -> TcCoercion -> TcCoercion +mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion +mkTcSubCo :: TcCoercionN -> TcCoercionR +maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion +tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion +mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR +mkTcCoherenceLeftCo :: TcCoercion -> TcCoercionN -> TcCoercion +mkTcCoherenceRightCo :: TcCoercion -> TcCoercionN -> TcCoercion +mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP +mkTcKindCo :: TcCoercion -> TcCoercionN +mkTcCoVarCo :: CoVar -> TcCoercion + +tcCoercionKind :: TcCoercion -> Pair TcType +tcCoercionRole :: TcCoercion -> Role +coVarsOfTcCo :: TcCoercion -> TcTyCoVarSet +isTcReflCo :: TcCoercion -> Bool + +mkTcReflCo = mkReflCo +mkTcSymCo = mkSymCo +mkTcTransCo = mkTransCo +mkTcNomReflCo = mkNomReflCo +mkTcRepReflCo = mkRepReflCo +mkTcTyConAppCo = mkTyConAppCo +mkTcAppCo = mkAppCo +mkTcFunCo = mkFunCo +mkTcAxInstCo = mkAxInstCo +mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational +mkTcForAllCo = mkForAllCo +mkTcForAllCos = mkForAllCos +mkTcNthCo = mkNthCo +mkTcLRCo = mkLRCo +mkTcSubCo = mkSubCo +maybeTcSubCo = maybeSubCo +tcDowngradeRole = downgradeRole +mkTcAxiomRuleCo = mkAxiomRuleCo +mkTcCoherenceLeftCo = mkCoherenceLeftCo +mkTcCoherenceRightCo = mkCoherenceRightCo +mkTcPhantomCo = mkPhantomCo +mkTcKindCo = mkKindCo +mkTcCoVarCo = mkCoVarCo + +tcCoercionKind = coercionKind +tcCoercionRole = coercionRole +coVarsOfTcCo = coVarsOfCo +isTcReflCo = isReflCo -isEqVar :: Var -> Bool --- Is lifted coercion variable (only!) -isEqVar v = case tyConAppTyCon_maybe (varType v) of - Just tc -> tc `hasKey` eqTyConKey - Nothing -> False - -isTcReflCo_maybe :: TcCoercion -> Maybe TcType -isTcReflCo_maybe (TcRefl _ ty) = Just ty -isTcReflCo_maybe (TcCoercion co) = isReflCo_maybe co -isTcReflCo_maybe _ = Nothing - -isTcReflCo :: TcCoercion -> Bool -isTcReflCo (TcRefl {}) = True -isTcReflCo (TcCoercion co) = isReflCo co -isTcReflCo _ = False - -getTcCoVar_maybe :: TcCoercion -> Maybe CoVar -getTcCoVar_maybe (TcCoVarCo v) = Just v -getTcCoVar_maybe _ = Nothing - -mkTcReflCo :: Role -> TcType -> TcCoercion -mkTcReflCo = TcRefl - -mkTcNomReflCo :: TcType -> TcCoercion -mkTcNomReflCo = TcRefl Nominal - -mkTcRepReflCo :: TcType -> TcCoercion -mkTcRepReflCo = TcRefl Representational - -mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -mkTcFunCo role co1 co2 = mkTcTyConAppCo role funTyCon [co1, co2] - -mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion -mkTcTyConAppCo role tc cos -- No need to expand type synonyms - -- See Note [TcCoercions] - | Just tys <- traverse isTcReflCo_maybe cos - = TcRefl role (mkTyConApp tc tys) -- See Note [Refl invariant] - - | otherwise = TcTyConAppCo role tc cos - --- Input coercion is Nominal --- mkSubCo will do some normalisation. We do not do it for TcCoercions, but --- defer that to desugaring; just to reduce the code duplication a little bit -mkTcSubCo :: TcCoercionN -> TcCoercionR -mkTcSubCo (TcRefl _ ty) - = TcRefl Representational ty -mkTcSubCo co - = ASSERT2( tcCoercionRole co == Nominal, ppr co) - TcSubCo co - --- See Note [Role twiddling functions] in Coercion --- | Change the role of a 'TcCoercion'. Returns 'Nothing' if this isn't --- a downgrade. -tcDowngradeRole_maybe :: Role -- desired role - -> Role -- current role - -> TcCoercion -> Maybe TcCoercion -tcDowngradeRole_maybe Representational Nominal = Just . mkTcSubCo -tcDowngradeRole_maybe Nominal Representational = const Nothing -tcDowngradeRole_maybe Phantom _ - = panic "tcDowngradeRole_maybe Phantom" - -- not supported (not needed at the moment) -tcDowngradeRole_maybe _ Phantom = const Nothing -tcDowngradeRole_maybe _ _ = Just - --- See Note [Role twiddling functions] in Coercion --- | Change the role of a 'TcCoercion'. Panics if this isn't a downgrade. -tcDowngradeRole :: Role -- ^ desired role - -> Role -- ^ current role - -> TcCoercion -> TcCoercion -tcDowngradeRole r1 r2 co - = case tcDowngradeRole_maybe r1 r2 co of - Just co' -> co' - Nothing -> pprPanic "tcDowngradeRole" (ppr r1 <+> ppr r2 <+> ppr co) - --- | If the EqRel is ReprEq, makes a TcSubCo; otherwise, does nothing. --- Note that the input coercion should always be nominal. -maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion -maybeTcSubCo NomEq = id -maybeTcSubCo ReprEq = mkTcSubCo - -mkTcAxInstCo :: Role -> CoAxiom br -> Int -> [TcType] -> TcCoercion -mkTcAxInstCo role ax index tys - | ASSERT2( not (role == Nominal && ax_role == Representational) , ppr (ax, tys) ) - arity == n_tys = tcDowngradeRole role ax_role $ - TcAxiomInstCo ax_br index rtys - | otherwise = ASSERT( arity < n_tys ) - tcDowngradeRole role ax_role $ - foldl TcAppCo (TcAxiomInstCo ax_br index (take arity rtys)) - (drop arity rtys) - where - n_tys = length tys - ax_br = toBranchedAxiom ax - branch = coAxiomNthBranch ax_br index - arity = length $ coAxBranchTyVars branch - ax_role = coAxiomRole ax - arg_roles = coAxBranchRoles branch - rtys = zipWith mkTcReflCo (arg_roles ++ repeat Nominal) tys - -mkTcAxiomRuleCo :: CoAxiomRule -> [TcType] -> [TcCoercion] -> TcCoercionR -mkTcAxiomRuleCo = TcAxiomRuleCo - -mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] -> TcCoercionR -mkTcUnbranchedAxInstCo ax tys = mkTcAxInstCo Representational ax 0 tys - -mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion --- No need to deal with TyConApp on the left; see Note [TcCoercions] --- Second coercion *must* be nominal -mkTcAppCo (TcRefl r ty1) (TcRefl _ ty2) = TcRefl r (mkAppTy ty1 ty2) -mkTcAppCo co1 co2 = TcAppCo co1 co2 - --- | Like `mkTcAppCo`, but allows the second coercion to be other than --- nominal. See Note [mkTcTransAppCo]. Role r3 cannot be more stringent --- than either r1 or r2. -mkTcTransAppCo :: Role -- ^ r1 - -> TcCoercion -- ^ co1 :: ty1a ~r1 ty1b - -> TcType -- ^ ty1a - -> TcType -- ^ ty1b - -> Role -- ^ r2 - -> TcCoercion -- ^ co2 :: ty2a ~r2 ty2b - -> TcType -- ^ ty2a - -> TcType -- ^ ty2b - -> Role -- ^ r3 - -> TcCoercion -- ^ :: ty1a ty2a ~r3 ty1b ty2b -mkTcTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3 --- How incredibly fiddly! Is there a better way?? - = case (r1, r2, r3) of - (_, _, Phantom) - -> mkTcPhantomCo (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b) - (_, _, Nominal) - -> ASSERT( r1 == Nominal && r2 == Nominal ) - mkTcAppCo co1 co2 - (Nominal, Nominal, Representational) - -> mkTcSubCo (mkTcAppCo co1 co2) - (_, Nominal, Representational) - -> ASSERT( r1 == Representational ) - mkTcAppCo co1 co2 - (Nominal, Representational, Representational) - -> go (mkTcSubCo co1) - (_ , _, Representational) - -> ASSERT( r1 == Representational && r2 == Representational ) - go co1 - where - go co1_repr - | Just (tc1b, tys1b) <- tcSplitTyConApp_maybe ty1b - , nextRole ty1b == r2 - = (co1_repr `mkTcAppCo` mkTcNomReflCo ty2a) `mkTcTransCo` - (mkTcTyConAppCo Representational tc1b - (zipWith mkTcReflCo (tyConRolesX Representational tc1b) tys1b - ++ [co2])) - - | Just (tc1a, tys1a) <- tcSplitTyConApp_maybe ty1a - , nextRole ty1a == r2 - = (mkTcTyConAppCo Representational tc1a - (zipWith mkTcReflCo (tyConRolesX Representational tc1a) tys1a - ++ [co2])) - `mkTcTransCo` - (co1_repr `mkTcAppCo` mkTcNomReflCo ty2b) - - | otherwise - = pprPanic "mkTcTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b - , ppr r2, ppr co2, ppr ty2a, ppr ty2b - , ppr r3 ]) - -mkTcSymCo :: TcCoercion -> TcCoercion -mkTcSymCo co@(TcRefl {}) = co -mkTcSymCo (TcSymCo co) = co -mkTcSymCo co = TcSymCo co - -mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion -mkTcTransCo (TcRefl {}) co = co -mkTcTransCo co (TcRefl {}) = co -mkTcTransCo co1 co2 = TcTransCo co1 co2 - -mkTcNthCo :: Int -> TcCoercion -> TcCoercion -mkTcNthCo n (TcRefl r ty) = TcRefl r (tyConAppArgN n ty) -mkTcNthCo n co = TcNthCo n co - -mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion -mkTcLRCo lr (TcRefl r ty) = TcRefl r (pickLR lr (tcSplitAppTy ty)) -mkTcLRCo lr co = TcLRCo lr co - -mkTcPhantomCo :: TcType -> TcType -> TcCoercion -mkTcPhantomCo = TcPhantomCo - -mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion -mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys - -mkTcForAllCo :: Var -> TcCoercion -> TcCoercion --- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) -mkTcForAllCo tv (TcRefl r ty) = ASSERT( isTyVar tv ) TcRefl r (mkForAllTy tv ty) -mkTcForAllCo tv co = ASSERT( isTyVar tv ) TcForAllCo tv co - -mkTcForAllCos :: [Var] -> TcCoercion -> TcCoercion -mkTcForAllCos tvs (TcRefl r ty) = ASSERT( all isTyVar tvs ) TcRefl r (mkForAllTys tvs ty) -mkTcForAllCos tvs co = ASSERT( all isTyVar tvs ) foldr TcForAllCo co tvs - -mkTcCoVarCo :: EqVar -> TcCoercion --- ipv :: s ~ t (the boxed equality type) or Coercible s t (the boxed representational equality type) -mkTcCoVarCo ipv = TcCoVarCo ipv - -- Previously I checked for (ty ~ ty) and generated Refl, - -- but in fact ipv may not even (visibly) have a (t1 ~ t2) type, because - -- the constraint solver does not substitute in the types of - -- evidence variables as it goes. In any case, the optimisation - -- will be done in the later zonking phase - -tcCoercionKind :: TcCoercion -> Pair Type -tcCoercionKind co = go co - where - go (TcRefl _ ty) = Pair ty ty - go (TcLetCo _ co) = go co - go (TcCastCo _ co) = case getEqPredTys (pSnd (go co)) of - (ty1,ty2) -> Pair ty1 ty2 - go (TcTyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) - go (TcAppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 - go (TcForAllCo tv co) = mkForAllTy tv <$> go co - go (TcCoVarCo cv) = eqVarKind cv - go (TcAxiomInstCo ax ind cos) - = let branch = coAxiomNthBranch ax ind - tvs = coAxBranchTyVars branch - Pair tys1 tys2 = sequenceA (map go cos) - in ASSERT( cos `equalLength` tvs ) - Pair (substTyWith tvs tys1 (coAxNthLHS ax ind)) - (substTyWith tvs tys2 (coAxBranchRHS branch)) - go (TcPhantomCo ty1 ty2) = Pair ty1 ty2 - go (TcSymCo co) = swap (go co) - go (TcTransCo co1 co2) = Pair (pFst (go co1)) (pSnd (go co2)) - go (TcNthCo d co) = tyConAppArgN d <$> go co - go (TcLRCo lr co) = (pickLR lr . tcSplitAppTy) <$> go co - go (TcSubCo co) = go co - go (TcAxiomRuleCo ax ts cs) = - case coaxrProves ax ts (map tcCoercionKind cs) of - Just res -> res - Nothing -> panic "tcCoercionKind: malformed TcAxiomRuleCo" - go (TcCoercion co) = coercionKind co - -eqVarRole :: EqVar -> Role -eqVarRole cv = getEqPredRole (varType cv) - -eqVarKind :: EqVar -> Pair Type -eqVarKind cv - | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv) - = ASSERT(tc `hasKey` eqTyConKey) - Pair ty1 ty2 - | otherwise = pprPanic "eqVarKind, non coercion variable" (ppr cv <+> dcolon <+> ppr (varType cv)) - -tcCoercionRole :: TcCoercion -> Role -tcCoercionRole = go - where - go (TcRefl r _) = r - go (TcTyConAppCo r _ _) = r - go (TcAppCo co _) = go co - go (TcForAllCo _ co) = go co - go (TcCoVarCo cv) = eqVarRole cv - go (TcAxiomInstCo ax _ _) = coAxiomRole ax - go (TcPhantomCo _ _) = Phantom - go (TcSymCo co) = go co - go (TcTransCo co1 _) = go co1 -- same as go co2 - go (TcNthCo n co) = let Pair ty1 _ = tcCoercionKind co - (tc, _) = tcSplitTyConApp ty1 - in nthRole (go co) tc n - go (TcLRCo _ _) = Nominal - go (TcSubCo _) = Representational - go (TcAxiomRuleCo c _ _) = coaxrRole c - go (TcCastCo c _) = go c - go (TcLetCo _ c) = go c - go (TcCoercion co) = coercionRole co - - -coVarsOfTcCo :: TcCoercion -> VarSet --- Only works on *zonked* coercions, because of TcLetCo -coVarsOfTcCo tc_co - = go tc_co - where - go (TcRefl _ _) = emptyVarSet - go (TcTyConAppCo _ _ cos) = mapUnionVarSet go cos - go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2 - go (TcCastCo co1 co2) = go co1 `unionVarSet` go co2 - go (TcForAllCo _ co) = go co - go (TcCoVarCo v) = unitVarSet v - go (TcAxiomInstCo _ _ cos) = mapUnionVarSet go cos - go (TcPhantomCo _ _) = emptyVarSet - go (TcSymCo co) = go co - go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2 - go (TcNthCo _ co) = go co - go (TcLRCo _ co) = go co - go (TcSubCo co) = go co - go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs - `minusVarSet` get_bndrs bs - go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call - -- to evVarsOfTerm in the DEBUG check of setEvBind - go (TcAxiomRuleCo _ _ cos) = mapUnionVarSet go cos - go (TcCoercion co) = -- the use of coVarsOfTcCo in dsTcCoercion will - -- fail if there are any proper, unlifted covars - ASSERT( isEmptyVarSet (coVarsOfCo co) ) - emptyVarSet - - -- We expect only coercion bindings, so use evTermCoercion - go_bind :: EvBind -> VarSet - go_bind (EvBind { eb_rhs =tm }) = go (evTermCoercion tm) - - get_bndrs :: Bag EvBind -> VarSet - get_bndrs = foldrBag (\ (EvBind { eb_lhs = b }) bs -> extendVarSet bs b) emptyVarSet - --- Pretty printing - -instance Outputable TcCoercion where - ppr = pprTcCo - -pprTcCo, pprParendTcCo :: TcCoercion -> SDoc -pprTcCo co = ppr_co TopPrec co -pprParendTcCo co = ppr_co TyConPrec co - -ppr_co :: TyPrec -> TcCoercion -> SDoc -ppr_co _ (TcRefl r ty) = angleBrackets (ppr ty) <> ppr_role r - -ppr_co p co@(TcTyConAppCo _ tc [_,_]) - | tc `hasKey` funTyConKey = ppr_fun_co p co - -ppr_co p (TcTyConAppCo r tc cos) = pprTcApp p ppr_co tc cos <> ppr_role r -ppr_co p (TcLetCo bs co) = maybeParen p TopPrec $ - sep [ptext (sLit "let") <+> braces (ppr bs), ppr co] -ppr_co p (TcAppCo co1 co2) = maybeParen p TyConPrec $ - pprTcCo co1 <+> ppr_co TyConPrec co2 -ppr_co p (TcCastCo co1 co2) = maybeParen p FunPrec $ - ppr_co FunPrec co1 <+> ptext (sLit "|>") <+> ppr_co FunPrec co2 -ppr_co p co@(TcForAllCo {}) = ppr_forall_co p co - -ppr_co _ (TcCoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) - -ppr_co p (TcAxiomInstCo con ind cos) - = pprPrefixApp p (ppr (getName con) <> brackets (ppr ind)) (map pprParendTcCo cos) - -ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $ - ppr_co FunPrec co1 - <+> ptext (sLit ";") - <+> ppr_co FunPrec co2 -ppr_co p (TcPhantomCo t1 t2) = pprPrefixApp p (ptext (sLit "PhantomCo")) [pprParendType t1, pprParendType t2] -ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co] -ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co] -ppr_co p (TcLRCo lr co) = pprPrefixApp p (ppr lr) [pprParendTcCo co] -ppr_co p (TcSubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendTcCo co] -ppr_co p (TcAxiomRuleCo co ts ps) = maybeParen p TopPrec - $ ppr_tc_axiom_rule_co co ts ps -ppr_co p (TcCoercion co) = pprPrefixApp p (text "Core co:") [ppr co] - -ppr_tc_axiom_rule_co :: CoAxiomRule -> [TcType] -> [TcCoercion] -> SDoc -ppr_tc_axiom_rule_co co ts ps = ppr (coaxrName co) <> ppTs ts $$ nest 2 (ppPs ps) - where - ppTs [] = Outputable.empty - ppTs [t] = ptext (sLit "@") <> ppr_type TopPrec t - ppTs ts = ptext (sLit "@") <> - parens (hsep $ punctuate comma $ map pprType ts) - - ppPs [] = Outputable.empty - ppPs [p] = pprParendTcCo p - ppPs (p : ps) = ptext (sLit "(") <+> pprTcCo p $$ - vcat [ ptext (sLit ",") <+> pprTcCo q | q <- ps ] $$ - ptext (sLit ")") - -ppr_role :: Role -> SDoc -ppr_role r = underscore <> pp_role - where pp_role = case r of - Nominal -> char 'N' - Representational -> char 'R' - Phantom -> char 'P' - -ppr_fun_co :: TyPrec -> TcCoercion -> SDoc -ppr_fun_co p co = pprArrowChain p (split co) - where - split :: TcCoercion -> [SDoc] - split (TcTyConAppCo _ f [arg,res]) - | f `hasKey` funTyConKey - = ppr_co FunPrec arg : split res - split co = [ppr_co TopPrec co] - -ppr_forall_co :: TyPrec -> TcCoercion -> SDoc -ppr_forall_co p ty - = maybeParen p FunPrec $ - sep [pprForAll tvs, ppr_co TopPrec rho] - where - (tvs, rho) = split1 [] ty - split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) {- -************************************************************************ -* * +%************************************************************************ +%* * HsWrapper * * ************************************************************************ @@ -567,7 +166,7 @@ data HsWrapper -- So note that if wrap1 :: exp_arg <= act_arg -- wrap2 :: act_res <= exp_res -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) - -- This isn't the same as for mkTcFunCo, but it has to be this way + -- This isn't the same as for mkFunCo, but it has to be this way -- because we can't use 'sym' to flip around these HsWrappers | WpCast TcCoercionR -- A cast: [] `cast` co @@ -576,9 +175,8 @@ data HsWrapper -- Evidence abstraction and application -- (both dictionaries and coercions) - | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable - | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint - + | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable + | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint -- Kind and Type abstraction and application | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) @@ -596,9 +194,9 @@ c1 <.> c2 = c1 `WpCompose` c2 mkWpFun :: HsWrapper -> HsWrapper -> TcType -> TcType -> HsWrapper mkWpFun WpHole WpHole _ _ = WpHole -mkWpFun WpHole (WpCast co2) t1 _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole _ t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) +mkWpFun WpHole (WpCast co2) t1 _ = WpCast (mkFunCo Representational (mkRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole _ t2 = WpCast (mkFunCo Representational (mkSymCo co1) (mkRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) _ _ = WpCast (mkFunCo Representational (mkSymCo co1) co2) mkWpFun co1 co2 t1 t2 = WpFun co1 co2 t1 t2 mkWpCastR :: TcCoercionR -> HsWrapper @@ -621,7 +219,7 @@ mkWpEvApps :: [EvTerm] -> HsWrapper mkWpEvApps args = mk_co_app_fn WpEvApp args mkWpEvVarApps :: [EvVar] -> HsWrapper -mkWpEvVarApps vs = mkWpEvApps (map EvId vs) +mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map EvId vs) mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids @@ -668,7 +266,7 @@ data TcEvBinds deriving( Data.Typeable ) data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique - -- The Unique is only for debug printing + -- The Unique is for debug printing only instance Data.Data TcEvBinds where -- Placeholder; we can't travers into TcEvBinds @@ -727,22 +325,26 @@ data EvBind -- See Note [Tracking redundant constraints] in TcSimplify } +evBindVar :: EvBind -> EvVar +evBindVar = eb_lhs + mkWantedEvBind :: EvVar -> EvTerm -> EvBind mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } + mkGivenEvBind :: EvVar -> EvTerm -> EvBind mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } data EvTerm = EvId EvId -- Any sort of evidence Id, including coercions - | EvCoercion TcCoercion -- (Boxed) coercion bindings + | EvCoercion TcCoercion -- coercion bindings -- See Note [Coercion evidence terms] - | EvCast EvTerm TcCoercion -- d |> co, the coercion being at role representational + | EvCast EvTerm TcCoercionR -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvId] + [Type] [EvTerm] | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] @@ -765,7 +367,8 @@ data EvTerm -- | Instructions on how to make a 'Typeable' dictionary. -- See Note [Typeable evidence terms] data EvTypeable - = EvTypeableTyCon -- ^ Dictionary for @Typeable (T k1..kn)@ + = EvTypeableTyCon [EvTerm] -- ^ Dictionary for @Typeable (T k1..kn)@. + -- The EvTerms are for the arguments | EvTypeableTyApp EvTerm EvTerm -- ^ Dictionary for @Typeable (s t)@, @@ -806,7 +409,7 @@ inside can be EvIds. Eg Here for the (Typeable [a]) dictionary passed to typeRep we make evidence dl :: Typeable [a] = EvTypeable [a] - (EvTypeableTyApp EvTypeableTyCon (EvId d)) + (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) where d :: Typable a is the lambda-bound dictionary passed into f. @@ -814,14 +417,14 @@ is the lambda-bound dictionary passed into f. Note [Coercion evidence terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "coercion evidence term" takes one of these forms - co_tm ::= EvId v where v :: t1 ~ t2 + co_tm ::= EvId v where v :: t1 ~# t2 | EvCoercion co | EvCast co_tm co We do quite often need to get a TcCoercion from an EvTerm; see 'evTermCoercion'. -INVARIANT: The evidence for any constraint with type (t1~t2) is +INVARIANT: The evidence for any constraint with type (t1 ~# t2) is a coercion evidence term. Consider for example [G] d :: F Int a If we have @@ -1037,17 +640,17 @@ isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" evTermCoercion :: EvTerm -> TcCoercion -- Applied only to EvTerms of type (s~t) -- See Note [Coercion evidence terms] -evTermCoercion (EvId v) = mkTcCoVarCo v +evTermCoercion (EvId v) = mkCoVarCo v evTermCoercion (EvCoercion co) = co -evTermCoercion (EvCast tm co) = TcCastCo (evTermCoercion tm) co +evTermCoercion (EvCast tm co) = mkCoCast (evTermCoercion tm) co evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm) evVarsOfTerm :: EvTerm -> VarSet evVarsOfTerm (EvId v) = unitVarSet v -evVarsOfTerm (EvCoercion co) = coVarsOfTcCo co -evVarsOfTerm (EvDFunApp _ _ evs) = mkVarSet evs +evVarsOfTerm (EvCoercion co) = coVarsOfCo co +evVarsOfTerm (EvDFunApp _ _ evs) = mapUnionVarSet evVarsOfTerm evs evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v -evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co +evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfCo co evVarsOfTerm (EvDelayedError _ _) = emptyVarSet evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs @@ -1056,6 +659,18 @@ evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms = mapUnionVarSet evVarsOfTerm +-- | Do SCC analysis on a bag of 'EvBind's. +sccEvBinds :: Bag EvBind -> [SCC EvBind] +sccEvBinds bs = stronglyConnCompFromEdgedVertices edges + where + edges :: [(EvBind, EvVar, [EvVar])] + edges = foldrBag ((:) . mk_node) [] bs + + mk_node :: EvBind -> (EvBind, EvVar, [EvVar]) + mk_node b@(EvBind { eb_lhs = var, eb_rhs = term }) + = (b, var, varSetElems (evVarsOfTerm term `unionVarSet` + coVarsOfType (varType var))) + evVarsOfCallStack :: EvCallStack -> VarSet evVarsOfCallStack cs = case cs of EvCsEmpty -> emptyVarSet @@ -1065,7 +680,7 @@ evVarsOfCallStack cs = case cs of evVarsOfTypeable :: EvTypeable -> VarSet evVarsOfTypeable ev = case ev of - EvTypeableTyCon -> emptyVarSet + EvTypeableTyCon es -> evVarsOfTerms es EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] EvTypeableTyLit e -> evVarsOfTerm e @@ -1084,7 +699,10 @@ pprHsWrapper :: SDoc -> HsWrapper -> SDoc -- In debug mode, print the wrapper -- otherwise just print what's inside pprHsWrapper doc wrap - = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc) + = sdocWithDynFlags $ \ dflags -> + getPprStyle (\ s -> if debugStyle s || gopt Opt_PrintExplicitCoercions dflags + then (help (add_parens doc) wrap False) + else doc ) where help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc -- True <=> appears in function application position @@ -1094,7 +712,7 @@ pprHsWrapper doc wrap help it (WpFun f1 f2 t1 _) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+> help (\_ -> it True <+> help (\_ -> ptext (sLit "x")) f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") - <+> pprParendTcCo co)] + <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] @@ -1115,6 +733,9 @@ instance Outputable TcEvBinds where instance Outputable EvBindsVar where ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u) +instance Uniquable EvBindsVar where + getUnique (EvBindsVar _ u) = u + instance Outputable EvBind where ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) = sep [ pp_gw <+> ppr v @@ -1124,14 +745,14 @@ instance Outputable EvBind where -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing instance Outputable EvTerm where - ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co - ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co - ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] - ppr (EvLit l) = ppr l - ppr (EvCallStack cs) = ppr cs - ppr (EvDelayedError ty msg) = ptext (sLit "error") + ppr (EvId v) = ppr v + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] + ppr (EvLit l) = ppr l + ppr (EvCallStack cs) = ppr cs + ppr (EvDelayedError ty msg) = ptext (sLit "error") <+> sep [ char '@' <> ppr ty, ppr msg ] ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> ptext (sLit "Typeable") <+> ppr ty @@ -1148,7 +769,7 @@ instance Outputable EvCallStack where = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm instance Outputable EvTypeable where - ppr EvTypeableTyCon = ptext (sLit "TC") + ppr (EvTypeableTyCon ts) = ptext (sLit "TC") <+> ppr ts ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) ppr (EvTypeableTyLit t1) = ptext (sLit "TyLit") <> ppr t1 @@ -1166,7 +787,7 @@ instance Outputable EvTypeable where unwrapIP :: Type -> CoercionR unwrapIP ty = case unwrapNewTyCon_maybe tc of - Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys + Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] Nothing -> pprPanic "unwrapIP" $ text "The dictionary for" <+> quotes (ppr tc) <+> text "is not a newtype!" diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 853ef54c8a..a7c4795a48 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1,5 +1,5 @@ {- -c% +% (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -52,7 +52,6 @@ import RdrName import TyCon import Type import TcEvidence -import Var import VarSet import VarEnv import TysWiredIn @@ -149,8 +148,11 @@ tcUnboundId occ res_ty = do { ty <- newFlexiTyVarTy liftedTypeKind ; name <- newSysName occ ; let ev = mkLocalId name ty - ; loc <- getCtLocM HoleOrigin - ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ + ; loc <- getCtLocM HoleOrigin Nothing + ; let can = CHoleCan { cc_ev = CtWanted { ctev_pred = ty + , ctev_dest = EvVarDest ev + , ctev_loc = loc} + , cc_occ = occ , cc_hole = ExprHole } ; emitInsoluble can ; tcWrapResult (HsVar (noLoc ev)) ty res_ty } @@ -206,31 +208,31 @@ tcExpr (HsIPVar x) res_ty type scheme. We enforce this by creating a fresh type variable as its type. (Because res_ty may not be a tau-type.) -} - ; ip_ty <- newFlexiTyVarTy openTypeKind + ; ip_ty <- newOpenFlexiTyVarTy ; let ip_name = mkStrLitTy (hsIPNameFS x) - ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty]) + ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var))) ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = HsWrap $ mkWpCastR $ TcCoercion $ + fromDict ipClass x ty = HsWrap $ mkWpCastR $ unwrapIP $ mkClassPred ipClass [x,ty] tcExpr (HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels] = do { let origin = OverLabelOrigin l ; isLabelClass <- tcLookupClass isLabelClassName - ; alpha <- newFlexiTyVarTy openTypeKind + ; alpha <- newOpenFlexiTyVarTy ; let lbl = mkStrLitTy l pred = mkClassPred isLabelClass [lbl, alpha] ; loc <- getSrcSpanM - ; var <- emitWanted origin pred + ; var <- emitWantedEvVar origin pred ; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl]) (HsVar (L loc proxyHashId))) tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg ; tcWrapResult tm alpha res_ty } where -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`. - fromDict pred = HsWrap $ mkWpCastR $ TcCoercion $ unwrapIP pred + fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty @@ -330,7 +332,7 @@ construct. See Note [seqId magic] in MkId, and -} -tcExpr (OpApp arg1 op fix arg2) res_ty +tcExpr expr@(OpApp arg1 op fix arg2) res_ty | (L loc (HsVar (L lv op_name))) <- op , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind @@ -354,11 +356,11 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- So: arg1_ty = arg2_ty -> op_res_ty -- where arg2_ty maybe polymorphic; that's the point - ; arg2' <- tcArg op (arg2, arg2_ty, 2) - ; co_b <- unifyType op_res_ty res_ty -- op_res ~ res + ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; co_b <- unifyType (Just expr) op_res_ty res_ty -- op_res ~ res -- Make sure that the argument type has kind '*' - -- ($) :: forall (a2:*) (r:Open). (a2->r) -> a2 -> r + -- ($) :: forall (v:Levity) (a:*) (b:TYPE v). (a->b) -> a -> b -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 -- (which gives a seg fault) -- We do this by unifying with a MetaTv; but of course @@ -368,10 +370,13 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- so we don't need to check anything for that ; a2_tv <- newReturnTyVar liftedTypeKind ; let a2_ty = mkTyVarTy a2_tv - ; co_a <- unifyType arg2_ty a2_ty -- arg2 ~ a2 + ; co_a <- unifyType (Just arg2) arg2_ty a2_ty -- arg2 ~ a2 ; op_id <- tcLookupId op_name - ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) + + ; let op' = L loc (HsWrap (mkWpTyApps [ getLevity "tcExpr ($)" res_ty + , a2_ty + , res_ty ]) (HsVar (L lv op_id))) ; return $ OpApp (mkLHsWrapCo (mkTcFunCo Nominal co_a co_b) $ @@ -392,7 +397,7 @@ tcExpr (OpApp arg1 op fix arg2) res_ty = do { traceTc "Non Application rule" (ppr op) ; (op', op_ty) <- tcInferFun op ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTysWrap op 2 op_ty - ; co_res <- unifyType op_res_ty res_ty + ; co_res <- unifyType (Just expr) op_res_ty res_ty ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys ; return $ mkHsWrapCo co_res $ OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' } @@ -400,46 +405,51 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr -tcExpr (SectionR op arg2) res_ty +tcExpr expr@(SectionR op arg2) res_ty = do { (op', op_ty) <- tcInferFun op ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTysWrap op 2 op_ty - ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty + ; co_res <- unifyType (Just expr) (mkFunTy arg1_ty op_res_ty) res_ty ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; return $ mkHsWrapCo co_res $ SectionR (mkLHsWrapCo co_fn op') arg2' } -tcExpr (SectionL arg1 op) res_ty +tcExpr expr@(SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op ; dflags <- getDynFlags -- Note [Left sections] ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1 | otherwise = 2 ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTysWrap op n_reqd_args op_ty - ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty + ; co_res <- unifyType (Just expr) (mkFunTys arg_tys op_res_ty) res_ty ; arg1' <- tcArg op (arg1, arg1_ty, 1) ; return $ mkHsWrapCo co_res $ SectionL arg1' (mkLHsWrapCo co_fn op') } -tcExpr (ExplicitTuple tup_args boxity) res_ty +tcExpr expr@(ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args - = do { let tup_tc = tupleTyCon boxity (length tup_args) + = do { let arity = length tup_args + tup_tc = tupleTyCon boxity arity ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty - ; tup_args1 <- tcTupArgs tup_args arg_tys + -- Unboxed tuples have levity vars, which we + -- don't care about here + -- See Note [Unboxed tuple levity vars] in TyCon + ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; tup_args1 <- tcTupArgs tup_args arg_tys' ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) - do { let kind = case boxity of { Boxed -> liftedTypeKind - ; Unboxed -> openTypeKind } - arity = length tup_args - tup_tc = tupleTyCon boxity arity + do { let arity = length tup_args - ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind + ; arg_tys <- case boxity of + { Boxed -> newFlexiTyVarTys arity liftedTypeKind + ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } ; let actual_res_ty - = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args] - (mkTyConApp tup_tc arg_tys) + = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args] + (mkTupleTy boxity arg_tys) - ; coi <- unifyType actual_res_ty res_ty + ; coi <- unifyType (Just expr) actual_res_ty res_ty -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys @@ -505,9 +515,9 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' ; return (HsIf Nothing pred' b1' b2') } tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] - = do { pred_ty <- newFlexiTyVarTy openTypeKind - ; b1_ty <- newFlexiTyVarTy openTypeKind - ; b2_ty <- newFlexiTyVarTy openTypeKind + = do { pred_ty <- newOpenFlexiTyVarTy + ; b1_ty <- newOpenFlexiTyVarTy + ; b2_ty <- newOpenFlexiTyVarTy ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty ; fun' <- tcSyntaxOp IfOrigin fun if_ty ; pred' <- tcMonoExpr pred pred_ty @@ -545,7 +555,7 @@ tcExpr (HsStatic expr) res_ty -- the current implementation is as restrictive as future versions -- of the StaticPointers extension. ; typeableClass <- tcLookupClass typeableClassName - ; _ <- emitWanted StaticOrigin $ + ; _ <- emitWantedEvVar StaticOrigin $ mkTyConApp (classTyCon typeableClass) [liftedTypeKind, expr_ty] -- Insert the static form in a global list for later validation. @@ -579,7 +589,8 @@ to support expressions like this: ************************************************************************ -} -tcExpr (RecordCon { rcon_con_name = L loc con_name, rcon_flds = rbinds }) res_ty +tcExpr expr@(RecordCon { rcon_con_name = L loc con_name + , rcon_flds = rbinds }) res_ty = do { con_like <- tcLookupConLike con_name -- Check for missing fields @@ -591,7 +602,7 @@ tcExpr (RecordCon { rcon_con_name = L loc con_name, rcon_flds = rbinds }) res_ty ; case conLikeWrapId_maybe con_like of Nothing -> nonBidirectionalErr (conLikeName con_like) Just con_id -> do { - co_res <- unifyType actual_res_ty res_ty + co_res <- unifyType (Just expr) actual_res_ty res_ty ; rbinds' <- tcRecordBinds con_like arg_tys rbinds ; return $ mkHsWrapCo co_res $ RecordCon { rcon_con_name = L loc con_id @@ -734,7 +745,7 @@ following. -} -tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty +tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty = ASSERT( notNull rbnds ) do { -- STEP -2: typecheck the record_expr, the record to bd updated (record_expr', record_tau) <- tcInferFun record_expr @@ -814,7 +825,7 @@ tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty bad_upd_flds = filter bad_fld flds1_w_tys con1_tv_set = mkVarSet con1_tvs bad_fld (fld, ty) = fld `elem` upd_fld_occs && - not (tyVarsOfType ty `subVarSet` con1_tv_set) + not (tyCoVarsOfType ty `subVarSet` con1_tv_set) ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) -- STEP 4 Note [Type of a record update] @@ -827,28 +838,28 @@ tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons is_fixed_tv tv = tv `elemVarSet` fixed_tvs - mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType) + mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) -- Deals with instantiation of kind variables -- c.f. TcMType.tcInstTyVars mk_inst_ty subst (tv, result_inst_ty) | is_fixed_tv tv -- Same as result type - = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) + = return (extendTCvSubst subst tv result_inst_ty, result_inst_ty) | otherwise -- Fresh type, of correct kind - = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv)) - ; return (extendTvSubst subst tv new_ty, new_ty) } + = do { (subst', new_tv) <- tcInstTyVarX subst tv + ; return (subst', mkTyVarTy new_tv) } ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs ; let result_inst_tys = mkTyVarTys con1_tvs' - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst + ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTCvSubst (con1_tvs `zip` result_inst_tys) ; let rec_res_ty = TcType.substTy result_subst con1_res_ty scrut_ty = TcType.substTy scrut_subst con1_res_ty con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - ; co_res <- unifyType rec_res_ty res_ty - ; co_scrut <- unifyType record_tau scrut_ty + ; co_res <- unifyType (Just expr) rec_res_ty res_ty + ; co_scrut <- unifyType (Just record_expr) record_tau scrut_ty -- STEP 5 -- Typecheck the bindings @@ -863,7 +874,7 @@ tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty fam_co | Just tycon <- mtycon , Just co_con <- tyConFamilyCoercion_maybe tycon - = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys) + = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) | otherwise = idHsWrapper @@ -1049,7 +1060,8 @@ tcApp fun args res_ty -- Rather like tcWrapResult, but (perhaps for historical reasons) -- we do this before typechecking the arguments ; wrap_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $ - tcSubTypeDS_NC GenSigCtxt actual_res_ty res_ty + tcSubTypeDS_NC GenSigCtxt (Just $ foldl mkHsApp fun args) + actual_res_ty res_ty -- Typecheck the arguments ; args1 <- tcArgs fun args expected_arg_tys @@ -1194,11 +1206,11 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr <- simplifyInfer tclvl False [sig] [(name, tau)] wanted ; tau <- zonkTcType tau ; let inferred_theta = map evVarPred givens - tau_tvs = tyVarsOfType tau + tau_tvs = tyCoVarsOfType tau ; (my_tv_set, my_theta) <- chooseInferredQuantifiers inferred_theta tau_tvs (Just sig) ; let my_tvs = filter (`elemVarSet` my_tv_set) qtvs -- Maintain original order - inferred_sigma = mkSigmaTy qtvs inferred_theta tau - my_sigma = mkSigmaTy my_tvs my_theta tau + inferred_sigma = mkInvSigmaTy qtvs inferred_theta tau + my_sigma = mkInvSigmaTy my_tvs my_theta tau ; wrap <- if inferred_sigma `eqType` my_sigma then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguouse type and have AllowAmbiguousType @@ -1209,7 +1221,7 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr <.> mkWpTyLams qtvs <.> mkWpLams givens <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', mkSigmaTy qtvs theta tau) } + ; return (mkLHsWrap poly_wrap expr', mkInvSigmaTy qtvs theta tau) } | otherwise = panic "tcExprSig" -- Can't happen where @@ -1400,7 +1412,7 @@ tcTagToEnum loc fun_name arg res_ty ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) rep_ty = mkTyConApp rep_tc rep_args - ; return (mkHsWrapCoR (mkTcSymCo $ TcCoercion coi) $ HsApp fun' arg') } + ; return (mkHsWrapCoR (mkTcSymCo coi) $ HsApp fun' arg') } -- coi is a Representational coercion where doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") @@ -1523,9 +1535,9 @@ getFixedTyVars upd_fld_occs univ_tvs cons ++ prov_theta ++ req_theta flds = conLikeFieldLabels con - fixed_tvs = exactTyVarsOfTypes fixed_tys + fixed_tvs = exactTyCoVarsOfTypes fixed_tys -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyVarsOfTypes theta + `unionVarSet` tyCoVarsOfTypes theta -- Universally-quantified tyvars that -- appear in any of the *implicit* -- arguments to the constructor are fixed @@ -1927,12 +1939,6 @@ fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") -funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc -funAppCtxt fun arg arg_no - = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), - quotes (ppr fun) <> text ", namely"]) - 2 (quotes (ppr arg)) - funResCtxt :: Bool -- There is at least one argument -> HsExpr Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index a3724a1276..8129981abf 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ViewPatterns #-} module TcFlatten( FlattenMode(..), @@ -14,9 +14,8 @@ import TcType import Type import TcEvidence import TyCon -import TypeRep -import Kind( isSubKind ) -import Coercion ( tyConRolesX ) +import TyCoRep -- performs delicate algorithm on types +import Coercion import Var import VarEnv import NameEnv @@ -26,6 +25,7 @@ import DynFlags( DynFlags ) import Util import Bag +import Pair import FastString import Control.Monad import MonadUtils ( zipWithAndUnzipM ) @@ -34,6 +34,7 @@ import GHC.Exts ( inline ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ( Applicative(..), (<$>) ) #endif +import Control.Arrow ( first ) {- Note [The flattening story] @@ -625,6 +626,17 @@ setMode new_mode thing_inside -- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2 _ `eq` _ = False +-- | Use when flattening kinds/kind coercions. See +-- Note [No derived kind equalities] in TcCanonical +flattenKinds :: FlatM a -> FlatM a +flattenKinds thing_inside + = FlatM $ \env -> + let kind_flav = case fe_flavour env of + Given -> Given + _ -> Wanted + in + runFlatM thing_inside (env { fe_eq_rel = NomEq, fe_flavour = kind_flav }) + bumpDepth :: FlatM a -> FlatM a bumpDepth (FlatM thing_inside) = FlatM $ \env -> do { let env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } @@ -633,7 +645,7 @@ bumpDepth (FlatM thing_inside) -- Flatten skolems -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ newFlattenSkolemFlatM :: TcType -- F xis - -> FlatM (CtEvidence, TcTyVar) -- [W] x:: F xis ~ fsk + -> FlatM (CtEvidence, Coercion, TcTyVar) -- [W] x:: F xis ~ fsk newFlattenSkolemFlatM ty = do { flavour <- getFlavour ; loc <- getLoc @@ -803,6 +815,10 @@ flattenManyNom ev tys Note that it is flatten's job to flatten *every type function it sees*. flatten is only called on *arguments* to type functions, by canEqGiven. +Flattening a type also means flattening its kind. In the case of a type +variable whose kind mentions a type family, this might mean that the result +of flattening has a cast in it. + Recall that in comments we use alpha[flat = ty] to represent a flattening skolem variable alpha which has been generated to stand in for ty. @@ -860,7 +876,7 @@ duplicate the flattener code for the nominal case, and make that case faster. This doesn't seem quite worth it, yet. -} -flatten_many :: [Role] -> [Type] -> FlatM ([Xi], [TcCoercion]) +flatten_many :: [Role] -> [Type] -> FlatM ([Xi], [Coercion]) -- Coercions :: Xi ~ Type, at roles given -- Returns True iff (no flattening happened) -- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused, @@ -873,19 +889,19 @@ flatten_many roles tys go Nominal ty = setEqRel NomEq $ flatten_one ty go Representational ty = setEqRel ReprEq $ flatten_one ty go Phantom ty = -- See Note [Phantoms in the flattener] - return (ty, mkTcPhantomCo ty ty) + do { ty <- liftTcS $ zonkTcType ty + ; return ( ty, mkReflCo Phantom ty ) } -- | Like 'flatten_many', but assumes that every role is nominal. -flatten_many_nom :: [Type] -> FlatM ([Xi], [TcCoercion]) +flatten_many_nom :: [Type] -> FlatM ([Xi], [Coercion]) flatten_many_nom [] = return ([], []) -- See Note [flatten_many performance] flatten_many_nom (ty:tys) = do { (xi, co) <- flatten_one ty ; (xis, cos) <- flatten_many_nom tys ; return (xi:xis, co:cos) } - ------------------ -flatten_one :: TcType -> FlatM (Xi, TcCoercion) +flatten_one :: TcType -> FlatM (Xi, Coercion) -- Flatten a type to get rid of type function applications, returning -- the new type-function-free type, and a collection of new equality -- constraints. See Note [Flattening] for more detail. @@ -895,22 +911,26 @@ flatten_one :: TcType -> FlatM (Xi, TcCoercion) flatten_one xi@(LitTy {}) = do { role <- getRole - ; return (xi, mkTcReflCo role xi) } + ; return (xi, mkReflCo role xi) } flatten_one (TyVarTy tv) = do { mb_yes <- flatten_tyvar tv ; role <- getRole ; case mb_yes of - Left tv' -> -- Done - do { traceFlat "flattenTyVar1" (ppr tv $$ ppr (tyVarKind tv')) - ; return (ty', mkTcReflCo role ty') } + FTRCasted tv' kco -> -- Done + do { traceFlat "flattenTyVar1" + (pprTvBndr tv' $$ + ppr kco <+> dcolon <+> ppr (coercionKind kco)) + ; return (ty', mkReflCo role ty + `mkCoherenceLeftCo` mkSymCo kco) } where - ty' = mkTyVarTy tv' + ty = mkTyVarTy tv' + ty' = ty `mkCastTy` mkSymCo kco - Right (ty1, co1) -- Recurse + FTRFollowed ty1 co1 -- Recur -> do { (ty2, co2) <- flatten_one ty1 ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2) - ; return (ty2, co2 `mkTcTransCo` co1) } } + ; return (ty2, co2 `mkTransCo` co1) } } flatten_one (AppTy ty1 ty2) = do { (xi1,co1) <- flatten_one ty1 @@ -920,32 +940,28 @@ flatten_one (AppTy ty1 ty2) (ReprEq, Nominal) -> flatten_rhs xi1 co1 NomEq (ReprEq, Representational) -> flatten_rhs xi1 co1 ReprEq (ReprEq, Phantom) -> - return (mkAppTy xi1 ty2, co1 `mkTcAppCo` mkTcNomReflCo ty2) } + do { ty2 <- liftTcS $ zonkTcType ty2 + ; return ( mkAppTy xi1 ty2 + , mkAppCo co1 (mkNomReflCo ty2)) } } where flatten_rhs xi1 co1 eq_rel2 = do { (xi2,co2) <- setEqRel eq_rel2 $ flatten_one ty2 - ; traceFlat "flatten/appty" - (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ - ppr co1 $$ ppr xi2) ; role1 <- getRole ; let role2 = eqRelRole eq_rel2 - ; return ( mkAppTy xi1 xi2 - , mkTcTransAppCo role1 co1 xi1 ty1 - role2 co2 xi2 ty2 - role1 ) } -- output should match fmode + ; traceFlat "flatten/appty" + (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ + ppr xi2 $$ ppr role1 $$ ppr role2) -flatten_one (FunTy ty1 ty2) - = do { (xi1,co1) <- flatten_one ty1 - ; (xi2,co2) <- flatten_one ty2 - ; role <- getRole - ; return (mkFunTy xi1 xi2, mkTcFunCo role co1 co2) } + ; return ( mkAppTy xi1 xi2 + , mkTransAppCo role1 co1 xi1 ty1 + role2 co2 xi2 ty2 + role1 ) } -- output should match fmode flatten_one (TyConApp tc tys) - -- Expand type synonyms that mention type families -- on the RHS; see Note [Flattening synonyms] | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys' + , let expanded_ty = mkAppTys (substTy (mkTopTCvSubst tenv) rhs) tys' = do { mode <- getMode ; let used_tcs = tyConsOfType rhs ; case mode of @@ -970,23 +986,62 @@ flatten_one (TyConApp tc tys) -- _ -> fmode = flatten_ty_con_app tc tys -flatten_one ty@(ForAllTy {}) +flatten_one (ForAllTy (Anon ty1) ty2) + = do { (xi1,co1) <- flatten_one ty1 + ; (xi2,co2) <- flatten_one ty2 + ; role <- getRole + ; return (mkFunTy xi1 xi2, mkFunCo role co1 co2) } + +flatten_one ty@(ForAllTy (Named {}) _) +-- TODO (RAE): This is inadequate, as it doesn't flatten the kind of +-- the bound tyvar. Doing so will require carrying around a substitution +-- and the usual substTyVarBndr-like silliness. Argh. + -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. - = do { let (tvs, rho) = splitForAllTys ty + = do { let (bndrs, rho) = splitNamedPiTys ty + tvs = map (binderVar "flatten") bndrs ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho -- Substitute only under a forall -- See Note [Flattening under a forall] - ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } + ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) } -flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, TcCoercion) +flatten_one (CastTy ty g) + = do { (xi, co) <- flatten_one ty + ; (g', _) <- flatten_co g + + ; return (mkCastTy xi g', castCoercionKind co g' g) } + +flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co + +-- | "Flatten" a coercion. Really, just flatten the types that it coerces +-- between and then use transitivity. +flatten_co :: Coercion -> FlatM (Coercion, Coercion) +flatten_co co + = do { let (Pair ty1 ty2, role) = coercionKindRole co + ; co <- liftTcS $ zonkCo co -- squeeze out any metavars from the original + ; (co1, co2) <- flattenKinds $ + do { (_, co1) <- flatten_one ty1 + ; (_, co2) <- flatten_one ty2 + ; return (co1, co2) } + ; let co' = downgradeRole role Nominal co1 `mkTransCo` + co `mkTransCo` + mkSymCo (downgradeRole role Nominal co2) + -- kco :: (ty1' ~r ty2') ~N (ty1 ~r ty2) + kco = mkTyConAppCo Nominal (equalityTyCon role) + [ mkKindCo co1, mkKindCo co2, co1, co2 ] + ; traceFlat "flatten_co" (vcat [ ppr co, ppr co1, ppr co2, ppr co' ]) + ; env_role <- getRole + ; return (co', mkProofIrrelCo env_role kco co' co) } + +flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) flatten_ty_con_app tc tys = do { eq_rel <- getEqRel ; let role = eqRelRole eq_rel ; (xis, cos) <- case eq_rel of NomEq -> flatten_many_nom tys ReprEq -> flatten_many (tyConRolesX role tc) tys - ; return (mkTyConApp tc xis, mkTcTyConAppCo role tc cos) } + ; return (mkTyConApp tc xis, mkTyConAppCo role tc cos) } {- Note [Flattening synonyms] @@ -1031,8 +1086,7 @@ and we have not begun to think about how to make that work! ************************************************************************ -} -flatten_fam_app, flatten_exact_fam_app, flatten_exact_fam_app_fully - :: TyCon -> [TcType] -> FlatM (Xi, TcCoercion) +flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion) -- flatten_fam_app can be over-saturated -- flatten_exact_fam_app is exactly saturated -- flatten_exact_fam_app_fully lifts out the application to top level @@ -1051,11 +1105,16 @@ flatten_fam_app tc tys -- Can be over-saturated -- all Nominal roles b/c the tycon is oversaturated ; (xis_rest, cos_rest) <- flatten_many (repeat Nominal) tys_rest -- cos_res :: xis_rest ~ tys_rest + ; return ( mkAppTys xi1 xis_rest -- NB mkAppTys: rhs_xi might not be a type variable -- cf Trac #5655 - , mkTcAppCos co1 cos_rest -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys) + , mkAppCos co1 cos_rest + -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys) ) } +flatten_exact_fam_app, flatten_exact_fam_app_fully :: + TyCon -> [TcType] -> FlatM (Xi, Coercion) + flatten_exact_fam_app tc tys = do { mode <- getMode ; role <- getRole @@ -1064,7 +1123,7 @@ flatten_exact_fam_app tc tys FM_SubstOnly -> do { (xis, cos) <- flatten_many roles tys ; return ( mkTyConApp tc xis - , mkTcTyConAppCo role tc cos ) } + , mkTyConAppCo role tc cos ) } where -- These are always going to be Nominal for now, -- but not if #8177 is implemented @@ -1072,7 +1131,7 @@ flatten_exact_fam_app tc tys -- FM_Avoid tv flat_top -> -- do { (xis, cos) <- flatten_many fmode roles tys --- ; if flat_top || tv `elemVarSet` tyVarsOfTypes xis +-- ; if flat_top || tv `elemVarSet` tyCoVarsOfTypes xis -- then flatten_exact_fam_app_fully fmode tc tys -- else return ( mkTyConApp tc xis -- , mkTcTyConAppCo (feRole fmode) tc cos ) } @@ -1081,38 +1140,38 @@ flatten_exact_fam_app_fully tc tys -- See Note [Reduce type family applications eagerly] = try_to_reduce tc tys False id $ do { -- First, flatten the arguments - (xis, cos) <- setEqRel NomEq $ flatten_many_nom tys + ; (xis, cos) <- setEqRel NomEq $ flatten_many_nom tys ; eq_rel <- getEqRel ; let role = eqRelRole eq_rel - ret_co = mkTcTyConAppCo role tc cos + ret_co = mkTyConAppCo role tc cos -- ret_co :: F xis ~ F tys -- Now, look in the cache ; mb_ct <- liftTcS $ lookupFlatCache tc xis - ; flavour_role <- getFlavourRole + ; fr <- getFlavourRole ; case mb_ct of Just (co, rhs_ty, flav) -- co :: F xis ~ fsk - | (flav, NomEq) `canDischargeFR` flavour_role + | (flav, NomEq) `canDischargeFR` fr -> -- Usable hit in the flat-cache -- We certainly *can* use a Wanted for a Wanted do { traceFlat "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr rhs_ty) ; (fsk_xi, fsk_co) <- flatten_one rhs_ty -- The fsk may already have been unified, so flatten it -- fsk_co :: fsk_xi ~ fsk - ; return (fsk_xi, fsk_co `mkTcTransCo` - maybeTcSubCo eq_rel - (mkTcSymCo co) `mkTcTransCo` - ret_co) } + ; return ( fsk_xi + , fsk_co `mkTransCo` + maybeSubCo eq_rel (mkSymCo co) `mkTransCo` + ret_co ) } -- :: fsk_xi ~ F xis -- Try to reduce the family application right now -- See Note [Reduce type family applications eagerly] - _ -> try_to_reduce tc xis True (`mkTcTransCo` ret_co) $ + _ -> try_to_reduce tc xis True (`mkTransCo` ret_co) $ do { let fam_ty = mkTyConApp tc xis - ; (ev, fsk) <- newFlattenSkolemFlatM fam_ty + ; (ev, co, fsk) <- newFlattenSkolemFlatM fam_ty ; let fsk_ty = mkTyVarTy fsk - co = ctEvCoercion ev - ; liftTcS $ extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev) + ; liftTcS $ extendFlatCache tc xis ( co + , fsk_ty, ctEvFlavour ev) -- The new constraint (F xis ~ fsk) is not necessarily inert -- (e.g. the LHS may be a redex) so we must put it in the work list @@ -1122,34 +1181,42 @@ flatten_exact_fam_app_fully tc tys , cc_fsk = fsk } ; emitFlatWork ct - ; traceFlat "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr fsk) - ; return (fsk_ty, maybeTcSubCo eq_rel - (mkTcSymCo co) - `mkTcTransCo` ret_co) } + ; traceFlat "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr fsk $$ ppr ev) + ; (fsk_xi, fsk_co) <- flatten_one fsk_ty + ; return (fsk_xi, fsk_co + `mkTransCo` + maybeSubCo eq_rel (mkSymCo co) + `mkTransCo` ret_co ) } } where try_to_reduce :: TyCon -- F, family tycon -> [Type] -- args, not necessarily flattened -> Bool -- add to the flat cache? - -> ( TcCoercion -- :: xi ~ F args - -> TcCoercion ) -- what to return from outer function - -> FlatM (Xi, TcCoercion) -- continuation upon failure - -> FlatM (Xi, TcCoercion) + -> ( Coercion -- :: xi ~ F args + -> Coercion ) -- what to return from outer function + -> FlatM (Xi, Coercion) -- continuation upon failure + -> FlatM (Xi, Coercion) try_to_reduce tc tys cache update_co k = do { checkStackDepth (mkTyConApp tc tys) ; mb_match <- liftTcS $ matchFam tc tys ; case mb_match of Just (norm_co, norm_ty) -> do { traceFlat "Eager T.F. reduction success" $ - vcat [ppr tc, ppr tys, ppr norm_ty, ppr cache] + vcat [ ppr tc, ppr tys, ppr norm_ty + , ppr norm_co <+> dcolon + <+> ppr (coercionKind norm_co) + , ppr cache] ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty - ; let co = norm_co `mkTcTransCo` mkTcSymCo final_co + ; eq_rel <- getEqRel + ; let co = maybeSubCo eq_rel norm_co + `mkTransCo` mkSymCo final_co ; flavour <- getFlavour - ; when cache $ + -- NB: only extend cache with nominal equalities + ; when (cache && eq_rel == NomEq) $ liftTcS $ - extendFlatCache tc tys (co, xi, flavour) - ; return (xi, update_co $ mkTcSymCo co) } + extendFlatCache tc tys ( co, xi, flavour ) + ; return ( xi, update_co $ mkSymCo co ) } Nothing -> k } {- Note [Reduce type family applications eagerly] @@ -1199,14 +1266,23 @@ have any knowledge as to *why* these facts are true. * * ********************************************************************* -} -flatten_tyvar :: TcTyVar - -> FlatM (Either TyVar (TcType, TcCoercion)) +-- | The result of flattening a tyvar "one step". +data FlattenTvResult + = FTRCasted TyVar Coercion + -- ^ Flattening the tyvar's kind produced a cast. + -- co :: new kind ~N old kind; + -- The 'TyVar' in there might have a new, zonked kind + | FTRFollowed TcType Coercion + -- ^ The tyvar flattens to a not-necessarily flat other type. + -- co :: new type ~r old type, where the role is determined by + -- the FlattenEnv + +flatten_tyvar :: TcTyVar -> FlatM FlattenTvResult -- "Flattening" a type variable means to apply the substitution to it -- Specifically, look up the tyvar in -- * the internal MetaTyVar box -- * the inerts --- Return (Left tv') if it is not found, tv' has a properly zonked kind --- (Right (ty, co) if found, with co :: ty ~ tv; +-- See also the documentation for FlattenTvResult flatten_tyvar tv | not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty) @@ -1218,23 +1294,21 @@ flatten_tyvar tv ; role <- getRole ; case mb_ty of Just ty -> do { traceFlat "Following filled tyvar" (ppr tv <+> equals <+> ppr ty) - ; return (Right (ty, mkTcReflCo role ty)) } ; - Nothing -> do { flavour_role <- getFlavourRole - ; flatten_tyvar2 tv flavour_role } } + ; return (FTRFollowed ty (mkReflCo role ty)) } ; + Nothing -> do { fr <- getFlavourRole + ; flatten_tyvar2 tv fr } } -flatten_tyvar2 :: TcTyVar -> CtFlavourRole - -> FlatM (Either TyVar (TcType, TcCoercion)) +flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult -- Try in the inert equalities -- See Definition [Applying a generalised substitution] in TcSMonad -- See Note [Stability of flattening] in TcSMonad -flatten_tyvar2 tv flavour_role@(flavour, eq_rel) +flatten_tyvar2 tv fr@(flavour, eq_rel) | Derived <- flavour -- For derived equalities, consult the inert_model (only) - = ASSERT( eq_rel == NomEq ) -- All derived equalities are nominal - do { model <- liftTcS $ getInertModel + = do { model <- liftTcS $ getInertModel ; case lookupVarEnv model tv of Just (CTyEqCan { cc_rhs = rhs }) - -> return (Right (rhs, pprPanic "flatten_tyvar2" (ppr tv $$ ppr rhs))) + -> return (FTRFollowed rhs (pprPanic "flatten_tyvar2" (ppr tv $$ ppr rhs))) -- Evidence is irrelevant for Derived contexts _ -> flatten_tyvar3 tv } @@ -1244,31 +1318,40 @@ flatten_tyvar2 tv flavour_role@(flavour, eq_rel) Just (ct:_) -- If the first doesn't work, -- the subsequent ones won't either | CTyEqCan { cc_ev = ctev, cc_tyvar = tv, cc_rhs = rhs_ty } <- ct - , ctEvFlavourRole ctev `eqCanRewriteFR` flavour_role + , ctEvFlavourRole ctev `eqCanRewriteFR` fr -> do { traceFlat "Following inert tyvar" (ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev) - ; let rewrite_co1 = mkTcSymCo (ctEvCoercion ctev) - rewrite_co = case (ctEvEqRel ctev, eq_rel) of + ; let rewrite_co1 = mkSymCo $ ctEvCoercion ctev + rewrite_co = case (ctEvEqRel ctev, eq_rel) of (ReprEq, _rel) -> ASSERT( _rel == ReprEq ) -- if this ASSERT fails, then -- eqCanRewriteFR answered incorrectly rewrite_co1 (NomEq, NomEq) -> rewrite_co1 - (NomEq, ReprEq) -> mkTcSubCo rewrite_co1 + (NomEq, ReprEq) -> mkSubCo rewrite_co1 - ; return (Right (rhs_ty, rewrite_co)) } + ; return (FTRFollowed rhs_ty rewrite_co) } -- NB: ct is Derived then fmode must be also, hence -- we are not going to touch the returned coercion -- so ctEvCoercion is fine. _other -> flatten_tyvar3 tv } -flatten_tyvar3 :: TcTyVar -> FlatM (Either TyVar a) --- Always returns Left! +flatten_tyvar3 :: TcTyVar -> FlatM FlattenTvResult +-- Always returns FTRCasted! flatten_tyvar3 tv = -- Done, but make sure the kind is zonked do { let kind = tyVarKind tv - ; (new_knd, _kind_co) <- setMode FM_SubstOnly $ flatten_one kind - ; return (Left (setVarType tv new_knd)) } + ; (_new_kind, kind_co) + <- setMode FM_SubstOnly $ + flattenKinds $ + flatten_one kind + ; traceFlat "flattenTyVarFinal" + (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) + , ppr _new_kind + , ppr kind_co <+> dcolon <+> ppr (coercionKind kind_co) ]) + ; let Pair _ orig_kind = coercionKind kind_co + -- orig_kind might be zonked + ; return (FTRCasted (setTyVarKind tv orig_kind) kind_co) } {- Note [An alternative story for the inert substitution] @@ -1460,7 +1543,7 @@ unflatten tv_eqs funeqs try_fill dflags tclvl ev ty1 ty2 | Just tv1 <- tcGetTyVar_maybe ty1 , isTouchableOrFmv tclvl tv1 - , typeKind ty1 `isSubKind` tyVarKind tv1 + , typeKind ty1 `eqType` tyVarKind tv1 = tryFill dflags tv1 ty2 ev | otherwise = return False diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index 01be9204bb..454cde4d70 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -43,7 +43,6 @@ import FamInst import FamInstEnv import Coercion import Type -import TypeRep import ForeignCall import ErrUtils import Id @@ -62,6 +61,7 @@ import FastString import Hooks import Control.Monad +import Data.Maybe -- Defines a binding isForeignImport :: LForeignDecl name -> Bool @@ -121,13 +121,28 @@ normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrEl normaliseFfiType' env ty0 = go initRecTc ty0 where go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) - go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms - = go rec_nts ty' + go rec_nts ty + | Just ty' <- coreView ty -- Expand synonyms + = go rec_nts ty' - go rec_nts ty@(TyConApp tc tys) + | Just (tc, tys) <- splitTyConApp_maybe ty + = go_tc_app rec_nts tc tys + + | Just (bndr, inner_ty) <- splitPiTy_maybe ty + , Just tyvar <- binderVar_maybe bndr + = do (coi, nty1, gres1) <- go rec_nts inner_ty + return ( mkHomoForAllCos [tyvar] coi + , mkForAllTy bndr nty1, gres1 ) + + | otherwise -- see Note [Don't recur in normaliseFfiType'] + = return (mkRepReflCo ty, ty, emptyBag) + + go_tc_app :: RecTcChecker -> TyCon -> [Type] + -> TcM (Coercion, Type, Bag GlobalRdrElt) + go_tc_app rec_nts tc tys -- We don't want to look through the IO newtype, even if it is -- in scope, so we have a special case for it: - | tc_key `elem` [ioTyConKey, funPtrTyConKey] + | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] -- These *must not* have nominal roles on their parameters! -- See Note [FFI type roles] = children_only @@ -165,23 +180,11 @@ normaliseFfiType' env ty0 = go initRecTc ty0 (repeat Representational) cos return ( mkTyConAppCo Representational tc cos' , mkTyConApp tc tys', unionManyBags gres) - nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys + nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys [] nt_rhs = newTyConInstRhs tc tys - nothing = return (Refl Representational ty, ty, emptyBag) - - go rec_nts (FunTy ty1 ty2) - = do (coi1,nty1,gres1) <- go rec_nts ty1 - (coi2,nty2,gres2) <- go rec_nts ty2 - return (mkFunCo Representational coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2) - - go rec_nts (ForAllTy tyvar ty1) - = do (coi,nty1,gres1) <- go rec_nts ty1 - return (mkForAllCo tyvar coi, ForAllTy tyvar nty1, gres1) - go _ ty@(TyVarTy {}) = return (Refl Representational ty, ty, emptyBag) - go _ ty@(LitTy {}) = return (Refl Representational ty, ty, emptyBag) - go _ ty@(AppTy {}) = return (Refl Representational ty, ty, emptyBag) - -- See Note [Don't recur in normaliseFfiType'] + ty = mkTyConApp tc tys + nothing = return (mkRepReflCo ty, ty, emptyBag) checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt checkNewtypeFFI rdr_env tc @@ -237,13 +240,13 @@ tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt) tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty , fd_fi = imp_decl })) = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ - do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + do { sig_ty <- solveEqualities $ tcHsSigType (ForSigCtxt nm) hs_ty ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty ; let -- Drop the foralls before inspecting the -- structure of the foreign type. - (_, t_ty) = tcSplitForAllTys norm_sig_ty - (arg_tys, res_ty) = tcSplitFunTys t_ty + (bndrs, res_ty) = tcSplitPiTys norm_sig_ty + arg_tys = mapMaybe binderRelevantType_maybe bndrs id = mkLocalId nm sig_ty -- Use a LocalId to obey the invariant that locally-defined -- things are LocalIds. However, it does not need zonking, @@ -298,7 +301,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected"))) (arg1_ty:arg_tys) -> do dflags <- getDynFlags - let curried_res_ty = foldr FunTy res_ty arg_tys + let curried_res_ty = mkFunTys arg_tys res_ty check (isFFIDynTy curried_res_ty arg1_ty) (illegalForeignTyErr argument) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -415,8 +418,8 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do where -- Drop the foralls before inspecting n -- the structure of the foreign type. - (_, t_ty) = tcSplitForAllTys sig_ty - (arg_tys, res_ty) = tcSplitFunTys t_ty + (bndrs, res_ty) = tcSplitPiTys sig_ty + arg_tys = mapMaybe binderRelevantType_maybe bndrs {- ************************************************************************ diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 19497fc8dd..009d203128 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -55,7 +55,7 @@ import TysPrim import TysWiredIn import Type import Class -import TypeRep +import TyCoRep import VarSet import VarEnv import State @@ -1395,8 +1395,8 @@ gen_Data_binds dflags loc rep_tc kind1, kind2 :: Kind -kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind -kind2 = liftedTypeKind `mkArrowKind` kind1 +kind1 = liftedTypeKind `mkFunTy` liftedTypeKind +kind2 = liftedTypeKind `mkFunTy` kind1 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, @@ -1620,8 +1620,8 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar go co ty | Just ty' <- coreView ty = go co ty' go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) - go co (FunTy x y) | isPredTy x = go co y - | xc || yc = (caseFun xr yr,True) + go co (ForAllTy (Anon x) y) | isPredTy x = go co y + | xc || yc = (caseFun xr yr,True) where (xr,xc) = go (not co) x (yr,yc) = go co y go co (AppTy x y) | xc = (caseWrongArg, True) @@ -1639,8 +1639,10 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) where (xrs,xcs) = unzip (map (go co) args) - go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True) + go co (ForAllTy (Named v Invisible) x) | v /= var && xc = (caseForAll v xr,True) where (xr,xc) = go co x + + go _ (ForAllTy (Named _ Visible) _) = panic "unexpected visible binder" go _ _ = (caseTrivial,False) -- Return all syntactic subterms of ty that contain var somewhere @@ -1655,7 +1657,7 @@ deepSubtypesContaining tv , ft_ty_app = (:) , ft_bad_app = panic "in other argument" , ft_co_var = panic "contravariant" - , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs }) + , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) foldDataConArgs :: FFoldType a -> DataCon -> [a] @@ -1981,9 +1983,12 @@ mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id where cls_tvs = classTyVars cls in_scope = mkInScopeSet $ mkVarSet inst_tvs - lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys) - rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty)) - (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id) + lhs_subst = mkTCvSubst in_scope (zipTyEnv cls_tvs cls_tys, emptyCvSubstEnv) + rhs_subst = mkTCvSubst in_scope + ( zipTyEnv cls_tvs (changeLast cls_tys rhs_ty) + , emptyCvSubstEnv ) + (_class_tvs, _class_constraint, user_meth_ty) + = tcSplitSigmaTy (varType id) changeLast :: [a] -> a -> [a] changeLast [] _ = panic "changeLast" @@ -2047,7 +2052,7 @@ genAuxBindSpec loc (DerivCon2Tag tycon) rdr_name = con2tag_RDR tycon sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ - mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ + mkInvSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ mkParentType tycon `mkFunTy` intPrimTy lots_of_constructors = tyConFamilySize tycon > 8 @@ -2071,7 +2076,7 @@ genAuxBindSpec loc (DerivTag2Con tycon) L loc (TypeSig [L loc rdr_name] sig_ty)) where sig_ty = mkLHsSigWcType $ L loc $ - HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ + HsCoreTy $ mkInvForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon rdr_name = tag2con_RDR tycon @@ -2186,7 +2191,7 @@ primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty ) where boxRDR - | ty == addrPrimTy = unpackCString_RDR + | ty `eqType` addrPrimTy = unpackCString_RDR | otherwise = assoc_ty_id str tycon boxConTbl ty ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 2c5b80ef03..fb18517ad5 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -15,7 +15,6 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1, import HsSyn import Type -import Kind ( isKind ) import TcType import TcGenDeriv import DataCon @@ -147,7 +146,7 @@ canDoGenerics tc tc_args -- -- Data family indices can be instantiated; the `tc_args` here are -- the representation tycon args - (if (all isTyVarTy (filterOut isKind tc_args)) + (if (all isTyVarTy (filterOutInvisibleTypes tc tc_args)) then IsValid else NotValid (tc_name <+> text "must not be instantiated;" <+> text "try deriving `" <> tc_name <+> tc_tys <> @@ -397,7 +396,7 @@ tc_mkRepFamInsts gk tycon mod = in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon))) (nameSrcSpan (tyConName tycon)) - ; let axiom = mkSingleCoAxiom Nominal rep_name tyvars fam_tc appT repTy + ; let axiom = mkSingleCoAxiom Nominal rep_name tyvars [] fam_tc appT repTy ; newFamInst SynFamilyInst axiom } -------------------------------------------------------------------------------- @@ -460,7 +459,7 @@ argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0, isApp = do -- handles applications (phi, beta) <- tcSplitAppTy_maybe t - let interesting = argVar `elemVarSet` exactTyVarsOfType beta + let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta -- Does it have no interesting structure to represent? if not interesting then Nothing @@ -602,12 +601,12 @@ mkBoxTy :: TyCon -- UAddr -> Type -> Type mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty - | ty == addrPrimTy = mkTyConTy uAddr - | ty == charPrimTy = mkTyConTy uChar - | ty == doublePrimTy = mkTyConTy uDouble - | ty == floatPrimTy = mkTyConTy uFloat - | ty == intPrimTy = mkTyConTy uInt - | ty == wordPrimTy = mkTyConTy uWord + | ty `eqType` addrPrimTy = mkTyConTy uAddr + | ty `eqType` charPrimTy = mkTyConTy uChar + | ty `eqType` doublePrimTy = mkTyConTy uDouble + | ty `eqType` floatPrimTy = mkTyConTy uFloat + | ty `eqType` intPrimTy = mkTyConTy uInt + | ty `eqType` wordPrimTy = mkTyConTy uWord | otherwise = mkTyConApp rec0 [ty] -------------------------------------------------------------------------------- @@ -737,12 +736,12 @@ unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs -- constructor. See Note [Generics and unlifted types] unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName) unboxedRepRDRs ty - | ty == addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) - | ty == charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) - | ty == doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) - | ty == floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) - | ty == intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) - | ty == wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) + | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR) + | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR) + | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR) + | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR) + | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR) + | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR) | otherwise = Nothing -- Build a product pattern diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 2aeca15953..2b57a400a8 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -24,8 +24,9 @@ module TcHsSyn ( zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkTopBndrs, zonkTyBndrsX, - emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, + emptyZonkEnv, mkEmptyZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc, + zonkCoToCo ) where #include "HsVersions.h" @@ -34,14 +35,13 @@ import HsSyn import Id import TcRnMonad import PrelNames -import TypeRep -- We can see the representation of types import TcType -import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar ) +import TcMType import TcEvidence -import Coercion import TysPrim import TysWiredIn import Type +import Coercion import ConLike import DataCon import Name @@ -59,6 +59,8 @@ import Util #if __GLASGOW_HASKELL__ < 709 import Data.Traversable ( traverse ) #endif +import Control.Monad +import Data.List ( partition ) {- ************************************************************************ @@ -170,15 +172,26 @@ It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. -} -type UnboundTyVarZonker = TcTyVar-> TcM Type +type UnboundTyVarZonker = TcTyVar -> TcM Type -- How to zonk an unbound type variable -- Note [Zonking the LHS of a RULE] +-- | A ZonkEnv carries around several bits. +-- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as +-- defined in zonkTypeZapping), except on the LHS of rules. See +-- Note [Zonking the LHS of a RULE]. The (TyCoVarEnv TyVar) and is just +-- an optimisation: when binding a tyvar or covar, we zonk the kind right away +-- and add a mapping to the env. This prevents re-zonking the kind at +-- every occurrence. But this is *just* an optimisation. +-- The final (IdEnv Var) optimises zonking for +-- Ids. It is knot-tied. We must be careful never to put coercion variables +-- (which are Ids, after all) in the knot-tied env, because coercions can +-- appear in types, and we sometimes inspect a zonked type in this module. data ZonkEnv = ZonkEnv UnboundTyVarZonker - (TyVarEnv TyVar) -- - (IdEnv Var) -- What variables are in scope + (TyCoVarEnv TyVar) + (IdEnv Var) -- What variables are in scope -- Maps an Id or EvVar to its zonked version; both have the same Name -- Note that all evidence (coercion variables as well as dictionaries) -- are kept in the ZonkEnv @@ -189,15 +202,31 @@ instance Outputable ZonkEnv where ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env)) +-- The EvBinds have to already be zonked, but that's usually the case. emptyZonkEnv :: ZonkEnv emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv -extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids +-- | Extend the knot-tied environment. +extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv +extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids + -- NB: Don't look at the var to decide which env't to put it in. That + -- would end up knot-tying all the env'ts. = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids]) + -- Given coercion variables will actually end up here. That's OK though: + -- coercion variables are never looked up in the knot-tied env't, so zonking + -- them simply doesn't get optimised. No one gets hurt. An improvement (?) + -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the + -- recursive groups. But perhaps the time it takes to do the analysis is + -- more than the savings. + +extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv +extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars + = ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]) + (extendVarEnvList id_env [(id,id) | id <- ids]) + where (tycovars, ids) = partition isTyCoVar vars extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id @@ -207,11 +236,9 @@ extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env -mkTyVarZonkEnv :: [TyVar] -> ZonkEnv -mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv - setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv -setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env +setZonkType (ZonkEnv _ ty_env id_env) zonk_ty + = ZonkEnv zonk_ty ty_env id_env zonkEnvIds :: ZonkEnv -> [Id] zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env @@ -232,8 +259,9 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id -- -- Even without template splices, in module Main, the checking of -- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id - | isLocalVar id = lookupVarEnv env id `orElse` id +zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id + | isLocalVar id = lookupVarEnv id_env id `orElse` + id | otherwise = id zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] @@ -244,7 +272,7 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env id = do ty' <- zonkTcTypeToType env (idType id) - return (Id.setIdType id ty') + return (setIdType id ty') zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] zonkIdBndrs env ids = mapM (zonkIdBndr env) ids @@ -262,7 +290,7 @@ zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) -- Works for dictionaries and coercions zonkEvBndrX env var = do { var' <- zonkEvBndr env var - ; return (extendIdZonkEnv1 env var', var') } + ; return (extendZonkEnv env [var'], var') } zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar -- Works for dictionaries and coercions @@ -274,8 +302,12 @@ zonkEvBndr env var zonkTcTypeToType env var_ty ; return (setVarType var ty) } -zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar -zonkEvVarOcc env v = zonkIdOcc env v +zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm +zonkEvVarOcc env v + | isCoVar v + = EvCoercion <$> zonkCoVarOcc env v + | otherwise + = return (EvId $ zonkIdOcc env v) zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar]) zonkTyBndrsX = mapAccumLM zonkTyBndrX @@ -284,7 +316,8 @@ zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar) -- This guarantees to return a TyVar (not a TcTyVar) -- then we add it to the envt, so all occurrences are replaced zonkTyBndrX env tv - = do { ki <- zonkTcTypeToType env (tyVarKind tv) + = ASSERT( isImmutableTyVar tv ) + do { ki <- zonkTcTypeToType env (tyVarKind tv) ; let tv' = mkTyVar (tyVarName tv) ki ; return (extendTyZonkEnv1 env tv', tv') } @@ -336,7 +369,7 @@ zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs)) zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do new_binds <- mapM (wrapLocM zonk_ip_bind) binds let - env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds] + env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) where @@ -349,7 +382,7 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) zonkRecMonoBinds env binds = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds) + { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds) ; binds' <- zonkMonoBinds env1 binds ; return (env1, binds') }) @@ -389,7 +422,8 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs ; (env1, new_evs) <- zonkEvBndrsX env0 evs ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> - do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds) + do { let env3 = extendIdZonkEnvRec env2 + (collectHsBindsBinders new_val_binds) ; new_val_binds <- zonkMonoBinds env3 val_binds ; new_exports <- mapM (zonkExport env3) exports ; return (new_val_binds, new_exports) } @@ -705,7 +739,7 @@ zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd zonkCmd env (HsCmdCast co cmd) - = do { co' <- zonkTcCoToCo env co + = do { co' <- zonkCoToCo env co ; cmd' <- zonkCmd env cmd ; return (HsCmdCast co' cmd') } zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) @@ -780,7 +814,7 @@ zonkCoFn env (WpFun c1 c2 t1 t2) = do { (env1, c1') <- zonkCoFn env c1 ; t1' <- zonkTcTypeToType env2 t1 ; t2' <- zonkTcTypeToType env2 t2 ; return (env2, WpFun c1' c2' t1' t2') } -zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co +zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev ; return (env', WpEvLam ev') } @@ -840,7 +874,7 @@ zonkStmt :: ZonkEnv zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op) = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] - env1 = extendIdZonkEnv env new_binders + env1 = extendIdZonkEnvRec env new_binders ; new_mzip <- zonkExpr env1 mzip_op ; new_bind <- zonkExpr env1 bind_op ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) } @@ -860,13 +894,13 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_ ; new_ret_id <- zonkExpr env ret_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id - ; let env1 = extendIdZonkEnv env new_rvs + ; let env1 = extendIdZonkEnvRec env new_rvs ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt ; new_later_rets <- mapM (zonkExpr env2) later_rets ; new_rec_rets <- mapM (zonkExpr env2) rec_rets - ; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed + ; return (extendIdZonkEnvRec env new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id @@ -895,7 +929,7 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap ; return_op' <- zonkExpr env' return_op ; bind_op' <- zonkExpr env' bind_op ; liftM_op' <- zonkExpr env' liftM_op - ; let env'' = extendIdZonkEnv env' (map snd binderMap') + ; let env'' = extendIdZonkEnvRec env' (map snd binderMap') ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' , trS_by = by', trS_form = form, trS_using = using' , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } @@ -1137,7 +1171,8 @@ zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) = do { unbound_tkv_set <- newMutVar emptyVarSet - ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set) + ; let kind_var_set = identify_kind_vars vars + env_rule = setZonkType env (zonkTvCollecting kind_var_set unbound_tkv_set) -- See Note [Zonking the LHS of a RULE] ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars @@ -1149,7 +1184,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) ; let final_bndrs :: [LRuleBndr Var] final_bndrs = map (noLoc . RuleBndr . noLoc) - (varSetElemsKvsFirst unbound_tkvs) + (varSetElemsWellScoped unbound_tkvs) ++ new_bndrs ; return $ @@ -1162,13 +1197,25 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) zonk_it env v | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', v') } + ; return (extendIdZonkEnvRec env [v'], v') } | otherwise = ASSERT( isImmutableTyVar v) zonkTyBndrX env v -- DV: used to be return (env,v) but that is plain -- wrong because we may need to go inside the kind -- of v and zonk there! + -- returns the set of type variables mentioned in the kind of another + -- type. This is used only when -XPolyKinds is not set. + identify_kind_vars :: [LRuleBndr TcId] -> TyVarSet + identify_kind_vars rule_bndrs + = let vars = map strip_rulebndr rule_bndrs in + unionVarSets (map (\v -> if isTyVar v + then tyCoVarsOfType (tyVarKind v) + else emptyVarSet) vars) + + strip_rulebndr (L _ (RuleBndr (L _ v))) = v + strip_rulebndr (L _ (RuleBndrSig {})) = panic "strip_rulebndr zonkRule" + zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] zonkVects env = mapM (wrapLocM (zonkVect env)) @@ -1202,11 +1249,11 @@ zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) - return (EvId (zonkIdOcc env v)) -zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co + zonkEvVarOcc env v +zonkEvTerm env (EvCoercion co) = do { co' <- zonkCoToCo env co ; return (EvCoercion co') } zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm - ; co' <- zonkTcCoToCo env co + ; co' <- zonkCoToCo env co ; return (mkEvCast tm' co') } zonkEvTerm _ (EvLit l) = return (EvLit l) @@ -1226,20 +1273,23 @@ zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d ; return (EvSuperClass d' n) } zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys - ; return (EvDFunApp (zonkIdOcc env df) tys' (zonkIdOccs env tms)) } + ; tms' <- mapM (zonkEvTerm env) tms + ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } zonkEvTerm env (EvDelayedError ty msg) = do { ty' <- zonkTcTypeToType env ty ; return (EvDelayedError ty' msg) } zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable -zonkEvTypeable _ EvTypeableTyCon - = return EvTypeableTyCon +zonkEvTypeable env (EvTypeableTyCon ts) + = do { ts' <- mapM (zonkEvTerm env) ts + ; return $ EvTypeableTyCon ts' } zonkEvTypeable env (EvTypeableTyApp t1 t2) = do { t1' <- zonkEvTerm env t1 ; t2' <- zonkEvTerm env t2 ; return (EvTypeableTyApp t1' t2') } -zonkEvTypeable _ (EvTypeableTyLit t1) - = return (EvTypeableTyLit t1) +zonkEvTypeable env (EvTypeableTyLit t1) + = do { t1' <- zonkEvTerm env t1 + ; return (EvTypeableTyLit t1') } zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs @@ -1261,7 +1311,7 @@ zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) zonkEvBinds env binds = {-# SCC "zonkEvBinds" #-} fixM (\ ~( _, new_binds) -> do - { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds) + { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) ; binds' <- mapBagM (zonkEvBind env1) binds ; return (env1, binds') }) where @@ -1270,18 +1320,19 @@ zonkEvBinds env binds add (EvBind { eb_lhs = var }) vars = var : vars zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind -zonkEvBind env (EvBind { eb_lhs = var, eb_rhs = term, eb_is_given = is_given }) +zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var -- Optimise the common case of Refl coercions -- See Note [Optimise coercion zonking] -- This has a very big effect on some programs (eg Trac #5030) + ; term' <- case getEqPredTys_maybe (idType var') of Just (r, ty1, ty2) | ty1 `eqType` ty2 -> return (EvCoercion (mkTcReflCo r ty1)) _other -> zonkEvTerm env term - ; return (EvBind { eb_lhs = var', eb_rhs = term', eb_is_given = is_given }) } + ; return (bind { eb_lhs = var', eb_rhs = term' }) } {- ************************************************************************ @@ -1330,13 +1381,11 @@ type and kind variables. Consider the following datatype: data Phantom a = Phantom Int -The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and +The type of Phantom is (forall (k : *). forall (a : k). Int). Both `a` and `k` are unbound variables. We want to zonk this to -(forall (k : AnyK). forall (a : Any AnyK). Int). For that we have to check if -we have a type or a kind variable; for kind variables we just return AnyK (and -not the ill-kinded Any BOX). +(forall (k : Any *). forall (a : Any (Any *)). Int). -Note [Optimise coercion zonkind] +Note [Optimise coercion zonking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When optimising evidence binds we may come across situations where a coercion looks like @@ -1350,6 +1399,7 @@ use Refl on the right, ignoring the actual coercion on the RHS. This can have a very big effect, because the constraint solver sometimes does go to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030) + -} zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType @@ -1375,129 +1425,78 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv where lookup_in_env -- Look up in the env just as we do for Ids = case lookupVarEnv tv_env tv of - Nothing -> return (mkTyVarTy tv) + Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToType env) tv Just tv' -> return (mkTyVarTy tv') -zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type -zonkTcTypeToType env ty - = go ty - where - go (TyConApp tc tys) = do tys' <- mapM go tys - return (mkTyConApp tc tys') - -- Establish Type invariants - -- See Note [Zonking inside the knot] in TcHsType - - go (LitTy n) = return (LitTy n) - - go (FunTy arg res) = do arg' <- go arg - res' <- go res - return (FunTy arg' res') - - go (AppTy fun arg) = do fun' <- go fun - arg' <- go arg - return (mkAppTy fun' arg') - -- NB the mkAppTy; we might have instantiated a - -- type variable to a type constructor, so we need - -- to pull the TyConApp to the top. - - -- The two interesting cases! - go (TyVarTy tv) = zonkTyVarOcc env tv +zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion +zonkCoVarOcc env@(ZonkEnv _ tyco_env _) cv + | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env + = return $ mkCoVarCo cv' + | otherwise + = mkCoVarCo <$> updateVarTypeM (zonkTcTypeToType env) cv + +zonkCoHole :: ZonkEnv -> CoercionHole + -> Role -> Type -> Type -- these are all redundant with + -- the details in the hole, + -- unzonked + -> TcM Coercion +zonkCoHole env h r t1 t2 + = do { contents <- unpackCoercionHole_maybe h + ; case contents of + Just co -> do { co <- zonkCoToCo env co + ; checkCoercionHole co h r t1 t2 } + + -- This next case should happen only in the presence of + -- (undeferred) type errors. Originally, I put in a panic + -- here, but that caused too many uses of `failIfErrsM`. + Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr h) + ; when debugIsOn $ + whenNoErrs $ + MASSERT2( False + , text "Type-correct unfilled coercion hole" + <+> ppr h ) + ; t1 <- zonkTcTypeToType env t1 + ; t2 <- zonkTcTypeToType env t2 + ; return $ mkHoleCo h r t1 t2 } } + +zonk_tycomapper :: TyCoMapper ZonkEnv TcM +zonk_tycomapper = TyCoMapper + { tcm_smart = True -- Establish type invariants + -- See Note [Type-checking inside the knot] in TcHsType + , tcm_tyvar = zonkTyVarOcc + , tcm_covar = zonkCoVarOcc + , tcm_hole = zonkCoHole + , tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv } - go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) - do { (env', tv') <- zonkTyBndrX env tv - ; ty' <- zonkTcTypeToType env' ty - ; return (ForAllTy tv' ty') } +zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type +zonkTcTypeToType = mapType zonk_tycomapper zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -zonkCoToCo env co - = go co - where - go (Refl r ty) = mkReflCo r <$> zonkTcTypeToType env ty - go (TyConAppCo r tc args) = mkTyConAppCo r tc <$> mapM go args - go (AppCo co arg) = mkAppCo <$> go co <*> go arg - go (AxiomInstCo ax ind args) = AxiomInstCo ax ind <$> mapM go args - go (UnivCo s r ty1 ty2) = mkUnivCo s r <$> zonkTcTypeToType env ty1 - <*> zonkTcTypeToType env ty2 - go (SymCo co) = mkSymCo <$> go co - go (TransCo co1 co2) = mkTransCo <$> go co1 <*> go co2 - go (NthCo n co) = mkNthCo n <$> go co - go (LRCo lr co) = mkLRCo lr <$> go co - go (InstCo co arg) = mkInstCo <$> go co <*> zonkTcTypeToType env arg - go (SubCo co) = mkSubCo <$> go co - go (AxiomRuleCo ax ts cs) = AxiomRuleCo ax <$> mapM (zonkTcTypeToType env) ts - <*> mapM go cs - - -- The two interesting cases! - go (CoVarCo cv) = return (mkCoVarCo $ zonkIdOcc env cv) - go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) - do { (env', tv') <- zonkTyBndrX env tv - ; co' <- zonkCoToCo env' co - ; return (mkForAllCo tv' co') } - -zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker +zonkCoToCo = mapCoercion zonk_tycomapper + +zonkTvCollecting :: TyVarSet -> TcRef TyVarSet -> UnboundTyVarZonker -- This variant collects unbound type variables in a mutable variable -- Works on both types and kinds -zonkTvCollecting unbound_tv_set tv +zonkTvCollecting kind_vars unbound_tv_set tv = do { poly_kinds <- xoptM Opt_PolyKinds - ; if isKindVar tv && not poly_kinds then defaultKindVarToStar tv - else do - { tv' <- zonkQuantifiedTyVar tv - ; tv_set <- readMutVar unbound_tv_set - ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') - ; return (mkTyVarTy tv') } } + ; if tv `elemVarSet` kind_vars && not poly_kinds then defaultKindVar tv else do + { ty_or_tv <- zonkQuantifiedTyVarOrType tv + ; case ty_or_tv of + Right ty -> return ty + Left tv' -> do + { tv_set <- readMutVar unbound_tv_set + ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') + ; return (mkTyVarTy tv') } } } zonkTypeZapping :: UnboundTyVarZonker -- This variant is used for everything except the LHS of rules -- It zaps unbound type variables to (), or some other arbitrary type -- Works on both types and kinds zonkTypeZapping tv - = do { let ty = if isKindVar tv - -- ty is actually a kind, zonk to AnyK - then anyKind - else anyTypeOfKind (defaultKind (tyVarKind tv)) + = do { let ty | isLevityVar tv = liftedDataConTy + | otherwise = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } - - -zonkTcCoToCo :: ZonkEnv -> TcCoercion -> TcM TcCoercion --- NB: zonking often reveals that the coercion is an identity --- in which case the Refl-ness can propagate up to the top --- which in turn gives more efficient desugaring. So it's --- worth using the 'mk' smart constructors on the RHS -zonkTcCoToCo env co - = go co - where - go (TcLetCo bs co) = do { (env', bs') <- zonkTcEvBinds env bs - ; co' <- zonkTcCoToCo env' co - ; return (TcLetCo bs' co') } - go (TcCoVarCo cv) = return (mkTcCoVarCo (zonkEvVarOcc env cv)) - go (TcRefl r ty) = do { ty' <- zonkTcTypeToType env ty - ; return (TcRefl r ty') } - go (TcTyConAppCo r tc cos) - = do { cos' <- mapM go cos; return (mkTcTyConAppCo r tc cos') } - go (TcAxiomInstCo ax ind cos) - = do { cos' <- mapM go cos; return (TcAxiomInstCo ax ind cos') } - go (TcAppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 - ; return (mkTcAppCo co1' co2') } - go (TcCastCo co1 co2) = do { co1' <- go co1; co2' <- go co2 - ; return (TcCastCo co1' co2') } - go (TcPhantomCo ty1 ty2) = do { ty1' <- zonkTcTypeToType env ty1 - ; ty2' <- zonkTcTypeToType env ty2 - ; return (TcPhantomCo ty1' ty2') } - go (TcSymCo co) = do { co' <- go co; return (mkTcSymCo co') } - go (TcNthCo n co) = do { co' <- go co; return (mkTcNthCo n co') } - go (TcLRCo lr co) = do { co' <- go co; return (mkTcLRCo lr co') } - go (TcTransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 - ; return (mkTcTransCo co1' co2') } - go (TcForAllCo tv co) = ASSERT( isImmutableTyVar tv ) - do { co' <- go co; return (mkTcForAllCo tv co') } - go (TcSubCo co) = do { co' <- go co; return (mkTcSubCo co') } - go (TcAxiomRuleCo co ts cs) = do { ts' <- zonkTcTypeToTypes env ts - ; cs' <- mapM go cs - ; return (TcAxiomRuleCo co ts' cs') - } - go (TcCoercion co) = do { co' <- zonkCoToCo env co - ; return (TcCoercion co') } diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 2b671463cd..9fd74d1fa6 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -5,55 +5,55 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} module TcHsType ( -- Type signatures kcHsSigType, tcClassSigType, tcHsSigType, tcHsSigWcType, - zonkSigType, zonkAndCheckValidity, funsSigCtxt, addSigCtxt, tcHsClsInstType, tcHsDeriv, tcHsVectInst, UserTypeCtxt(..), - tcImplicitTKBndrs, tcHsTyVarBndrs, + tcImplicitTKBndrs, tcImplicitTKBndrsType, tcHsTyVarBndrs, - -- Type checking type and class decls + -- Type checking type and class decls kcLookupKind, kcTyClTyVars, tcTyClTyVars, tcHsConArgType, tcDataKindSig, -- Kind-checking types -- No kind generalisation, no checkValidType tcWildCardBinders, - kcHsTyVarBndrs, tcHsQTyVars, + kcHsTyVarBndrs, tcHsLiftedType, tcHsOpenType, tcHsLiftedTypeNC, tcHsOpenTypeNC, tcLHsType, tcCheckLHsType, - tcHsContext, tcLHsPredType, tcInferApps, tcHsArgTys, + tcHsContext, tcLHsPredType, tcInferApps, tcInferArgs, + solveEqualities, -- useful re-export - kindGeneralize, checkKind, + kindGeneralize, -- Sort-checking kinds tcLHsKind, -- Pattern type signatures - tcHsPatSigType, tcPatSig + tcHsPatSigType, tcPatSig, funAppCtxt ) where #include "HsVersions.h" import HsSyn import TcRnMonad -import TcEvidence( HsWrapper ) +import TcEvidence import TcEnv import TcMType import TcValidity import TcUnify import TcIface +import TcSimplify ( solveEqualities ) import TcType import Type -import TypeRep( Type(..) ) -- For the mkNakedXXX stuff import Kind import RdrName( lookupLocalRdrOcc ) import Var @@ -61,72 +61,51 @@ import VarSet import TyCon import ConLike import DataCon -import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) +import TysPrim ( tYPE ) import Class import Name import NameEnv +import NameSet +import VarEnv import TysWiredIn import BasicTypes import SrcLoc -import DynFlags ( ExtensionFlag( Opt_DataKinds ), getDynFlags ) +import DynFlags ( ExtensionFlag( Opt_DataKinds, Opt_MonoLocalBinds + , Opt_TypeInType ) ) import Constants ( mAX_CTUPLE_SIZE ) import ErrUtils( MsgDoc ) import Unique +import Util import UniqSupply import Outputable import FastString -import Util +import PrelNames hiding ( wildCardName ) +import Pair -import Data.Maybe( isNothing ) -import Control.Monad ( unless, when, zipWithM, void ) -import PrelNames( funTyConKey, allNameStrings ) +import Data.Maybe +import Control.Monad {- ---------------------------- General notes ---------------------------- -Generally speaking we now type-check types in three phases - - 1. kcHsType: kind check the HsType - *includes* performing any TH type splices; - so it returns a translated, and kind-annotated, type - - 2. dsHsType: convert from HsType to Type: - perform zonking - expand type synonyms [mkGenTyApps] - hoist the foralls [tcHsType] - - 3. checkValidType: check the validity of the resulting type - -Often these steps are done one after the other (tcHsSigType). -But in mutually recursive groups of type and class decls we do - 1 kind-check the whole group - 2 build TyCons/Classes in a knot-tied way - 3 check the validity of types in the now-unknotted TyCons/Classes - -For example, when we find - (forall a m. m a -> m a) -we bind a,m to kind varibles and kind-check (m a -> m a). This makes -a get kind *, and m get kind *->*. Now we typecheck (m a -> m a) in -an environment that binds a and m suitably. +Unlike with expressions, type-checking types both does some checking and +desugars at the same time. This is necessary because we often want to perform +equality checks on the types right away, and it would be incredibly painful +to do this on un-desugared types. Luckily, desugared types are close enough +to HsTypes to make the error messages sane. -The kind checker passed to tcHsTyVars needs to look at enough to -establish the kind of the tyvar: - * For a group of type and class decls, it's just the group, not - the rest of the program - * For a tyvar bound in a pattern type signature, its the types - mentioned in the other type signatures in that bunch of patterns - * For a tyvar bound in a RULE, it's the type signatures on other - universally quantified variables in the rule - -Note that this may occasionally give surprising results. For example: - - data T a b = MkT (a b) - -Here we deduce a::*->*, b::* -But equally valid would be a::(*->*)-> *, b::*->* +During type-checking, we perform as little validity checking as possible. +This is because some type-checking is done in a mutually-recursive knot, and +if we look too closely at the tycons, we'll loop. This is why we always must +use mkNakedTyConApp and mkNakedAppTys, etc., which never look at a tycon. +The mkNamed... functions don't uphold Type invariants, but zonkTcTypeToType +will repair this for us. Note that zonkTcType *is* safe within a knot, and +can be done repeatedly with no ill effect: it just squeezes out metavariables. +Generally, after type-checking, you will want to do validity checking, say +with TcValidity.checkValidType. Validity checking ~~~~~~~~~~~~~~~~~ @@ -157,9 +136,8 @@ During step (1) we might fault in a TyCon defined in another module, and it migh knot around type declarations with ARecThing, so that the fault-in code can get the TyCon being defined. - -************************************************************************ -* * +%************************************************************************ +%* * Check types AND do validity checking * * ************************************************************************ @@ -185,48 +163,46 @@ tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) kcHsSigType :: [Located Name] -> LHsSigType Name -> TcM () kcHsSigType names (HsIB { hsib_body = hs_ty - , hsib_kvs = sig_kvs - , hsib_tvs = sig_tvs }) + , hsib_vars = sig_vars }) = addSigCtxt (funsSigCtxt names) hs_ty $ - do { tcImplicitTKBndrs sig_kvs sig_tvs $ \ _ _ -> - void $ tc_check_lhs_type hs_ty liftedTypeKind } + discardResult $ + tcImplicitTKBndrsType sig_vars $ + tc_lhs_type typeLevelMode hs_ty liftedTypeKind tcClassSigType :: [Located Name] -> LHsSigType Name -> TcM Type -- Does not do validity checking; this must be done outside -- the recursive class declaration "knot" tcClassSigType names sig_ty = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ - tc_hs_sig_type sig_ty liftedTypeKind + do { ty <- tc_hs_sig_type sig_ty liftedTypeKind + ; kindGeneralizeType ty } tcHsSigType :: UserTypeCtxt -> LHsSigType Name -> TcM Type -- Does validity checking tcHsSigType ctxt sig_ty = addSigCtxt ctxt (hsSigType sig_ty) $ do { kind <- case expectedKindInCtxt ctxt of - Nothing -> newMetaKindVar - Just k -> return k + AnythingKind -> newMetaKindVar + TheKind k -> return k + OpenKind -> do { lev <- newFlexiTyVarTy levityTy + ; return $ tYPE lev } -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] ; ty <- tc_hs_sig_type sig_ty kind + -- Generalise here: see Note [Kind generalisation] + ; ty <- maybeKindGeneralizeType ty -- also zonks ; checkValidType ctxt ty ; return ty } tc_hs_sig_type :: LHsSigType Name -> Kind -> TcM Type --- Does not do validity checking +-- Does not do validity checking or zonking tc_hs_sig_type (HsIB { hsib_body = hs_ty - , hsib_kvs = sig_kvs - , hsib_tvs = sig_tvs }) kind - = do { ty <- tcImplicitTKBndrs sig_kvs sig_tvs $ \ kvs tvs -> - do { ty <- tc_check_lhs_type hs_ty kind - ; return (mkForAllTys kvs $ mkForAllTys tvs ty) } - - -- Generalise here: see Note [Kind generalisation] - ; ty <- kindGeneralizeType ty - - -- Zonk to expose kind information to checkValidType - ; zonkSigType ty } - + , hsib_vars = sig_vars }) kind + = do { (tkvs, ty) <- solveEqualities $ + tcImplicitTKBndrsType sig_vars $ + tc_lhs_type typeLevelMode hs_ty kind + ; return (mkInvForAllTys tkvs ty) } ----------------- tcHsDeriv :: LHsSigType Name -> TcM ([TyVar], Class, [Type], Kind) @@ -239,8 +215,13 @@ tcHsDeriv :: LHsSigType Name -> TcM ([TyVar], Class, [Type], Kind) -- if arg has a suitable kind tcHsDeriv hs_ty = do { arg_kind <- newMetaKindVar - ; ty <- tc_hs_sig_type hs_ty (mkArrowKind arg_kind constraintKind) - ; arg_kind <- zonkSigType arg_kind + -- always safe to kind-generalize, because there + -- can be no covars in an outer scope + ; ty <- checkNoErrs $ + -- avoid redundant error report with "illegal deriving", below + tc_hs_sig_type hs_ty (mkFunTy arg_kind constraintKind) + ; ty <- kindGeneralizeType ty -- also zonks + ; arg_kind <- zonkTcType arg_kind ; let (tvs, pred) = splitForAllTys ty ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, arg_kind) @@ -252,30 +233,37 @@ tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -- Like tcHsSigType, but for a class instance declaration -- The significant difference is that we expect a /constraint/ -- not a /type/ for the bit after the '=>'. -tcHsClsInstType user_ctxt hs_inst_ty@(HsIB { hsib_kvs = sig_kvs, hsib_tvs = sig_tvs +tcHsClsInstType user_ctxt hs_inst_ty@(HsIB { hsib_vars = sig_vars , hsib_body = hs_qual_ty }) - | (cxt, head_ty) <- splitLHsQualTy hs_qual_ty -- An explicit forall in an instance declaration isn't -- allowed, so there won't be any HsForAllTy here = setSrcSpan (getLoc hs_qual_ty) $ - do { inst_ty <- tcImplicitTKBndrs sig_kvs sig_tvs $ \ kvs tvs -> + do { (tkvs, phi_ty) <- solveEqualities $ + tcImplicitTKBndrsType sig_vars $ do { theta <- tcHsContext cxt - ; head_ty' <- tc_check_lhs_type head_ty constraintKind - ; return (mkForAllTys kvs $ mkForAllTys tvs $ - mkPhiTy theta head_ty') } + ; head_ty' <- tc_lhs_type typeLevelMode + head_ty constraintKind + ; return (mkPhiTy theta head_ty') } + ; let inst_ty = mkInvForAllTys tkvs phi_ty ; inst_ty <- kindGeneralizeType inst_ty - ; inst_ty <- zonkSigType inst_ty + ; inst_ty <- zonkTcType inst_ty ; checkValidInstance user_ctxt hs_inst_ty inst_ty } + where + (cxt, head_ty) = splitLHsQualTy hs_qual_ty -- Used for 'VECTORISE [SCALAR] instance' declarations -- tcHsVectInst :: LHsSigType Name -> TcM (Class, [Type]) tcHsVectInst ty - | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe (hsSigType ty) + | Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe (hsSigType ty) -- Ignoring the binders looks pretty dodgy to me = do { (cls, cls_kind) <- tcClass cls_name - ; (arg_tys, _res_kind) <- tcInferApps cls_name cls_kind tys - ; return (cls, arg_tys) } + ; (applied_class, _res_kind) + <- tcInferApps typeLevelMode cls_name (mkClassPred cls []) cls_kind tys + ; case tcSplitTyConApp_maybe applied_class of + Just (_tc, args) -> ASSERT( _tc == classTyCon cls ) + return (cls, args) + _ -> failWithTc (text "Too many arguments passed to" <+> ppr cls_name) } | otherwise = failWithTc $ ptext (sLit "Malformed instance type") @@ -288,8 +276,8 @@ tcHsVectInst ty ************************************************************************ * * The main kind checker: no validity checks here -* * -************************************************************************ +%* * +%************************************************************************ First a couple of simple wrappers for kcHsType -} @@ -306,19 +294,6 @@ tcHsConArgType DataType bty = tcHsOpenType (getBangType bty) -- And newtypes can't be bang'd --------------------------- -tcHsArgTys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] -tcHsArgTys what tys kinds - = sequence [ addTypeCtxt ty $ - tc_lhs_type ty (expArgKind what kind n) - | (ty,kind,n) <- zip3 tys kinds [1..] ] - -tc_hs_arg_tys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] --- Just like tcHsArgTys but without the addTypeCtxt -tc_hs_arg_tys what tys kinds - = sequence [ tc_lhs_type ty (expArgKind what kind n) - | (ty,kind,n) <- zip3 tys kinds [1..] ] - ---------------------------- tcHsOpenType, tcHsLiftedType, tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType Name -> TcM TcType -- Used for type signatures @@ -326,153 +301,249 @@ tcHsOpenType, tcHsLiftedType, tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty -tcHsOpenTypeNC ty = tc_lhs_type ty ekOpen -tcHsLiftedTypeNC ty = tc_lhs_type ty ekLifted +tcHsOpenTypeNC ty = do { ek <- ekOpen + ; tc_lhs_type typeLevelMode ty ek } +tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind -- Like tcHsType, but takes an expected kind tcCheckLHsType :: LHsType Name -> Kind -> TcM Type tcCheckLHsType hs_ty exp_kind = addTypeCtxt hs_ty $ - tc_check_lhs_type hs_ty exp_kind - -tc_check_lhs_type :: LHsType Name -> Kind -> TcM Type -tc_check_lhs_type hs_ty exp_kind - = tc_lhs_type hs_ty (EK exp_kind expectedKindMsg) + tc_lhs_type typeLevelMode hs_ty exp_kind tcLHsType :: LHsType Name -> TcM (TcType, TcKind) -- Called from outside: set the context -tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty) +tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty) --------------------------- +-- | Should we generalise the kind of this type? +-- We *should* generalise if the type is mentions no scoped type variables +-- or if NoMonoLocalBinds is set. Otherwise, nope. +decideKindGeneralisationPlan :: Type -> TcM Bool +decideKindGeneralisationPlan ty + = do { mono_locals <- xoptM Opt_MonoLocalBinds + ; in_scope <- getInLocalScope + ; let fvs = tyCoVarsOfTypeList ty + should_gen = not mono_locals || all (not . in_scope . getName) fvs + ; traceTc "decideKindGeneralisationPlan" + (vcat [ text "type:" <+> ppr ty + , text "ftvs:" <+> ppr fvs + , text "should gen?" <+> ppr should_gen ]) + ; return should_gen } + +maybeKindGeneralizeType :: TcType -> TcM Type +maybeKindGeneralizeType ty + = do { should_gen <- decideKindGeneralisationPlan ty + ; if should_gen + then kindGeneralizeType ty + else zonkTcType ty } + {- -Like tcExpr, tc_hs_type takes an expected kind which it unifies with -the kind it figures out. When we don't know what kind to expect, we use -tc_lhs_type_fresh, to first create a new meta kind variable and use that as -the expected kind. +************************************************************************ +* * + Type-checking modes +* * +************************************************************************ + +The kind-checker is parameterised by a TcTyMode, which contains some +information about where we're checking a type. + +The renamer issues errors about what it can. All errors issued here must +concern things that the renamer can't handle. + -} -tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind) -tc_infer_lhs_type ty = - do { kv <- newMetaKindVar - ; r <- tc_lhs_type ty (EK kv expectedKindMsg) - ; return (r, kv) } +data TcTyMode + = TcTyMode { mode_level :: TypeOrKind -- True <=> type, False <=> kind + -- used only for -XNoTypeInType errors + } + +typeLevelMode :: TcTyMode +typeLevelMode = TcTyMode { mode_level = TypeLevel } + +kindLevelMode :: TcTyMode +kindLevelMode = TcTyMode { mode_level = KindLevel } + +-- switch to kind level +kindLevel :: TcTyMode -> TcTyMode +kindLevel mode = mode { mode_level = KindLevel } + +{- +Note [Bidirectional type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In expressions, whenever we see a polymorphic identifier, say `id`, we are +free to instantiate it with metavariables, knowing that we can always +re-generalize with type-lambdas when necessary. For example: + + rank2 :: (forall a. a -> a) -> () + x = rank2 id + +When checking the body of `x`, we can instantiate `id` with a metavariable. +Then, when we're checking the application of `rank2`, we notice that we really +need a polymorphic `id`, and then re-generalize over the unconstrained +metavariable. + +In types, however, we're not so lucky, because *we cannot re-generalize*! +There is no lambda. So, we must be careful only to instantiate at the last +possible moment, when we're sure we're never going to want the lost polymorphism +again. This is done in calls to tcInstBinders and tcInstBindersX. + +To implement this behavior, we use bidirectional type checking, where we +explicitly think about whether we know the kind of the type we're checking +or not. Note that there is a difference between not knowing a kind and +knowing a metavariable kind: the metavariables are TauTvs, and cannot become +forall-quantified kinds. Previously (before dependent types), there were +no higher-rank kinds, and so we could instantiate early and be sure that +no types would have polymorphic kinds, and so we could always assume that +the kind of a type was a fresh metavariable. Not so anymore, thus the +need for two algorithms. + +For HsType forms that can never be kind-polymorphic, we implement only the +"down" direction, where we safely assume a metavariable kind. For HsType forms +that *can* be kind-polymorphic, we implement just the "up" (functions with +"infer" in their name) version, as we gain nothing by also implementing the +"down" version. + +Note [Future-proofing the type checker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As discussed in Note [Bidirectional type checking], each HsType form is +handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions +are mutually recursive, so that either one can work for any type former. +But, we want to make sure that our pattern-matches are complete. So, +we have a bunch of repetitive code just so that we get warnings if we're +missing any patterns. +-} -tc_lhs_type :: LHsType Name -> ExpKind -> TcM TcType -tc_lhs_type (L span ty) exp_kind +-- | Check and desugar a type, returning the core type and its +-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression +-- level. +tc_infer_lhs_type :: TcTyMode -> LHsType Name -> TcM (TcType, TcKind) +tc_infer_lhs_type mode (L span ty) + = setSrcSpan span $ + do { traceTc "tc_infer_lhs_type:" (ppr ty) + ; tc_infer_hs_type mode ty } + +-- | Infer the kind of a type and desugar. This is the "up" type-checker, +-- as described in Note [Bidirectional type checking] +tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind) +tc_infer_hs_type mode (HsTyVar (L _ tv)) = tcTyVar mode tv +tc_infer_hs_type mode (HsAppTy ty1 ty2) + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] + ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty + ; fun_kind' <- zonkTcType fun_kind + ; tcInferApps mode fun_ty fun_ty' fun_kind' arg_tys } +tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t +tc_infer_hs_type mode (HsOpTy lhs (L _ op) rhs) + | not (op `hasKey` funTyConKey) + = do { (op', op_kind) <- tcTyVar mode op + ; op_kind' <- zonkTcType op_kind + ; tcInferApps mode op op' op_kind' [lhs, rhs] } +tc_infer_hs_type mode (HsKindSig ty sig) + = do { sig' <- tc_lhs_kind (kindLevel mode) sig + ; ty' <- tc_lhs_type mode ty sig' + ; return (ty', sig') } +tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty +tc_infer_hs_type _ (HsCoreTy ty) = return (ty, typeKind ty) +tc_infer_hs_type mode other_ty + = do { kv <- newMetaKindVar + ; ty' <- tc_hs_type mode other_ty kv + ; return (ty', kv) } + +tc_lhs_type :: TcTyMode -> LHsType Name -> TcKind -> TcM TcType +tc_lhs_type mode (L span ty) exp_kind = setSrcSpan span $ do { traceTc "tc_lhs_type:" (ppr ty $$ ppr exp_kind) - ; tc_hs_type ty exp_kind } - -tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType] -tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds + ; tc_hs_type mode ty exp_kind } ------------------------------------------ -tc_fun_type :: HsType Name -> LHsType Name -> LHsType Name -> ExpKind -> TcM TcType --- We need to recognise (->) so that we can construct a FunTy, --- *and* we need to do by looking at the Name, not the TyCon --- (see Note [Zonking inside the knot]). For example, --- consider f :: (->) Int Int (Trac #7312) -tc_fun_type ty ty1 ty2 exp_kind@(EK _ ctxt) - = do { ty1' <- tc_lhs_type ty1 (EK openTypeKind ctxt) - ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt) - ; checkExpectedKind ty liftedTypeKind exp_kind - ; return (mkFunTy ty1' ty2') } +tc_fun_type :: TcTyMode -> LHsType Name -> LHsType Name -> TcKind -> TcM TcType +tc_fun_type mode ty1 ty2 exp_kind + = do { arg_lev <- newFlexiTyVarTy levityTy + ; res_lev <- newFlexiTyVarTy levityTy + ; ty1' <- tc_lhs_type mode ty1 (tYPE arg_lev) + ; ty2' <- tc_lhs_type mode ty2 (tYPE res_lev) + ; checkExpectedKind (mkNakedFunTy ty1' ty2') liftedTypeKind exp_kind } ------------------------------------------ -tc_hs_type :: HsType Name -> ExpKind -> TcM TcType -tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind -tc_hs_type (HsDocTy ty _) exp_kind = tc_lhs_type ty exp_kind -tc_hs_type ty@(HsBangTy {}) _ +-- See also Note [Bidirectional type checking] +tc_hs_type :: TcTyMode -> HsType Name -> TcKind -> TcM TcType +tc_hs_type mode (HsParTy ty) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type _ ty@(HsBangTy {}) _ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210) = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) -tc_hs_type ty@(HsRecTy _) _ +tc_hs_type _ ty@(HsRecTy _) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty) ----------- Functions and applications -tc_hs_type hs_ty@(HsTyVar (L _ name)) exp_kind - = do { (ty, k) <- tcTyVar name - ; checkExpectedKind hs_ty k exp_kind - ; return ty } +-- This should never happen; type splices are expanded by the renamer +tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind + = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) -tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind - = tc_fun_type ty ty1 ty2 exp_kind +---------- Functions and applications +tc_hs_type mode (HsFunTy ty1 ty2) exp_kind + = tc_fun_type mode ty1 ty2 exp_kind -tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind +tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind | op `hasKey` funTyConKey - = tc_fun_type hs_ty ty1 ty2 exp_kind - | otherwise - = do { (op', op_kind) <- tcTyVar op - ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind - ; return (mkNakedAppTys op' tys') } - -- mkNakedAppTys: see Note [Zonking inside the knot] - -tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind --- | L _ (HsTyVar fun) <- fun_ty --- , fun `hasKey` funTyConKey --- , [fty1,fty2] <- arg_tys --- = tc_fun_type hs_ty fty1 fty2 exp_kind --- | otherwise - = do { (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty - ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind - ; return (mkNakedAppTys fun_ty' arg_tys') } - -- mkNakedAppTys: see Note [Zonking inside the knot] - -- This looks fragile; how do we *know* that fun_ty isn't - -- a TyConApp, say (which is never supposed to appear in the - -- function position of an AppTy)? - where - (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] + = tc_fun_type mode ty1 ty2 exp_kind --------- Foralls -tc_hs_type hs_ty@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind@(EK exp_k _) - | isConstraintKind exp_k +tc_hs_type mode hs_ty@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind + -- Do not kind-generalise here. See Note [Kind generalisation] + | isConstraintKind exp_kind = failWithTc (hang (ptext (sLit "Illegal constraint:")) 2 (ppr hs_ty)) | otherwise - = tcHsTyVarBndrs hs_tvs $ \ tvs' -> + = fmap fst $ + tcHsTyVarBndrs hs_tvs $ \ tvs' -> -- Do not kind-generalise here! See Note [Kind generalisation] - do { ty' <- tc_lhs_type ty exp_kind - ; return (mkForAllTys tvs' ty') } + -- Why exp_kind? See Note [Body kind of forall] + do { ty' <- tc_lhs_type mode ty exp_kind + ; let bound_vars = allBoundVariables ty' + ; return (mkNakedInvSigmaTy tvs' [] ty', bound_vars) } -tc_hs_type hs_ty@(HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind - = do { ctxt' <- tcHsContext ctxt +tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind + = do { ctxt' <- tc_hs_context mode ctxt ; ty' <- if null (unLoc ctxt) then -- Plain forall, no context - tc_lhs_type ty exp_kind -- Why exp_kind? See Note [Body kind of forall] + tc_lhs_type mode ty exp_kind + -- Why exp_kind? See Note [Body kind of forall] else -- If there is a context, then this forall is really a -- _function_, so the kind of the result really is * -- The body kind (result of the function) can be * or #, hence ekOpen - do { checkExpectedKind hs_ty liftedTypeKind exp_kind - ; tc_lhs_type ty ekOpen } - ; return (mkPhiTy ctxt' ty') } - ---------- Lists, arraysp, and tuples -tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind - = do { tau_ty <- tc_lhs_type elt_ty ekLifted - ; checkExpectedKind hs_ty liftedTypeKind exp_kind + do { ek <- ekOpen + ; ty <- tc_lhs_type mode ty ek + ; checkExpectedKind ty liftedTypeKind exp_kind } + + ; return (mkNakedPhiTy ctxt' ty') } + +--------- Lists, arrays, and tuples +tc_hs_type mode (HsListTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; checkWiredInTyCon listTyCon - ; return (mkListTy tau_ty) } + ; checkExpectedKind (mkListTy tau_ty) liftedTypeKind exp_kind } -tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind - = do { tau_ty <- tc_lhs_type elt_ty ekLifted - ; checkExpectedKind hs_ty liftedTypeKind exp_kind +tc_hs_type mode (HsPArrTy elt_ty) exp_kind + = do { MASSERT( isTypeLevel (mode_level mode) ) + ; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; checkWiredInTyCon parrTyCon - ; return (mkPArrTy tau_ty) } + ; checkExpectedKind (mkPArrTy tau_ty) liftedTypeKind exp_kind } -- See Note [Distinguishing tuple kinds] in HsTypes -- See Note [Inferring tuple kinds] -tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k _ctxt) +tc_hs_type mode (HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind -- (NB: not zonking before looking at exp_k, to avoid left-right bias) - | Just tup_sort <- tupKindSort_maybe exp_k + | Just tup_sort <- tupKindSort_maybe exp_kind = traceTc "tc_hs_type tuple" (ppr hs_tys) >> - tc_tuple hs_ty tup_sort hs_tys exp_kind + tc_tuple mode tup_sort hs_tys exp_kind | otherwise = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) - ; (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys - ; kinds <- mapM zonkTcKind kinds + ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys + ; kinds <- mapM zonkTcType kinds -- Infer each arg type separately, because errors can be -- confusing if we give them a shared kind. Eg Trac #7410 -- (Either Int, Int), we do not want to get an error saying @@ -485,16 +556,15 @@ tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k [] -> (liftedTypeKind, BoxedTuple) -- In the [] case, it's not clear what the kind is, so guess * - ; sequence_ [ setSrcSpan loc $ - checkExpectedKind ty kind - (expArgKind (ptext (sLit "a tuple")) arg_kind n) - | (L loc ty, kind, n) <- zip3 hs_tys kinds [1..] ] + ; tys' <- sequence [ setSrcSpan loc $ + checkExpectedKind ty kind arg_kind + | ((L loc _),ty,kind) <- zip3 hs_tys tys kinds ] - ; finish_tuple hs_ty tup_sort tys exp_kind } + ; finish_tuple tup_sort tys' (map (const arg_kind) tys') exp_kind } -tc_hs_type hs_ty@(HsTupleTy hs_tup_sort tys) exp_kind - = tc_tuple hs_ty tup_sort tys exp_kind +tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind + = tc_tuple mode tup_sort tys exp_kind where tup_sort = case hs_tup_sort of -- Fourth case dealt with above HsUnboxedTuple -> UnboxedTuple @@ -504,106 +574,107 @@ tc_hs_type hs_ty@(HsTupleTy hs_tup_sort tys) exp_kind --------- Promoted lists and tuples -tc_hs_type hs_ty@(HsExplicitListTy _k hs_tys) exp_kind - = do { (taus, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys - ; kind <- unifyKinds (ptext (sLit "In a promoted list")) hs_tys kinds - ; checkExpectedKind hs_ty (mkPromotedListTy kind) exp_kind - ; return (foldr (mk_cons kind) (mk_nil kind) taus) } +tc_hs_type mode (HsExplicitListTy _k tys) exp_kind + = do { tks <- mapM (tc_infer_lhs_type mode) tys + ; (taus', kind) <- unifyKinds tks + ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') + ; checkExpectedKind ty (mkListTy kind) exp_kind } where mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] -tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind - = do { tks <- mapM tc_infer_lhs_type tys +tc_hs_type mode (HsExplicitTupleTy _ tys) exp_kind + = do { tks <- mapM (tc_infer_lhs_type mode) tys ; let n = length tys - kind_con = promotedTupleTyCon Boxed n + kind_con = tupleTyCon Boxed n ty_con = promotedTupleDataCon Boxed n (taus, ks) = unzip tks tup_k = mkTyConApp kind_con ks - ; checkExpectedKind hs_ty tup_k exp_kind - ; return (mkTyConApp ty_con (ks ++ taus)) } + ; checkExpectedKind (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } --------- Constraint types -tc_hs_type ipTy@(HsIParamTy n ty) exp_kind - = do { ty' <- tc_lhs_type ty ekLifted - ; checkExpectedKind ipTy constraintKind exp_kind +tc_hs_type mode (HsIParamTy n ty) exp_kind + = do { MASSERT( isTypeLevel (mode_level mode) ) + ; ty' <- tc_lhs_type mode ty liftedTypeKind ; let n' = mkStrLitTy $ hsIPNameFS n - ; return (mkClassPred ipClass [n',ty']) - } - -tc_hs_type ty@(HsEqTy ty1 ty2) exp_kind - = do { (ty1', kind1) <- tc_infer_lhs_type ty1 - ; (ty2', kind2) <- tc_infer_lhs_type ty2 - ; checkExpectedKind (unLoc ty2) kind2 - (EK kind1 msg_fn) - ; checkExpectedKind ty constraintKind exp_kind - ; return (mkNakedTyConApp eqTyCon [kind1, ty1', ty2']) } - where - msg_fn pkind = ptext (sLit "The left argument of the equality had kind") - <+> quotes (pprKind pkind) - ---------- Misc -tc_hs_type (HsKindSig ty sig_k) exp_kind - = do { sig_k' <- tcLHsKind sig_k - ; checkExpectedKind (unLoc ty) sig_k' exp_kind - ; tc_lhs_type ty (EK sig_k' msg_fn) } - where - msg_fn pkind = ptext (sLit "The signature specified kind") - <+> quotes (pprKind pkind) - -tc_hs_type hs_ty@(HsCoreTy ty) exp_kind - = do { checkExpectedKind hs_ty (typeKind ty) exp_kind - ; return ty } - - --- This should never happen; type splices are expanded by the renamer -tc_hs_type ty@(HsSpliceTy {}) _exp_kind - = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) - -tc_hs_type (HsWrapTy {}) _exp_kind - = panic "tc_hs_type HsWrapTy" -- We kind checked something twice - -tc_hs_type hs_ty@(HsTyLit (HsNumTy _ n)) exp_kind - = do { checkExpectedKind hs_ty typeNatKind exp_kind - ; checkWiredInTyCon typeNatKindCon - ; return (mkNumLitTy n) } - -tc_hs_type hs_ty@(HsTyLit (HsStrTy _ s)) exp_kind - = do { checkExpectedKind hs_ty typeSymbolKind exp_kind - ; checkWiredInTyCon typeSymbolKindCon - ; return (mkStrLitTy s) } - -tc_hs_type hs_ty@(HsWildCardTy wc) exp_kind + ; checkExpectedKind (mkClassPred ipClass [n',ty']) + constraintKind exp_kind } + +tc_hs_type mode (HsEqTy ty1 ty2) exp_kind + = do { (ty1', kind1) <- tc_infer_lhs_type mode ty1 + ; (ty2', kind2) <- tc_infer_lhs_type mode ty2 + ; ty2'' <- checkExpectedKind ty2' kind2 kind1 + ; eq_tc <- tcLookupTyCon eqTyConName + ; let ty' = mkNakedTyConApp eq_tc [kind1, ty1', ty2''] + ; checkExpectedKind ty' constraintKind exp_kind } + +--------- Literals +tc_hs_type _ (HsTyLit (HsNumTy _ n)) exp_kind + = do { checkWiredInTyCon typeNatKindCon + ; checkExpectedKind (mkNumLitTy n) typeNatKind exp_kind } + +tc_hs_type _ (HsTyLit (HsStrTy _ s)) exp_kind + = do { checkWiredInTyCon typeSymbolKindCon + ; checkExpectedKind (mkStrLitTy s) typeSymbolKind exp_kind } + +--------- Potentially kind-polymorphic types: call the "up" checker +-- See Note [Future-proofing the type checker] +tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsCoreTy {}) ek = tc_infer_hs_type_ek mode ty ek + +tc_hs_type _ (HsWildCardTy wc) exp_kind = do { let name = wildCardName wc ; tv <- tcLookupTyVar name - ; checkExpectedKind hs_ty (tyVarKind tv) exp_kind - ; return (mkTyVarTy tv) } + ; checkExpectedKind (mkTyVarTy tv) (tyVarKind tv) exp_kind } + +-- disposed of by renamer +tc_hs_type _ ty@(HsAppsTy {}) _ + = pprPanic "tc_hs_tyep HsAppsTy" (ppr ty) + +--------------------------- +-- | Call 'tc_infer_hs_type' and check its result against an expected kind. +tc_infer_hs_type_ek :: TcTyMode -> HsType Name -> TcKind -> TcM TcType +tc_infer_hs_type_ek mode ty ek + = do { (ty', k) <- tc_infer_hs_type mode ty + ; checkExpectedKind ty' k ek } --------------------------- tupKindSort_maybe :: TcKind -> Maybe TupleSort tupKindSort_maybe k + | Just (k', _) <- tcSplitCastTy_maybe k = tupKindSort_maybe k' + | Just k' <- coreView k = tupKindSort_maybe k' | isConstraintKind k = Just ConstraintTuple | isLiftedTypeKind k = Just BoxedTuple | otherwise = Nothing -tc_tuple :: HsType Name -> TupleSort -> [LHsType Name] -> ExpKind -> TcM TcType -tc_tuple hs_ty tup_sort tys exp_kind - = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind) - ; finish_tuple hs_ty tup_sort tau_tys exp_kind } +tc_tuple :: TcTyMode -> TupleSort -> [LHsType Name] -> TcKind -> TcM TcType +tc_tuple mode tup_sort tys exp_kind + = do { arg_kinds <- case tup_sort of + BoxedTuple -> return (nOfThem arity liftedTypeKind) + UnboxedTuple -> do { levs <- newFlexiTyVarTys arity levityTy + ; return $ map tYPE levs } + ConstraintTuple -> return (nOfThem arity constraintKind) + ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds + ; finish_tuple tup_sort tau_tys arg_kinds exp_kind } where - arg_kind = case tup_sort of - BoxedTuple -> liftedTypeKind - UnboxedTuple -> openTypeKind - ConstraintTuple -> constraintKind - cxt_doc = case tup_sort of - BoxedTuple -> ptext (sLit "a tuple") - UnboxedTuple -> ptext (sLit "an unboxed tuple") - ConstraintTuple -> ptext (sLit "a constraint tuple") - -finish_tuple :: HsType Name -> TupleSort -> [TcType] -> ExpKind -> TcM TcType -finish_tuple hs_ty tup_sort tau_tys exp_kind - = do { traceTc "finish_tuple" (ppr res_kind $$ ppr exp_kind $$ ppr exp_kind) - ; checkExpectedKind hs_ty res_kind exp_kind + arity = length tys + +finish_tuple :: TupleSort + -> [TcType] -- ^ argument types + -> [TcKind] -- ^ of these kinds + -> TcKind -- ^ expected kind of the whole tuple + -> TcM TcType +finish_tuple tup_sort tau_tys tau_kinds exp_kind + = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind) + ; let arg_tys = case tup_sort of + -- See also Note [Unboxed tuple levity vars] in TyCon + UnboxedTuple -> map (getLevityFromKind "finish_tuple") tau_kinds + ++ tau_tys + BoxedTuple -> tau_tys + ConstraintTuple -> tau_tys ; tycon <- case tup_sort of ConstraintTuple | arity > mAX_CTUPLE_SIZE @@ -613,7 +684,7 @@ finish_tuple hs_ty tup_sort tau_tys exp_kind ; checkWiredInTyCon tc ; return tc } UnboxedTuple -> return (tupleTyCon Unboxed arity) - ; return (mkTyConApp tycon tau_tys) } + ; checkExpectedKind (mkTyConApp tycon arg_tys) res_kind exp_kind } where arity = length tau_tys res_kind = case tup_sort of @@ -628,81 +699,324 @@ bigConstraintTuple arity 2 (ptext (sLit "Instead, use a nested tuple")) --------------------------- -tcInferApps :: Outputable a - => a - -> TcKind -- Function kind - -> [LHsType Name] -- Arg types - -> TcM ([TcType], TcKind) -- Kind-checked args -tcInferApps the_fun fun_kind args - = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) fun_kind args - ; args' <- tc_lhs_types args_w_kinds - ; return (args', res_kind) } - -tcCheckApps :: Outputable a - => HsType Name -- The type being checked (for err messages only) - -> a -- The function - -> TcKind -> [LHsType Name] -- Fun kind and arg types - -> ExpKind -- Expected kind - -> TcM [TcType] -tcCheckApps hs_ty the_fun fun_kind args exp_kind - = do { (arg_tys, res_kind) <- tcInferApps the_fun fun_kind args - ; checkExpectedKind hs_ty res_kind exp_kind - ; return arg_tys } +-- | Apply a type of a given kind to a list of arguments. This instantiates +-- invisible parameters as necessary. However, it does *not* necessarily +-- apply all the arguments, if the kind runs out of binders. +-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds. +-- These kinds should be used to instantiate invisible kind variables; +-- they come from an enclosing class for an associated type/data family. +-- This version will instantiate all invisible arguments left over after +-- the visible ones. +tcInferArgs :: Outputable fun + => fun -- ^ the function + -> TcKind -- ^ function kind (zonked) + -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) + -> [LHsType Name] -- ^ args + -> TcM (TcKind, [TcType], [LHsType Name], Int) + -- ^ (result kind, typechecked args, untypechecked args, n) +tcInferArgs fun fun_kind mb_kind_info args + = do { (res_kind, args', leftovers, n) + <- tc_infer_args typeLevelMode fun fun_kind mb_kind_info args 1 + -- now, we need to instantiate any remaining invisible arguments + ; let (invis_bndrs, really_res_kind) = splitPiTysInvisible res_kind + ; (subst, invis_args) + <- tcInstBindersX emptyTCvSubst mb_kind_info invis_bndrs + ; return ( substTy subst really_res_kind, args' `chkAppend` invis_args + , leftovers, n ) } + +-- | See comments for 'tcInferArgs'. But this version does not instantiate +-- any remaining invisible arguments. +tc_infer_args :: Outputable fun + => TcTyMode + -> fun -- ^ the function + -> TcKind -- ^ function kind (zonked) + -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) + -> [LHsType Name] -- ^ args + -> Int -- ^ number to start arg counter at + -> TcM (TcKind, [TcType], [LHsType Name], Int) +tc_infer_args mode orig_ty ki mb_kind_info orig_args n0 + = do { traceTc "tcInferApps" (ppr ki $$ ppr orig_args) + ; go emptyTCvSubst ki orig_args n0 [] } + where + go subst fun_kind [] n acc + = return ( substTy subst fun_kind, reverse acc, [], n ) + -- when we call this when checking type family patterns, we really + -- do want to instantiate all invisible arguments. During other + -- typechecking, we don't. + + go subst fun_kind all_args n acc + | Just fun_kind' <- coreView fun_kind + = go subst fun_kind' all_args n acc + + | Just tv <- getTyVar_maybe fun_kind + , Just fun_kind' <- lookupTyVar subst tv + = go subst fun_kind' all_args n acc + + | (inv_bndrs, res_k) <- splitPiTysInvisible fun_kind + , not (null inv_bndrs) + = do { (subst', args') <- tcInstBindersX subst mb_kind_info inv_bndrs + ; go subst' res_k all_args n (reverse args' ++ acc) } + + | Just (bndr, res_k) <- splitPiTy_maybe fun_kind + , arg:args <- all_args -- this actually has to succeed + = ASSERT( isVisibleBinder bndr ) + do { let mode' | isNamedBinder bndr = kindLevel mode + | otherwise = mode + ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $ + tc_lhs_type mode' arg (substTy subst $ binderType bndr) + ; let subst' = case binderVar_maybe bndr of + Just tv -> extendTCvSubst subst tv arg' + Nothing -> subst + ; go subst' res_k args (n+1) (arg' : acc) } ---------------------------- -splitFunKind :: SDoc -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) -splitFunKind the_fun fun_kind args - = go 1 fun_kind args + | otherwise + = return (substTy subst fun_kind, reverse acc, all_args, n) + +-- | Applies a type to a list of arguments. Always consumes all the +-- arguments. +tcInferApps :: Outputable fun + => TcTyMode + -> fun -- ^ Function (for printing only) + -> TcType -- ^ Function (could be knot-tied) + -> TcKind -- ^ Function kind (zonked) + -> [LHsType Name] -- ^ Args + -> TcM (TcType, TcKind) -- ^ (f args, result kind) +tcInferApps mode orig_ty ty ki args = go ty ki args 1 where - go _ fk [] = return ([], fk) - go arg_no fk (arg:args) - = do { mb_fk <- matchExpectedFunKind fk - ; case mb_fk of - Nothing -> failWithTc too_many_args - Just (ak,fk') -> do { (aks, rk) <- go (arg_no+1) fk' args - ; let exp_kind = expArgKind (quotes the_fun) ak arg_no - ; return ((arg, exp_kind) : aks, rk) } } + go fun fun_kind [] _ = return (fun, fun_kind) + go fun fun_kind args n + | Just fun_kind' <- coreView fun_kind + = go fun fun_kind' args n + + | isPiTy fun_kind + = do { (res_kind, args', leftover_args, n') + <- tc_infer_args mode orig_ty fun_kind Nothing args n + ; go (mkNakedAppTys fun args') res_kind leftover_args n' } + + go fun fun_kind all_args@(arg:args) n + = do { (co, arg_k, res_k) <- matchExpectedFunKind (length all_args) + fun fun_kind + ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $ + tc_lhs_type mode arg arg_k + ; go (mkNakedAppTy (fun `mkNakedCastTy` co) arg') + res_k args (n+1) } + +--------------------------- +-- | This is used to instantiate binders when type-checking *types* only. +-- Precondition: all binders are invisible. See also Note [Bidirectional type checking] +tcInstBinders :: [TyBinder] -> TcM (TCvSubst, [TcType]) +tcInstBinders = tcInstBindersX emptyTCvSubst Nothing + +-- | This is used to instantiate binders when type-checking *types* only. +-- Precondition: all binders are invisible. +-- The @VarEnv Kind@ gives some known instantiations. +-- See also Note [Bidirectional type checking] +tcInstBindersX :: TCvSubst -> Maybe (VarEnv Kind) + -> [TyBinder] -> TcM (TCvSubst, [TcType]) +tcInstBindersX subst mb_kind_info bndrs + = do { (subst, args) <- mapAccumLM (tcInstBinderX mb_kind_info) subst bndrs + ; traceTc "instantiating implicit dependent vars:" + (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg) + bndrs args) + ; return (subst, args) } + +-- | Used only in *types* +tcInstBinderX :: Maybe (VarEnv Kind) + -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) +tcInstBinderX mb_kind_info subst binder + | Just tv <- binderVar_maybe binder + = case lookup_tv tv of + Just ki -> return (extendTCvSubst subst tv ki, ki) + Nothing -> do { (subst', tv') <- tcInstTyVarX subst tv + ; return (subst', mkTyVarTy tv') } + + -- This is the *only* constraint currently handled in types. + | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty + = do { let origin = TypeEqOrigin { uo_actual = k1 + , uo_expected = k2 + , uo_thing = Nothing } + ; co <- case role of + Nominal -> unifyKind noThing k1 k2 + Representational -> emitWantedEq origin KindLevel role k1 k2 + Phantom -> pprPanic "tcInstBinderX Phantom" (ppr binder) + ; arg' <- mk co k1 k2 + ; return (subst, arg') } - too_many_args = quotes the_fun <+> - ptext (sLit "is applied to too many type arguments") + | otherwise + = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty + ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty) + + -- just invent a new variable so that we can continue + ; u <- newUnique + ; let name = mkSysTvName u (fsLit "dict") + ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) } + where + substed_ty = substTy subst (binderType binder) + + lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad + ; lookupVarEnv env tv } + + -- handle boxed equality constraints, because it's so easy + get_pred_tys_maybe ty + | Just (r, k1, k2) <- getEqPredTys_maybe ty + = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2) + | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty + = if | tc `hasKey` heqTyConKey + -> Just (mkHEqBoxTy, Nominal, k1, k2) + | otherwise + -> Nothing + | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty + = if | tc `hasKey` eqTyConKey + -> Just (mkEqBoxTy, Nominal, k1, k2) + | tc `hasKey` coercibleTyConKey + -> Just (mkCoercibleBoxTy, Representational, k1, k2) + | otherwise + -> Nothing + | otherwise + = Nothing + +------------------------------- +-- | This takes @a ~# b@ and returns @a ~~ b@. +mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +-- monadic just for convenience with mkEqBoxTy +mkHEqBoxTy co ty1 ty2 + = return $ + mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] + where k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | This takes @a ~# b@ and returns @a ~ b@. +mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type +mkEqBoxTy co ty1 ty2 + = do { eq_tc <- tcLookupTyCon eqTyConName + ; let [datacon] = tyConDataCons eq_tc + ; hetero <- mkHEqBoxTy co ty1 ty2 + ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] } + where k = typeKind ty1 + +-- | This takes @a ~R# b@ and returns @Coercible a b@. +mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type +-- monadic just for convenience with mkEqBoxTy +mkCoercibleBoxTy co ty1 ty2 + = do { return $ + mkTyConApp (promoteDataCon coercibleDataCon) + [k, ty1, ty2, mkCoercionTy co] } + where k = typeKind ty1 + + +-------------------------- +checkExpectedKind :: TcType -- the type whose kind we're checking + -> TcKind -- the known kind of that type, k + -> TcKind -- the expected kind, exp_kind + -> TcM TcType -- a possibly-inst'ed, casted type :: exp_kind +-- Instantiate a kind (if necessary) and then call unifyType +-- (checkExpectedKind ty act_kind exp_kind) +-- checks that the actual kind act_kind is compatible +-- with the expected kind exp_kind +checkExpectedKind ty act_kind exp_kind + = do { (ty', act_kind') <- instantiate ty act_kind exp_kind + ; let origin = TypeEqOrigin { uo_actual = act_kind' + , uo_expected = exp_kind + , uo_thing = Just $ mkTypeErrorThing ty' + } + ; co_k <- uType origin KindLevel act_kind' exp_kind + ; traceTc "checkExpectedKind" (vcat [ ppr act_kind + , ppr exp_kind + , ppr co_k ]) + ; let result_ty = ty' `mkNakedCastTy` co_k + ; return result_ty } + where + -- we need to make sure that both kinds have the same number of implicit + -- foralls out front. If the actual kind has more, instantiate accordingly. + -- Otherwise, just pass the type & kind through -- the errors are caught + -- in unifyType. + instantiate :: TcType -- the type + -> TcKind -- of this kind + -> TcKind -- but expected to be of this one + -> TcM ( TcType -- the inst'ed type + , TcKind ) -- its new kind + instantiate ty act_ki exp_ki + = let (exp_bndrs, _) = splitPiTysInvisible exp_ki in + instantiateTyN (length exp_bndrs) ty act_ki + +-- | Instantiate a type to have at most @n@ invisible arguments. +instantiateTyN :: Int -- ^ @n@ + -> TcType -- ^ the type + -> TcKind -- ^ its kind + -> TcM (TcType, TcKind) -- ^ The inst'ed type with kind +instantiateTyN n ty ki + = let (bndrs, inner_ki) = splitPiTysInvisible ki + num_to_inst = length bndrs - n + -- NB: splitAt is forgiving with invalid numbers + (inst_bndrs, leftover_bndrs) = splitAt num_to_inst bndrs + in + if num_to_inst <= 0 then return (ty, ki) else + do { (subst, inst_args) <- tcInstBinders inst_bndrs + ; let rebuilt_ki = mkForAllTys leftover_bndrs inner_ki + ki' = substTy subst rebuilt_ki + ; return (mkNakedAppTys ty inst_args, ki') } --------------------------- tcHsContext :: LHsContext Name -> TcM [PredType] -tcHsContext ctxt = mapM tcLHsPredType (unLoc ctxt) +tcHsContext = tc_hs_context typeLevelMode tcLHsPredType :: LHsType Name -> TcM PredType -tcLHsPredType pred = tc_lhs_type pred ekConstraint +tcLHsPredType = tc_lhs_pred typeLevelMode + +tc_hs_context :: TcTyMode -> LHsContext Name -> TcM [PredType] +tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) + +tc_lhs_pred :: TcTyMode -> LHsType Name -> TcM PredType +tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind --------------------------- -tcTyVar :: Name -> TcM (TcType, TcKind) +tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) -- See Note [Type checking recursive type and class declarations] -- in TcTyClsDecls -tcTyVar name -- Could be a tyvar, a tycon, or a datacon +tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon = do { traceTc "lk1" (ppr name) ; thing <- tcLookup name ; case thing of - ATyVar _ tv - | isKindVar tv - -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr tv) - <+> ptext (sLit "used as a type")) - | otherwise - -> return (mkTyVarTy tv, tyVarKind tv) - - AThing kind -> do { tc <- get_loopy_tc name - ; inst_tycon (mkNakedTyConApp tc) kind } - -- mkNakedTyConApp: see Note [Zonking inside the knot] + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + AThing kind -> do { data_kinds <- xoptM Opt_DataKinds + ; unless (isTypeLevel (mode_level mode) || + data_kinds) $ + promotionErr name NoDataKinds + ; tc <- get_loopy_tc name + ; return (mkNakedTyConApp tc [], kind) } + -- mkNakedTyConApp: see Note [Type-checking inside the knot] + -- NB: we really should check if we're at the kind level + -- and if the tycon is promotable if -XNoTypeInType is set. + -- But this is a terribly large amount of work! Not worth it. - AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc) + AGlobal (ATyCon tc) + -> do { type_in_type <- xoptM Opt_TypeInType + ; data_kinds <- xoptM Opt_DataKinds + ; unless (isTypeLevel (mode_level mode) || + data_kinds || + isKindTyCon tc) $ + promotionErr name NoDataKinds + ; unless (isTypeLevel (mode_level mode) || + type_in_type || + isLegacyPromotableTyCon tc) $ + promotionErr name NoTypeInTypeTC + ; return (mkTyConApp tc [], tyConKind tc) } AGlobal (AConLike (RealDataCon dc)) - | Promoted tc <- promoteDataCon_maybe dc -> do { data_kinds <- xoptM Opt_DataKinds - ; unless data_kinds $ promotionErr name NoDataKinds - ; inst_tycon (mkTyConApp tc) (tyConKind tc) } - | otherwise -> failWithTc (ptext (sLit "Data constructor") <+> quotes (ppr dc) - <+> ptext (sLit "comes from an un-promotable type") - <+> quotes (ppr (dataConTyCon dc))) + ; unless (data_kinds || specialPromotedDc dc) $ + promotionErr name NoDataKinds + ; type_in_type <- xoptM Opt_TypeInType + ; unless ( type_in_type || + ( isTypeLevel (mode_level mode) && + isLegacyPromotableDataCon dc ) || + ( isKindLevel (mode_level mode) && + specialPromotedDc dc ) ) $ + promotionErr name NoTypeInTypeDC + ; let tc = promoteDataCon dc + ; return (mkNakedTyConApp tc [], tyConKind tc) } APromotionErr err -> promotionErr name err @@ -714,19 +1028,6 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon Just (ATyCon tc) -> return tc _ -> return (aThingErr "tcTyVar" name) } - inst_tycon :: ([Type] -> Type) -> Kind -> TcM (Type, Kind) - -- Instantiate the polymorphic kind - -- Lazy in the TyCon - inst_tycon mk_tc_app kind - | null kvs - = return (mk_tc_app [], ki_body) - | otherwise - = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind) - ; ks <- mapM (const newMetaKindVar) kvs - ; return (mk_tc_app ks, substKiWith kvs ks ki_body) } - where - (kvs, ki_body) = splitForAllTys kind - tcClass :: Name -> TcM (Class, TcKind) tcClass cls -- Must be a class = do { thing <- tcLookup cls @@ -745,7 +1046,7 @@ aThingErr :: String -> Name -> b aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x) {- -Note [Zonking inside the knot] +Note [Type-checking inside the knot] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are checking the argument types of a data constructor. We must zonk the types before making the DataCon, because once built we @@ -757,81 +1058,22 @@ So we must be careful not to use "smart constructors" for types that look at the TyCon or Class involved. * Hence the use of mkNakedXXX functions. These do *not* enforce - the invariants (for example that we use (FunTy s t) rather + the invariants (for example that we use (ForAllTy (Anon s) t) rather than (TyConApp (->) [s,t])). - * Ditto in zonkTcType (which may be applied more than once, eg to - squeeze out kind meta-variables), we are careful not to look at - the TyCon. - - * We arrange to call zonkSigType *once* right at the end, and it - does establish the invariants. But in exchange we can't look - at the result (not even its structure) until we have emerged - from the "knot". + * The zonking functions establish invariants (even zonkTcType, a change from + previous behaviour). So we must never inspect the result of a + zonk that might mention a knot-tied TyCon. This is generally OK + because we zonk *kinds* while kind-checking types. And the TyCons + in kinds shouldn't be knot-tied, because they come from a previous + mutually recursive group. * TcHsSyn.zonkTcTypeToType also can safely check/establish invariants. This is horribly delicate. I hate it. A good example of how delicate it is can be seen in Trac #7903. --} - -mkNakedTyConApp :: TyCon -> [Type] -> Type --- Builds a TyConApp --- * without being strict in TyCon, --- * without satisfying the invariants of TyConApp --- A subsequent zonking will establish the invariants -mkNakedTyConApp tc tys = TyConApp tc tys - -mkNakedAppTys :: Type -> [Type] -> Type -mkNakedAppTys ty1 [] = ty1 -mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) -mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 - -zonkAndCheckValidity :: UserTypeCtxt -> TcType -> TcM TcType --- Zonk a user-written type signature, and check it for validity -zonkAndCheckValidity ctxt ty - = do { ty <- zonkSigType ty - ; checkValidType ctxt ty - ; return ty } - -zonkSigType :: TcType -> TcM TcType --- Zonk the result of type-checking a user-written type signature --- It may have kind variables in it, but no meta type variables --- Because of knot-typing (see Note [Zonking inside the knot]) --- it may need to establish the Type invariants; --- hence the use of mkTyConApp and mkAppTy -zonkSigType ty - = go ty - where - go (TyConApp tc tys) = do tys' <- mapM go tys - return (mkTyConApp tc tys') - -- Key point: establish Type invariants! - -- See Note [Zonking inside the knot] - - go (LitTy n) = return (LitTy n) - - go (FunTy arg res) = do arg' <- go arg - res' <- go res - return (FunTy arg' res') - - go (AppTy fun arg) = do fun' <- go fun - arg' <- go arg - return (mkAppTy fun' arg') - -- NB the mkAppTy; we might have instantiated a - -- type variable to a type constructor, so we need - -- to pull the TyConApp to the top. - - -- The two interesting cases! - go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar - | otherwise = TyVarTy <$> updateTyVarKindM go tyvar - -- Ordinary (non Tc) tyvars occur inside quantified types - - go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv - ; ty' <- go ty - ; return (ForAllTy tv' ty') } -{- Note [Body kind of a forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The body of a forall is usually a type, but in principle @@ -867,17 +1109,23 @@ Then the dfun has type T :: * -> * MkT :: forall k. (Typeable ((k->*) -> k -> *) (Apply k)) -> T a - f :: (forall (k:BOX). forall (t:: k->*) (a:k). t a -> t a) -> Int + f :: (forall (k:*). forall (t:: k->*) (a:k). t a -> t a) -> Int f :: (forall a. a -> Typeable Apply) -> Int So we *must* keep the HsForAll on the instance type HsForAll Implicit [] [] (Typeable Apply) so that we do kind generalisation on it. -Really we should check that it's a type of value kind -{*, Constraint, #}, but I'm not doing that yet -Example that should be rejected: - f :: (forall (a:*->*). a) Int +It's tempting to check that the body kind is either * or #. But this is +wrong. For example: + + class C a b + newtype N = Mk Foo deriving (C a) + +We're doing newtype-deriving for C. But notice how `a` isn't in scope in +the predicate `C a`. So we quantify, yielding `forall a. C a` even though +`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but +convenient. Bottom line: don't check for * or # here. Note [Inferring tuple kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -907,7 +1155,7 @@ The type desugarer is phase 2 of dealing with HsTypes. Specifically: * It zonks any kinds. The returned type should have no mutable kind or type variables (hence returning Type not TcType): - - any unconstrained kind variables are defaulted to AnyK just + - any unconstrained kind variables are defaulted to (Any *) just as in TcHsSyn. - there are no mutable type variables because we are kind-checking a type @@ -918,7 +1166,7 @@ You might worry about nested scopes: ..a:kappa in scope.. let f :: forall b. T '[a,b] -> Int In this case, f's type could have a mutable kind variable kappa in it; -and we might then default it to AnyK when dealing with f's type +and we might then default it to (Any *) when dealing with f's type signature. But we don't expect this to happen because we can't get a lexically scoped type variable with a mutable kind variable in it. A delicate point, this. If it becomes an issue we might need to @@ -943,7 +1191,7 @@ as if $(..blah..) :: forall k. k. In the e1 example, the context of the splice fixes kappa to *. But in the e2 example, we'll desugar the type, zonking the kind unification variables as we go. When we encounter the unconstrained kappa, we -want to default it to '*', not to AnyK. +want to default it to '*', not to (Any *). Help functions for type applications @@ -962,14 +1210,33 @@ addTypeCtxt (L _ ty) thing ************************************************************************ * * Type-variable binders -* * -************************************************************************ +%* * +%************************************************************************ + +Note [Scope-check inferred kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data SameKind :: k -> k -> * + foo :: forall a (b :: Proxy a) (c :: Proxy d). SameKind b c + +d has no binding site. So it gets bound implicitly, at the top. The +problem is that d's kind mentions `a`. So it's all ill-scoped. + +The way we check for this is to gather all variables *bound* in a +type variable's scope. The type variable's kind should not mention +any of these variables. That is, d's kind can't mention a, b, or c. +We can't just check to make sure that d's kind is in scope, because +we might be about to kindGeneralize. + +A little messy, but it works. + -} tcWildCardBinders :: [Name] -> ([(Name, TcTyVar)] -> TcM a) -> TcM a --- Use the Unqique form the specified Name; don't clone it. There is +-- Use the Unique form the specified Name; don't clone it. There is -- no need to clone, and not doing so avoids the need to return a list -- of pairs to bring into scope. tcWildCardBinders wcs thing_inside @@ -982,122 +1249,176 @@ tcWildCardBinders wcs thing_inside ; tv <- newFlexiTyVar kind ; return (name, tv) } -mkKindSigVar :: Name -> TcM KindVar --- Use the specified Name; don't clone it. There is no need to --- clone, and not doing so avoids the need to return a list of --- pairs to bring into scope. -mkKindSigVar n - = do { mb_thing <- tcLookupLcl_maybe n - ; case mb_thing of - Just (AThing k) - | Just kvar <- getTyVar_maybe k - -> return kvar - _ -> return $ mkTcTyVar n superKind (SkolemTv False) } - -kcScopedKindVars :: [Name] -> TcM a -> TcM a --- Given some tyvar binders like [a (b :: k -> *) (c :: k)] --- bind each scoped kind variable (k in this case) to a fresh --- kind skolem variable -kcScopedKindVars kv_ns thing_inside - = do { kvs <- mapM newSigKindVar kv_ns - -- NB: use mutable signature variables - ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) thing_inside } - -- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete, --- user-supplied kind signature (CUSK), generalise the result. Used in 'getInitialKind' --- and in kind-checking. See also Note [Complete user-supplied kind signatures] in +-- user-supplied kind signature (CUSK), generalise the result. +-- Used in 'getInitialKind' (for tycon kinds and other kinds) +-- and in kind-checking (but not for tycon kinds, which are checked with +-- tcTyClDecls). See also Note [Complete user-supplied kind signatures] in -- HsDecls. +-- +-- This function does not do telescope checking. kcHsTyVarBndrs :: Bool -- ^ True <=> the decl being checked has a CUSK -> LHsQTyVars Name - -> TcM (Kind, r) -- ^ the result kind, possibly with other info + -> ([TyVar] -> [TyVar] -> TcM (Kind, r)) + -- ^ the result kind, possibly with other info + -- ^ args are implicit vars, explicit vars -> TcM (Kind, r) -- ^ The full kind of the thing being declared, -- with the other info -kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside - = do { kvs <- if cusk - then mapM mkKindSigVar kv_ns - else mapM newSigKindVar kv_ns +kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns + , hsq_explicit = hs_tvs }) thing_inside + = do { meta_kvs <- mapM (const newMetaKindVar) kv_ns + ; kvs <- if cusk + then return $ zipWith new_skolem_tv kv_ns meta_kvs + -- the names must line up in splitTelescopeTvs + else zipWithM newSigTyVar kv_ns meta_kvs ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $ - do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs - ; (res_kind, stuff) <- tcExtendKindEnv nks thing_inside - ; let full_kind = mkArrowKinds (map snd nks) res_kind - kvs = filter (not . isMetaTyVar) $ - tyVarsOfTypeList full_kind + do { (full_kind, _, stuff) <- bind_telescope hs_tvs (thing_inside kvs) + ; let qkvs = filter (not . isMetaTyVar) $ + tyCoVarsOfTypeWellScoped full_kind + + -- the free non-meta variables in the returned kind will + -- contain both *mentioned* kind vars and *unmentioned* kind + -- vars (See case (1) under Note [Typechecking telescopes]) gen_kind = if cusk - then mkForAllTys kvs full_kind + then mkInvForAllTys qkvs $ full_kind else full_kind ; return (gen_kind, stuff) } } where - kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind) - kc_hs_tv (UserTyVar (L _ n)) - = do { mb_thing <- tcLookupLcl_maybe n - ; kind <- case mb_thing of - Just (AThing k) -> return k - _ | cusk -> return liftedTypeKind - | otherwise -> newMetaKindVar - ; return (n, kind) } - kc_hs_tv (KindedTyVar (L _ n) k) - = do { kind <- tcLHsKind k - -- In an associated type decl, the type variable may already - -- be in scope; in that case we want to make sure its kind - -- matches the one declared here - ; mb_thing <- tcLookupLcl_maybe n - ; case mb_thing of - Nothing -> return () - Just (AThing ks) -> checkKind kind ks - Just thing -> pprPanic "check_in_scope" (ppr thing) - ; return (n, kind) } - -tcImplicitTKBndrs :: [Name] -> [Name] -> ([TcTyVar] -> [TcTyVar] -> TcM a) -> TcM a + -- there may be dependency between the explicit "ty" vars. So, we have + -- to handle them one at a time. We also need to build up a full kind + -- here, because this is the place we know whether to use a FunTy or a + -- ForAllTy. We prefer using an anonymous binder over a trivial named + -- binder. If a user wants a trivial named one, use an explicit kind + -- signature. + bind_telescope :: [LHsTyVarBndr Name] + -> ([TyVar] -> TcM (Kind, r)) + -> TcM (Kind, VarSet, r) + bind_telescope [] thing + = do { (res_kind, stuff) <- thing [] + ; return (res_kind, tyCoVarsOfType res_kind, stuff) } + bind_telescope (L _ hs_tv : hs_tvs) thing + = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv + ; (res_kind, fvs, stuff) <- bind_unless_scoped tv_pair $ + bind_telescope hs_tvs $ \tvs -> + thing (tv:tvs) + -- we must be *lazy* in res_kind and fvs (assuming that the + -- caller of kcHsTyVarBndrs is, too), as sometimes these hold + -- panics. See kcConDecl. + ; k <- zonkTcType (tyVarKind tv) + ; let k_fvs = tyCoVarsOfType k + (bndr, fvs') + | tv `elemVarSet` fvs + = ( mkNamedBinder tv Visible + , fvs `delVarSet` tv `unionVarSet` k_fvs ) + | otherwise + = (mkAnonBinder k, fvs `unionVarSet` k_fvs) + + ; return ( mkForAllTy bndr res_kind, fvs', stuff ) } + + -- | Bind the tyvar in the env't unless the bool is True + bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a + bind_unless_scoped (_, True) thing_inside = thing_inside + bind_unless_scoped (tv, False) thing_inside + = tcExtendTyVarEnv [tv] thing_inside + + kc_hs_tv :: HsTyVarBndr Name -> TcM (TcTyVar, Bool) + kc_hs_tv hs_tvb + = do { (tv, scoped) <- tcHsTyVarBndr_Scoped hs_tvb + + -- in the CUSK case, we want to default any un-kinded tyvars + -- See Note [Complete user-supplied kind signatures] in HsDecls + ; case hs_tvb of + UserTyVar {} + | cusk + , not scoped -- don't default class tyvars + -> discardResult $ + unifyKind (Just (mkTyVarTy tv)) liftedTypeKind + (tyVarKind tv) + _ -> return () + + ; return (tv, scoped) } + +tcImplicitTKBndrs :: [Name] + -> TcM (a, TyVarSet) -- vars are bound somewhere in the scope + -- see Note [Scope-check inferred kinds] + -> TcM ([TcTyVar], a) +tcImplicitTKBndrs = tcImplicitTKBndrsX tcHsTyVarName + +-- | Convenient specialization +tcImplicitTKBndrsType :: [Name] + -> TcM Type + -> TcM ([TcTyVar], Type) +tcImplicitTKBndrsType var_ns thing_inside + = tcImplicitTKBndrs var_ns $ + do { res_ty <- thing_inside + ; return (res_ty, allBoundVariables res_ty) } + +-- this more general variant is needed in tcHsPatSigType. +-- See Note [Pattern signature binders] +tcImplicitTKBndrsX :: (Name -> TcM (TcTyVar, Bool)) -- new_tv function + -> [Name] + -> TcM (a, TyVarSet) + -> TcM ([TcTyVar], a) -- Returned TcTyVars have the supplied Names -- i.e. no cloning of fresh names -tcImplicitTKBndrs kv_ns tv_ns thing_inside - = do { kvs <- mapM mkKindSigVar kv_ns - ; tvs <- mapM tc_tv tv_ns - ; tcExtendTyVarEnv (kvs ++ tvs) (thing_inside kvs tvs) } - where - tc_tv name = do { kind <- newMetaKindVar - ; return (mkTcTyVar name kind (SkolemTv False)) } - -tcHsQTyVars :: LHsQTyVars Name - -> ([TcTyVar] -> TcM r) - -> TcM r --- Bind the kind variables to fresh skolem variables --- and type variables to skolems, each with a meta-kind variable kind -tcHsQTyVars (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside - = tcImplicitTKBndrs kv_ns [] $ \ kvs _ -> - do { tv_prs <- mapM tc_tv_bndr hs_tvs - ; tcExtendTyVarEnv [ tv | (tv, False) <- tv_prs ] $ - thing_inside (kvs ++ map fst tv_prs) } - where - -- If the variable is already in scope return it, instead of - -- introducing a new one. This can occur in - -- instance C (a,b) where - -- type F (a,b) c = ... - -- Here a,b will be in scope when processing the associated type instance for F. - -- See Note [Associated type tyvar names] in Class - tc_tv_bndr :: LHsTyVarBndr Name -> TcM (TcTyVar, Bool) - -- True <=> already in scope, do not extend envt - -- False <=> not already in scope - tc_tv_bndr (L _ hs_tv) - = do { let name = hsTyVarName hs_tv - ; mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of - Just (ATyVar _ tv) -> return (tv, True) - _ -> do { tv <- tcHsTyVarBndr hs_tv - ; return (tv, False) } } - -tcHsTyVarBndrs :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM a) -> TcM a +tcImplicitTKBndrsX new_tv var_ns thing_inside + = do { tkvs_pairs <- mapM new_tv var_ns + ; let must_scope_tkvs = [ tkv | (tkv, False) <- tkvs_pairs ] + tkvs = map fst tkvs_pairs + ; (result, bound_tvs) <- tcExtendTyVarEnv must_scope_tkvs $ + thing_inside + + -- it's possible that we guessed the ordering of variables + -- wrongly. Adjust. + ; tkvs <- mapM zonkTyCoVarKind tkvs + ; let extra = text "NB: Implicitly-bound variables always come" <+> + text "before other ones." + ; checkValidInferredKinds tkvs bound_tvs extra + + ; let final_tvs = toposortTyVars tkvs + ; traceTc "tcImplicitTKBndrs" (ppr var_ns $$ ppr final_tvs) + + ; return (final_tvs, result) } + +tcHsTyVarBndrs :: [LHsTyVarBndr Name] + -> ([TyVar] -> TcM (a, TyVarSet)) + -- ^ Thing inside returns the set of variables bound + -- in the scope. See Note [Scope-check inferred kinds] + -> TcM (a, TyVarSet) -- ^ returns augmented bound vars -- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs -tcHsTyVarBndrs hs_tvs thing_inside - = do { tvs <- mapM (tcHsTyVarBndr . unLoc) hs_tvs - ; tcExtendTyVarEnv tvs (thing_inside tvs) } +tcHsTyVarBndrs orig_hs_tvs thing_inside + = go orig_hs_tvs $ \ tvs -> + do { (result, bound_tvs) <- thing_inside tvs + + -- Issue an error if the ordering is bogus. + -- See Note [Bad telescopes] in TcValidity. + ; tvs <- checkZonkValidTelescope (interppSP orig_hs_tvs) tvs empty + ; checkValidInferredKinds tvs bound_tvs empty + + ; traceTc "tcHsTyVarBndrs" $ + vcat [ text "Hs vars:" <+> ppr orig_hs_tvs + , text "tvs:" <+> sep (map pprTvBndr tvs) ] + + ; return (result, bound_tvs `unionVarSet` mkVarSet tvs) + } + where + go [] thing = thing [] + go (L _ hs_tv : hs_tvs) thing + = do { tv <- tcHsTyVarBndr hs_tv + ; tcExtendTyVarEnv [tv] $ + go hs_tvs $ \ tvs -> + thing (tv : tvs) } tcHsTyVarBndr :: HsTyVarBndr Name -> TcM TcTyVar -- Return a type variable initialised with a kind variable. -- Typically the Kind inside the HsTyVarBndr will be a tyvar -- with a mutable kind in it. +-- NB: These variables must not be in scope. This function +-- is not appropriate for use with associated types, for example. -- -- Returned TcTyVar has the same name; no cloning +-- +-- See also Note [Associated type tyvar names] in Class tcHsTyVarBndr (UserTyVar (L _ name)) = do { kind <- newMetaKindVar ; return (mkTcTyVar name kind (SkolemTv False)) } @@ -1105,27 +1426,49 @@ tcHsTyVarBndr (KindedTyVar (L _ name) kind) = do { kind <- tcLHsKind kind ; return (mkTcTyVar name kind (SkolemTv False)) } +-- | Type-check a user-written TyVarBndr, which binds a variable +-- that might already be in scope (e.g., in an associated type declaration) +-- The second return value says whether the variable is in scope (True) +-- or not (False). +tcHsTyVarBndr_Scoped :: HsTyVarBndr Name -> TcM (TcTyVar, Bool) +tcHsTyVarBndr_Scoped (UserTyVar (L _ name)) + = tcHsTyVarName name +tcHsTyVarBndr_Scoped (KindedTyVar (L _ name) lhs_kind) + = do { tv_pair@(tv, _) <- tcHsTyVarName name + ; kind <- tcLHsKind lhs_kind + -- for a scoped variable: make sure annotation is consistent + -- for an unscoped variable: unify the meta-tyvar kind + -- either way: we can ignore the resulting coercion + ; discardResult $ unifyKind (Just (mkTyVarTy tv)) kind (tyVarKind tv) + ; return tv_pair } + +-- | Produce a tyvar of the given name (with a meta-tyvar kind). If +-- the name is already in scope, return the scoped variable. The +-- second return value says whether the variable is in scope (True) +-- or not (False). (Use this for associated types, for example.) +tcHsTyVarName :: Name -> TcM (TcTyVar, Bool) +tcHsTyVarName name + = do { mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of + Just (ATyVar _ tv) -> return (tv, True) + _ -> do { kind <- newMetaKindVar + ; return (mkTcTyVar name kind vanillaSkolemTv, False) }} + +-- makes a new skolem tv +new_skolem_tv :: Name -> Kind -> TcTyVar +new_skolem_tv n k = mkTcTyVar n k vanillaSkolemTv + ------------------ kindGeneralizeType :: Type -> TcM Type kindGeneralizeType ty - = do { kvs <- zonkTcTypeAndFV ty - ; kvs <- kindGeneralize kvs - ; return (mkForAllTys kvs ty) } - -kindGeneralize :: TyVarSet -> TcM [KindVar] -kindGeneralize tkvs - = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; quantifyTyVars gbl_tvs (filterVarSet isKindVar tkvs) } - -- ToDo: remove the (filter isKindVar) - -- Any type variables in tkvs will be in scope, - -- and hence in gbl_tvs, so after removing gbl_tvs - -- we should only have kind variables left - -- - -- BUT there is a smelly case (to be fixed when TH is reorganised) - -- f t = [| e :: $t |] - -- When typechecking the body of the bracket, we typecheck $t to a - -- unification variable 'alpha', with no biding forall. We don't - -- want to kind-quantify it! + = do { kvs <- kindGeneralize ty + ; zonkTcType (mkInvForAllTys kvs ty) } + +kindGeneralize :: TcType -> TcM [KindVar] +kindGeneralize ty + = do { gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked + ; kvs <- zonkTcTypeAndFV ty + ; quantifyTyVars gbl_tvs (Pair kvs emptyVarSet) } {- Note [Kind generalisation] @@ -1144,6 +1487,11 @@ we want to infer the most general type. The f2 type signature would be *less applicable* than f1, because it requires a more polymorphic argument. +NB: There are no explicit kind variables written in f's signature. +When there are, the renamer adds these kind variables to the list of +variables bound by the forall, so you can indeed have a type that's +higher-rank in its kind. But only by explicit request. + Note [Kinds of quantified type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tcTyVarBndrsGen quantifies over a specified list of type variables, @@ -1162,6 +1510,102 @@ which the type checker will then instantiate, and instantiate does not look through unification variables! Hence using zonked_kinds when forming tvs'. + +Note [Typechecking telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function tcTyClTyVars has to bind the scoped type and kind +variables in a telescope. For example: + +class Foo k (t :: Proxy k -> k2) where ... + +By the time [kt]cTyClTyVars is called, we know *something* about the kind of Foo, +at least that it has the form + + Foo :: forall (k2 :: mk2). forall (k :: mk1) -> (Proxy mk1 k -> k2) -> Constraint + +if it has a CUSK (Foo does not, in point of fact) or + + Foo :: forall (k :: mk1) -> (Proxy mk1 k -> k2) -> Constraint + +if it does not, where mk1 and mk2 are meta-kind variables (mk1, mk2 :: *). + +When calling tcTyClTyVars, this kind is further generalized w.r.t. any +free variables appearing in mk1 or mk2. So, mk_tvs must handle +that possibility. Perhaps we discover that mk1 := Maybe k3 and mk2 := *, +so we have + +Foo :: forall (k3 :: *). forall (k2 :: *). forall (k :: Maybe k3) -> + (Proxy (Maybe k3) k -> k2) -> Constraint + +We now have several sorts of variables to think about: +1) The variable k3 is not mentioned in the source at all. It is neither + explicitly bound nor ever used. It is *not* a scoped kind variable, + and should not be bound when type-checking the scope of the telescope. + +2) The variable k2 is mentioned in the source, but it is not explicitly + bound. It *is* a scoped kind variable, and will appear in the + hsq_implicit field of a LHsTyVarBndrs. + + 2a) In the non-CUSK case, these variables won't have been generalized + yet and don't appear in the looked-up kind. So we just return these + in a NameSet. + +3) The variable k is mentioned in the source with an explicit binding. + It *is* a scoped type variable, and will appear in the + hsq_explicit field of a LHsTyVarBndrs. + +4) The variable t is bound in the source, but it is never mentioned later + in the kind. It *is* a scoped variable (it can appear in the telescope + scope, even though it is non-dependent), and will appear in the + hsq_explicit field of a LHsTyVarBndrs. + +splitTelescopeTvs walks through the output of a splitPiTys on the +telescope head's kind (Foo, in our example), creating a list of tyvars +to be bound within the telescope scope. It must simultaneously walk +through the hsq_implicit and hsq_explicit fields of a LHsTyVarBndrs. +Comments in the code refer back to the cases in this Note. + +Cases (1) and (2) can be mixed together, but these cases must appear before +cases (3) and (4) (the implicitly bound vars always precede the explicitly +bound ones). So, we handle the lists in two stages (mk_tvs and +mk_tvs2). + +As a further wrinkle, it's possible that the variables in case (2) have +been reordered. This is because hsq_implicit is ordered by the renamer, +but there may be dependency among the variables. Of course, the order in +the kind must take dependency into account. So we use a NameSet to keep +these straightened out. + +Note [Free-floating kind vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T = MkT (forall (a :: k). Proxy a) + +This is not an existential datatype, but a higher-rank one. Note that +the forall to the right of MkT. Also consider + + data S a = MkS (Proxy (a :: k)) + +According to the rules around implicitly-bound kind variables, those +k's scope over the whole declarations. The renamer grabs it and adds it +to the hsq_implicits field of the HsQTyVars of the tycon. So it must +be in scope during type-checking, but we want to reject T while accepting +S. + +Why reject T? Because the kind variable isn't fixed by anything. For +a variable like k to be implicit, it needs to be mentioned in the kind +of a tycon tyvar. But it isn't. + +Why accept S? Because kind inference tells us that a has kind k, so it's +all OK. + +Here's the approach: in the first pass ("kind-checking") we just bring +k into scope. In the second pass, we certainly hope that k has been +integrated into the type's (generalized) kind, and so it should be found +by splitTelescopeTvs. If it's not, then we must have a definition like +T, and we reject. + -} -------------------- @@ -1178,76 +1622,168 @@ kcLookupKind nm AGlobal (ATyCon tc) -> return (tyConKind tc) _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } -kcTyClTyVars :: Name -> LHsQTyVars Name -> TcM a -> TcM a --- Used for the type variables of a type or class decl, --- when doing the initial kind-check. -kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside - = kcScopedKindVars kvs $ - do { tc_kind <- kcLookupKind name - ; let (_, mono_kind) = splitForAllTys tc_kind - -- if we have a FullKindSignature, the tc_kind may already - -- be generalized. The kvs get matched up while kind-checking - -- the types in kc_tv, below - (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) mono_kind - -- There should be enough arrows, because - -- getInitialKinds used the tcdTyVars - ; name_ks <- zipWithM kc_tv hs_tvs arg_ks - ; tcExtendKindEnv name_ks thing_inside } +-- See Note [Typechecking telescopes] +splitTelescopeTvs :: Kind -- of the head of the telescope + -> LHsQTyVars Name + -> ( [TyVar] -- scoped type variables + , NameSet -- ungeneralized implicit variables (case 2a) + , [TyVar] -- implicit type variables (cases 1 & 2) + , [TyVar] -- explicit type variables (cases 3 & 4) + , Kind ) -- result kind +splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs + , hsq_explicit = hs_tvs }) + = let (bndrs, inner_ki) = splitPiTys kind + (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, mk_kind) + = mk_tvs [] [] bndrs (mkNameSet hs_kvs) hs_tvs + in + (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, mk_kind inner_ki) where - -- getInitialKind has already gotten the kinds of these type - -- variables, but tiresomely we need to check them *again* - -- to match the kind variables they mention against the ones - -- we've freshly brought into scope - kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) - kc_tv (L _ (UserTyVar (L _ n))) exp_k - = return (n, exp_k) - kc_tv (L _ (KindedTyVar (L _ n) hs_k)) exp_k - = do { k <- tcLHsKind hs_k - ; checkKind k exp_k - ; return (n, exp_k) } + mk_tvs :: [TyVar] -- scoped tv accum (reversed) + -> [TyVar] -- implicit tv accum (reversed) + -> [TyBinder] + -> NameSet -- implicit variables + -> [LHsTyVarBndr Name] -- explicit variables + -> ( [TyVar] -- the tyvars to be lexically bound + , NameSet -- Case 2a names + , [TyVar] -- implicit tyvars + , [TyVar] -- explicit tyvars + , Type -> Type ) -- a function to create the result k + mk_tvs scoped_tv_acc imp_tv_acc (bndr : bndrs) all_hs_kvs all_hs_tvs + | Just tv <- binderVar_maybe bndr + , isInvisibleBinder bndr + , let tv_name = getName tv + , tv_name `elemNameSet` all_hs_kvs + = mk_tvs (tv : scoped_tv_acc) (tv : imp_tv_acc) + bndrs (all_hs_kvs `delFromNameSet` tv_name) all_hs_tvs -- Case (2) + + | Just tv <- binderVar_maybe bndr + , isInvisibleBinder bndr + = mk_tvs scoped_tv_acc (tv : imp_tv_acc) + bndrs all_hs_kvs all_hs_tvs -- Case (1) + + -- there may actually still be some hs_kvs, if we're kind checking + -- a non-CUSK. The kinds *aren't* generalized, so we won't see them + -- here. + mk_tvs scoped_tv_acc imp_tv_acc all_bndrs all_hs_kvs all_hs_tvs + = let (scoped, exp_tvs, mk_kind) + = mk_tvs2 scoped_tv_acc [] all_bndrs all_hs_tvs in + (scoped, all_hs_kvs, reverse imp_tv_acc, exp_tvs, mk_kind) + -- no more Case (1) or (2) + + -- This can't handle Case (1) or Case (2) from [Typechecking telescopes] + mk_tvs2 :: [TyVar] + -> [TyVar] -- new parameter: explicit tv accum (reversed) + -> [TyBinder] + -> [LHsTyVarBndr Name] + -> ( [TyVar] + , [TyVar] -- explicit tvs only + , Type -> Type ) + mk_tvs2 scoped_tv_acc exp_tv_acc (bndr : bndrs) (hs_tv : hs_tvs) + | Just tv <- binderVar_maybe bndr + = ASSERT2( isVisibleBinder bndr, err_doc ) + ASSERT( getName tv == hsLTyVarName hs_tv ) + mk_tvs2 (tv : scoped_tv_acc) (tv : exp_tv_acc) bndrs hs_tvs -- Case (3) + + | otherwise + = ASSERT( isVisibleBinder bndr ) + let tv = mkTyVar (hsLTyVarName hs_tv) (binderType bndr) in + mk_tvs2 (tv : scoped_tv_acc) (tv : exp_tv_acc) bndrs hs_tvs -- Case (4) + where + err_doc = vcat [ ppr (bndr : bndrs) + , ppr (hs_tv : hs_tvs) + , ppr kind + , ppr tvbs ] + + mk_tvs2 scoped_tv_acc exp_tv_acc all_bndrs [] -- All done! + = ( reverse scoped_tv_acc + , reverse exp_tv_acc + , mkForAllTys all_bndrs ) + + mk_tvs2 _ _ all_bndrs all_hs_tvs + = pprPanic "splitTelescopeTvs 2" (vcat [ ppr all_bndrs + , ppr all_hs_tvs ]) + ----------------------- +-- used on first pass only ("kind checking") +kcTyClTyVars :: Name -> LHsQTyVars Name + -> TcM a -> TcM a +kcTyClTyVars tycon hs_tvs thing_inside + = tc_tycl_tyvars False tycon hs_tvs $ \_ _ _ _ -> thing_inside + +-- used on second pass only ("type checking", really desugaring) tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl - -> ([TyVar] -> Kind -> TcM a) -> TcM a --- Used for the type variables of a type or class decl, --- on the second pass when constructing the final result + -> ([TyVar] -> [TyVar] -> Kind -> Kind -> TcM a) -> TcM a +tcTyClTyVars = tc_tycl_tyvars True + +tc_tycl_tyvars :: Bool -- are we doing the second pass? + -> Name -> LHsQTyVars Name -- LHS of the type or class decl + -> ([TyVar] -> [TyVar] -> Kind -> Kind -> TcM a) -> TcM a +-- Used for the type variables of a type or class decl +-- on both the first and second full passes in TcTyClDecls. +-- *Not* used in the initial-kind run. +-- -- (tcTyClTyVars T [a,b] thing_inside) -- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * -- calls thing_inside with arguments --- [k1,k2,a,b] (k2 -> *) +-- [k1,k2] [a,b] (forall (k1:*) (k2:*) (a:k1 -> *) (b:k1). k2 -> *) (k2 -> *) -- having also extended the type environment with bindings -- for k1,k2,a,b -- -- No need to freshen the k's because they are just skolem -- constants here, and we are at top level anyway. -tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside - = kcScopedKindVars hs_kvs $ -- Bind scoped kind vars to fresh kind univ vars - -- There may be fewer of these than the kvs of - -- the type constructor, of course - do { thing <- tcLookup tycon - ; let { kind = case thing of -- The kind of the tycon has been worked out - -- by the previous pass, and is fully zonked - AThing kind -> kind - _ -> panic "tcTyClTyVars" - -- We only call tcTyClTyVars during typechecking in - -- TcTyClDecls, where the local env is extended with - -- the generalized_env (mapping Names to AThings). - ; (kvs, body) = splitForAllTys kind - ; (kinds, res) = splitKindFunTysN (length hs_tvs) body } - ; tvs <- zipWithM tc_hs_tv hs_tvs kinds - ; tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs) res) } +-- +-- Never emits constraints. +-- +-- The LHsTyVarBndrs is always user-written, and the kind of the tycon +-- is available in the local env. +tc_tycl_tyvars second_pass tycon hs_tvs thing_inside + = do { kind <- kcLookupKind tycon + ; let (scoped_tvs, non_cusk_kv_name_set, all_kvs, all_tvs, res_k) + = splitTelescopeTvs kind hs_tvs + ; traceTc "tcTyClTyVars splitTelescopeTvs:" + (vcat [ text "Tycon:" <+> ppr tycon + , text "Kind:" <+> ppr kind + , text "hs_tvs:" <+> ppr hs_tvs + , text "scoped tvs:" <+> pprWithCommas pprTvBndr scoped_tvs + , text "implicit tvs:" <+> pprWithCommas pprTvBndr all_kvs + , text "explicit tvs:" <+> pprWithCommas pprTvBndr all_tvs + , text "non-CUSK kvs:" <+> ppr non_cusk_kv_name_set + , text "res_k:" <+> ppr res_k] ) + + -- need to look up the non-cusk kvs in order to get their + -- kinds right, in case the kinds were informed by + -- the getInitialKinds pass + ; let non_cusk_kv_names = nameSetElems non_cusk_kv_name_set + free_kvs = tyCoVarsOfTypes $ + map tyVarKind (all_kvs ++ all_tvs) + lookup nm = case lookupVarSetByName free_kvs nm of + Just tv -> Left tv + Nothing -> Right nm + (non_cusk_kvs, weirds) = partitionWith lookup non_cusk_kv_names + + -- See Note [Free-floating kind vars] TODO (RAE): Write note. + ; weird_kvs <- if second_pass + then do { checkNoErrs $ + mapM_ (report_floating_kv all_tvs) weirds + ; return [] } + else do { ks <- mapM (const newMetaKindVar) weirds + ; return (zipWith new_skolem_tv weirds ks) } + + ; tcExtendTyVarEnv (non_cusk_kvs ++ weird_kvs ++ scoped_tvs) $ + thing_inside (non_cusk_kvs ++ weird_kvs ++ all_kvs) all_tvs kind res_k } where - -- In the case of associated types, the renamer has - -- ensured that the names are in commmon - -- e.g. class C a_29 where - -- type T b_30 a_29 :: * - -- Here the a_29 is shared - tc_hs_tv (L _ (UserTyVar (L _ n))) kind - = return (mkTyVar n kind) - tc_hs_tv (L _ (KindedTyVar (L _ n) hs_k)) kind - = do { tc_kind <- tcLHsKind hs_k - ; checkKind kind tc_kind - ; return (mkTyVar n kind) } + report_floating_kv all_tvs kv_name + = addErr $ + vcat [ text "Kind variable" <+> quotes (ppr kv_name) <+> + text "is implicitly bound in datatype" + , quotes (ppr tycon) <> comma <+> + text "but does not appear as the kind of any" + , text "of its type variables. Perhaps you meant" + , text "to bind it (with TypeInType) explicitly somewhere?" + , if null all_tvs then empty else + hang (text "Type variables with inferred kinds:") + 2 (pprTvBndrs all_tvs) ] ----------------------------------- tcDataKindSig :: Kind -> TcM [TyVar] @@ -1256,6 +1792,7 @@ tcDataKindSig :: Kind -> TcM [TyVar] -- This function makes up suitable (kinded) type variables for -- the argument kinds, and checks that the result kind is indeed *. -- We use it also to make up argument type variables for for data instances. +-- Never emits constraints. tcDataKindSig kind = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) ; span <- getSrcSpanM @@ -1270,7 +1807,8 @@ tcDataKindSig kind ; return [ mk_tv span uniq occ kind | ((kind, occ), uniq) <- arg_kinds `zip` occs `zip` uniqs ] } where - (arg_kinds, res_kind) = splitKindFunTys kind + (bndrs, res_kind) = splitPiTys kind + arg_kinds = map binderType bndrs mk_tv loc uniq occ kind = mkTyVar (mkInternalName uniq occ loc) kind @@ -1340,45 +1878,44 @@ Historical note: tcHsPatSigType :: UserTypeCtxt -> LHsSigWcType Name -- The type signature -> TcM ( Type -- The signature - , [(Name, TcTyVar)] -- The new bit of type environment, binding - -- the scoped type variables + , [TcTyVar] -- The new bit of type environment, binding + -- the scoped type variables , [(Name, TcTyVar)] ) -- The wildcards -- Used for type-checking type signatures in -- (a) patterns e.g f (x::Int) = e --- (b) result signatures e.g. g x :: Int = e --- (c) RULE forall bndrs e.g. forall (x::Int). f x = x +-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x +-- +-- This may emit constraints tcHsPatSigType ctxt sig_ty - | HsIB { hsib_kvs = sig_kvs, hsib_tvs = sig_tvs, hsib_body = wc_ty } <- sig_ty - , HsWC { hswc_wcs = sig_wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty + | HsIB { hsib_vars = sig_vars, hsib_body = wc_ty } <- sig_ty + , HsWC { hswc_wcs = sig_wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty = ASSERT( isNothing extra ) -- No extra-constraint wildcard in pattern sigs addSigCtxt ctxt hs_ty $ tcWildCardBinders sig_wcs $ \ wcs -> do { emitWildCardHoleConstraints wcs - ; kvs <- mapM new_kv sig_kvs - ; tvs <- mapM new_tv sig_tvs - ; let ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs) - ; sig_ty <- tcExtendTyVarEnv2 ktv_binds $ - tcHsLiftedType hs_ty - ; sig_ty <- zonkSigType sig_ty + ; (vars, sig_ty) <- tcImplicitTKBndrsX new_tkv sig_vars $ + do { ty <- tcHsLiftedType hs_ty + ; return (ty, allBoundVariables ty) } + ; sig_ty <- zonkTcType sig_ty + -- don't use zonkTcTypeToType; it mistreats wildcards ; checkValidType ctxt sig_ty - ; traceTc "tcHsPatSigType" (ppr sig_tvs $$ ppr ktv_binds) - ; return (sig_ty, ktv_binds, wcs) } + ; traceTc "tcHsPatSigType" (ppr sig_vars) + ; return (sig_ty, vars, wcs) } where - new_kv name = new_tkv name superKind - new_tv name = do { kind <- newMetaKindVar - ; new_tkv name kind } - - new_tkv name kind -- See Note [Pattern signature binders] - = case ctxt of - RuleSigCtxt {} -> return (mkTcTyVar name kind (SkolemTv False)) - _ -> newSigTyVar name kind -- See Note [Unifying SigTvs] + new_tkv name -- See Note [Pattern signature binders] + = (, False) <$> -- "False" means that these tyvars aren't yet in scope + do { kind <- newMetaKindVar + ; case ctxt of + RuleSigCtxt {} -> return $ new_skolem_tv name kind + _ -> newSigTyVar name kind } + -- See Note [Unifying SigTvs] tcPatSig :: Bool -- True <=> pattern binding -> LHsSigWcType Name -> TcSigmaType -> TcM (TcType, -- The type to use for "inside" the signature - [(Name, TcTyVar)], -- The new bit of type environment, binding + [TcTyVar], -- The new bit of type environment, binding -- the scoped type variables [(Name, TcTyVar)], -- The wildcards HsWrapper) -- Coercion due to unification with actual ty @@ -1409,8 +1946,8 @@ tcPatSig in_pat_bind sig res_ty -- f :: Int -> Int -- f (x :: T a) = ... -- Here 'a' doesn't get a binding. Sigh - ; let bad_tvs = [ tv | (_, tv) <- sig_tvs - , not (tv `elemVarSet` exactTyVarsOfType sig_ty) ] + ; let bad_tvs = [ tv | tv <- sig_tvs + , not (tv `elemVarSet` exactTyCoVarsOfType sig_ty) ] ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty @@ -1430,10 +1967,10 @@ tcPatSig in_pat_bind sig res_ty 2 (ppr res_ty)) ] ; return (tidy_env, msg) } -patBindSigErr :: [(Name, TcTyVar)] -> SDoc +patBindSigErr :: [TcTyVar] -> SDoc patBindSigErr sig_tvs = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs - <+> pprQuotedList (map fst sig_tvs)) + <+> pprQuotedList sig_tvs) 2 (ptext (sLit "in a pattern binding signature")) {- @@ -1486,142 +2023,19 @@ in-scope variables that it should not unify with, but it's fiddly. * * ************************************************************************ -We would like to get a decent error message from - (a) Under-applied type constructors - f :: (Maybe, Maybe) - (b) Over-applied type constructors - f :: Int x -> Int x -} --- The ExpKind datatype means "expected kind" and contains --- some info about just why that kind is expected, to improve --- the error message on a mis-match -data ExpKind = EK TcKind (TcKind -> SDoc) - -- The second arg is function that takes a *tidied* version - -- of the first arg, and produces something like - -- "Expected kind k" - -- "Expected a constraint" - -- "The argument of Maybe should have kind k" - -instance Outputable ExpKind where - ppr (EK k f) = f k - -ekLifted, ekOpen, ekConstraint :: ExpKind -ekLifted = EK liftedTypeKind expectedKindMsg -ekOpen = EK openTypeKind expectedKindMsg -ekConstraint = EK constraintKind expectedKindMsg - -expectedKindMsg :: TcKind -> SDoc -expectedKindMsg pkind - | isConstraintKind pkind = ptext (sLit "Expected a constraint") - | isOpenTypeKind pkind = ptext (sLit "Expected a type") - | otherwise = ptext (sLit "Expected kind") <+> quotes (pprKind pkind) - --- Build an ExpKind for arguments -expArgKind :: SDoc -> TcKind -> Int -> ExpKind -expArgKind exp kind arg_no = EK kind msg_fn - where - msg_fn pkind - = sep [ ptext (sLit "The") <+> speakNth arg_no - <+> ptext (sLit "argument of") <+> exp - , nest 2 $ ptext (sLit "should have kind") - <+> quotes (pprKind pkind) ] - -unifyKinds :: SDoc -> [LHsType Name] -> [TcKind] -> TcM TcKind -unifyKinds fun hs_tys act_kinds +-- | Produce an 'TcKind' suitable for a checking a type that can be * or #. +ekOpen :: TcM TcKind +ekOpen = do { lev <- newFlexiTyVarTy levityTy + ; return (tYPE lev) } + +unifyKinds :: [(TcType, TcKind)] -> TcM ([TcType], TcKind) +unifyKinds act_kinds = do { kind <- newMetaKindVar - ; let check (arg_no, L _ hs_ty, act_kind) - = checkExpectedKind hs_ty act_kind (expArgKind (quotes fun) kind arg_no) - ; mapM_ check (zip3 [1..] hs_tys act_kinds) - ; return kind } - -checkKind :: TcKind -> TcKind -> TcM () -checkKind act_kind exp_kind - = do { mb_subk <- unifyKindX act_kind exp_kind - ; case mb_subk of - Just EQ -> return () - _ -> unifyKindMisMatch act_kind exp_kind } - -checkExpectedKind :: HsType Name -> TcKind -> ExpKind -> TcM () --- A fancy wrapper for 'unifyKindX', which tries --- to give decent error messages. --- (checkExpectedKind ty act_kind exp_kind) --- checks that the actual kind act_kind is compatible --- with the expected kind exp_kind --- The first argument, ty, is used only in the error message generation -checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) - = do { mb_subk <- unifyKindX act_kind exp_kind - - -- Kind unification only generates definite errors - ; case mb_subk of { - Just LT -> return () ; -- act_kind is a sub-kind of exp_kind - Just EQ -> return () ; -- The two are equal - _other -> do - - { -- So there's an error - -- Now to find out what sort - exp_kind <- zonkTcKind exp_kind - ; act_kind <- zonkTcKind act_kind - ; traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr exp_kind) - ; env0 <- tcInitTidyEnv - ; dflags <- getDynFlags - ; let (exp_as, _) = splitKindFunTys exp_kind - (act_as, _) = splitKindFunTys act_kind - n_exp_as = length exp_as - n_act_as = length act_as - n_diff_as = n_act_as - n_exp_as - - (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind - (env2, tidy_act_kind) = tidyOpenKind env1 act_kind - - occurs_check - | Just act_tv <- tcGetTyVar_maybe act_kind - = check_occ act_tv exp_kind - | Just exp_tv <- tcGetTyVar_maybe exp_kind - = check_occ exp_tv act_kind - | otherwise - = False - - check_occ tv k = case occurCheckExpand dflags tv k of - OC_Occurs -> True - _bad -> False - - err | occurs_check -- Must precede the "more args expected" check - = ptext (sLit "Kind occurs check") $$ more_info - - | n_exp_as < n_act_as -- E.g. [Maybe] - = vcat [ ptext (sLit "Expecting") <+> - speakN n_diff_as <+> ptext (sLit "more argument") - <> (if n_diff_as > 1 then char 's' else empty) - <+> ptext (sLit "to") <+> quotes (ppr ty) - , more_info ] - - -- Now n_exp_as >= n_act_as. In the next two cases, - -- n_exp_as == 0, and hence so is n_act_as - | otherwise -- E.g. Monad [Int] - = more_info - - more_info - | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind - = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) - <+> ptext (sLit "is unlifted") - - | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind - = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty) - <+> ptext (sLit "is lifted") - - | isSubOpenTypeKind exp_kind - , isConstraintKind act_kind - = ptext (sLit "Constraint") <+> quotes (ppr ty) - <+> ptext (sLit "used as a type") - - | otherwise - = sep [ ek_ctxt tidy_exp_kind <> comma - , nest 2 $ ptext (sLit "but") <+> quotes (ppr ty) - <+> ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind) ] - - ; traceTc "checkExpectedKind 1" (ppr ty $$ ppr tidy_act_kind $$ ppr tidy_exp_kind $$ ppr env1 $$ ppr env2) - ; failWithTcM (env2, err) } } } + ; let check (ty, act_kind) = checkExpectedKind ty act_kind kind + ; tys' <- mapM check act_kinds + ; return (tys', kind) } {- ************************************************************************ @@ -1632,113 +2046,15 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) tcLHsKind converts a user-written kind to an internal, sort-checked kind. It does sort checking and desugaring at the same time, in one single pass. -It fails when the kinds are not well-formed (eg. data A :: * Int), or if there -are non-promotable or non-fully applied kinds. -} tcLHsKind :: LHsKind Name -> TcM Kind -tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ - tc_lhs_kind k +tcLHsKind = tc_lhs_kind kindLevelMode -tc_lhs_kind :: LHsKind Name -> TcM Kind -tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) - --- The main worker -tc_hs_kind :: HsKind Name -> TcM Kind -tc_hs_kind (HsTyVar (L _ tc)) = tc_kind_var_app tc [] -tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] - -tc_hs_kind (HsParTy ki) = tc_lhs_kind ki - -tc_hs_kind (HsFunTy ki1 ki2) = - do kappa_ki1 <- tc_lhs_kind ki1 - kappa_ki2 <- tc_lhs_kind ki2 - return (mkArrowKind kappa_ki1 kappa_ki2) - -tc_hs_kind (HsListTy ki) = - do kappa <- tc_lhs_kind ki - checkWiredInTyCon listTyCon - return $ mkPromotedListTy kappa - -tc_hs_kind (HsTupleTy _ kis) = - do kappas <- mapM tc_lhs_kind kis - checkWiredInTyCon tycon - return $ mkTyConApp tycon kappas - where - tycon = promotedTupleTyCon Boxed (length kis) - --- Argument not kind-shaped -tc_hs_kind k = pprPanic "tc_hs_kind" (ppr k) - --- Special case for kind application -tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind -tc_kind_app (HsAppTy ki1 ki2) kis = tc_kind_app (unLoc ki1) (ki2:kis) -tc_kind_app (HsTyVar (L _ tc)) kis = do { arg_kis <- mapM tc_lhs_kind kis - ; tc_kind_var_app tc arg_kis } -tc_kind_app ki _ = failWithTc (quotes (ppr ki) <+> - ptext (sLit "is not a kind constructor")) - -tc_kind_var_app :: Name -> [Kind] -> TcM Kind --- Special case for * and Constraint kinds --- They are kinds already, so we don't need to promote them -tc_kind_var_app name arg_kis - | name == liftedTypeKindTyConName - || name == constraintKindTyConName - = do { unless (null arg_kis) - (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) - ; thing <- tcLookup name - ; case thing of - AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "tc_kind_var_app 1" } - --- General case -tc_kind_var_app name arg_kis - = do { thing <- tcLookup name - ; case thing of - AGlobal (ATyCon tc) - -> do { data_kinds <- xoptM Opt_DataKinds - ; unless data_kinds $ addErr (dataKindsErr name) - ; case promotableTyCon_maybe tc of - Promoted prom_tc | arg_kis `lengthIs` tyConArity prom_tc - -> return (mkTyConApp prom_tc arg_kis) - Promoted _ -> tycon_err tc "is not fully applied" - NotPromoted -> tycon_err tc "is not promotable" } - - -- A lexically scoped kind variable - ATyVar _ kind_var - | not (isKindVar kind_var) - -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr kind_var) - <+> ptext (sLit "used as a kind")) - | not (null arg_kis) -- Kind variables always have kind BOX, - -- so cannot be applied to anything - -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr name) - <+> ptext (sLit "cannot appear in a function position")) - | otherwise - -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) - - -- It is in scope, but not what we expected - AThing _ - | isTyVarName name - -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr name) - <+> ptext (sLit "used in a kind")) - | otherwise - -> failWithTc (hang (ptext (sLit "Type constructor") <+> quotes (ppr name) - <+> ptext (sLit "used in a kind")) - 2 (ptext (sLit "inside its own recursive group"))) - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr "promoted type" thing name - -- This really should not happen - } - where - tycon_err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind") - <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg)) - -dataKindsErr :: Name -> SDoc -dataKindsErr name - = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr name)) - 2 (ptext (sLit "Perhaps you intended to use DataKinds")) +tc_lhs_kind :: TcTyMode -> LHsKind Name -> TcM Kind +tc_lhs_kind mode k + = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + tc_lhs_type (kindLevel mode) k liftedTypeKind promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err @@ -1746,9 +2062,11 @@ promotionErr name err 2 (parens reason)) where reason = case err of - FamDataConPE -> ptext (sLit "it comes from a data family instance") - NoDataKinds -> ptext (sLit "Perhaps you intended to use DataKinds") - _ -> ptext (sLit "it is defined and used in the same recursive group") + FamDataConPE -> text "it comes from a data family instance" + NoDataKinds -> text "Perhaps you intended to use DataKinds" + NoTypeInTypeTC -> text "Perhaps you intended to use TypeInType" + NoTypeInTypeDC -> text "Perhaps you intended to use TypeInType" + _ -> text "it is defined and used in the same recursive group" {- ************************************************************************ @@ -1767,12 +2085,18 @@ badPatSigTvs sig_ty bad_tvs , ptext (sLit "To fix this, expand the type synonym") , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] -unifyKindMisMatch :: TcKind -> TcKind -> TcM a -unifyKindMisMatch ki1 ki2 = do - ki1' <- zonkTcKind ki1 - ki2' <- zonkTcKind ki2 - let msg = hang (ptext (sLit "Couldn't match kind")) - 2 (sep [quotes (ppr ki1'), - ptext (sLit "against"), - quotes (ppr ki2')]) - failWithTc msg +{- +************************************************************************ +* * + Error messages and such +* * +************************************************************************ +-} + +-- | Make an appropriate message for an error in a function argument. +-- Used for both expressions and types. +funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc +funAppCtxt fun arg arg_no + = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), + quotes (ppr fun) <> text ", namely"]) + 2 (quotes (ppr arg)) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 860b79f2ca..587fa9fa78 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -21,6 +21,7 @@ import TcClassDcl( tcClassDecl2, tcATDefault, import TcPat ( addInlinePrags, lookupPragEnv, emptyPragEnv ) import TcRnMonad import TcValidity +import TcHsSyn ( zonkTcTypeToTypes, emptyZonkEnv ) import TcMType import TcType import BuildTyCl @@ -36,7 +37,8 @@ import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import TcEvidence import TyCon -import CoAxiom( toBranchedAxiom ) +import Coercion ( emptyCvSubstEnv ) +import CoAxiom import DataCon import Class import Var @@ -526,7 +528,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + mini_subst = mkTCvSubst (mkInScopeSet (mkVarSet tyvars)) + (mini_env, emptyCvSubstEnv) mb_info = Just (clas, mini_env) -- Next, process any associated types. @@ -644,20 +647,21 @@ tcDataFamInstDecl mb_clsinfo -- Kind check type patterns ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats - (kcDataDefn defn) $ + (kcDataDefn (unLoc fam_tc_name) pats defn) $ \tvs' pats' res_kind -> do - - { -- Check that left-hand side contains no type family applications + { + -- Check that left-hand side contains no type family applications -- (vanilla synonyms are fine, though, and we checked for -- foralls earlier) - checkValidFamPats fam_tc tvs' pats' + ; checkValidFamPats fam_tc tvs' [] pats' -- Check that type patterns match class instance head, if any ; checkConsistentFamInst mb_clsinfo fam_tc tvs' pats' -- Result kind must be '*' (otherwise, we have too few patterns) ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) - ; stupid_theta <- tcHsContext ctxt + ; stupid_theta <- solveEqualities $ tcHsContext ctxt + ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_theta ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons -- Construct representation tycon @@ -674,7 +678,6 @@ tcDataFamInstDecl mb_clsinfo ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) -> do { data_cons <- tcConDecls new_or_data - False -- Not promotable rec_rep_tc (full_tvs, orig_res_ty) cons ; tc_rhs <- case new_or_data of @@ -683,19 +686,19 @@ tcDataFamInstDecl mb_clsinfo mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) -- freshen tyvars ; let axiom = mkSingleCoAxiom Representational - axiom_name eta_tvs fam_tc eta_pats + axiom_name eta_tvs [] fam_tc eta_pats (mkTyConApp rep_tc (mkTyVarTys eta_tvs)) parent = DataFamInstTyCon axiom fam_tc pats' + kind = mkPiTypesPreferFunTy tvs' liftedTypeKind + -- NB: Use the full_tvs from the pats. See bullet toward -- the end of Note [Data type families] in TyCon - rep_tc = buildAlgTyCon rep_tc_name full_tvs - (map (const Nominal) full_tvs) - (fmap unLoc cType) stupid_theta - tc_rhs - Recursive - False -- No promotable to the kind level - gadt_syntax parent + rep_tc = mkAlgTyCon rep_tc_name kind full_tvs + (map (const Nominal) full_tvs) + (fmap unLoc cType) stupid_theta + tc_rhs parent + Recursive gadt_syntax -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive @@ -727,7 +730,7 @@ tcDataFamInstDecl mb_clsinfo = go (reverse pats) [] go (pat:pats) etad_tvs | Just tv <- getTyVar_maybe pat - , not (tv `elemVarSet` tyVarsOfTypes pats) + , not (tv `elemVarSet` tyCoVarsOfTypes pats) = go pats (tv : etad_tvs) go pats etad_tvs = (reverse pats, etad_tvs) @@ -791,7 +794,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; let (clas, inst_tys) = tcSplitDFunHead inst_head (class_tyvars, sc_theta, _, op_items) = classBigSig clas - sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta + sc_theta' = substTheta (zipOpenTCvSubst class_tyvars inst_tys) sc_theta ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) @@ -828,7 +831,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , ic_given = dfun_ev_vars , ic_wanted = addImplics emptyWC sc_meth_implics , ic_status = IC_Unsolved - , ic_binds = dfun_ev_binds_var + , ic_binds = Just dfun_ev_binds_var , ic_env = env , ic_info = InstSkol } @@ -849,6 +852,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr) + -- NB: We *can* have covars in inst_tys, in the case of + -- promoted GADT constructors. + con_app_args = foldl app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr Id -> Id -> HsExpr Id @@ -971,16 +977,18 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t loc = getSrcSpan dfun_id size = sizeTypes inst_tys tc_super (sc_pred, n) - = do { (sc_implic, sc_ev_id) <- checkInstConstraints $ - emitWanted (ScOrigin size) sc_pred + = do { (sc_implic, ev_binds_var, sc_ev_tm) + <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred - ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) - ; let sc_top_ty = mkForAllTys tyvars (mkPiTypes dfun_evs sc_pred) + ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) + ; sc_ev_id <- newEvVar sc_pred + ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm + ; let sc_top_ty = mkInvForAllTys tyvars (mkPiTypes dfun_evs sc_pred) sc_top_id = mkLocalId sc_top_name sc_top_ty export = ABE { abe_wrap = idHsWrapper, abe_poly = sc_top_id , abe_mono = sc_ev_id , abe_prags = SpecPrags [] } - local_ev_binds = TcEvBinds (ic_binds sc_implic) + local_ev_binds = TcEvBinds ev_binds_var bind = AbsBinds { abs_tvs = tyvars , abs_ev_vars = dfun_evs , abs_exports = [export] @@ -989,7 +997,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t ; return (sc_top_id, L loc bind, sc_implic) } ------------------- -checkInstConstraints :: TcM result -> TcM (Implication, result) +checkInstConstraints :: TcM result + -> TcM (Implication, EvBindsVar, result) -- See Note [Typechecking plan for instance declarations] checkInstConstraints thing_inside = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ @@ -1003,11 +1012,11 @@ checkInstConstraints thing_inside , ic_given = [] , ic_wanted = wanted , ic_status = IC_Unsolved - , ic_binds = ev_binds_var + , ic_binds = Just ev_binds_var , ic_env = env , ic_info = InstSkol } - ; return (implic, result) } + ; return (implic, ev_binds_var, result) } {- Note [Recursive superclasses] @@ -1266,9 +1275,13 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; return (meth_id, meth_bind, Nothing) } where error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) - error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID + error_fun = L inst_loc $ + wrapId (mkWpTyApps + [ getLevity "tcInstanceMethods.tc_default" meth_tau + , meth_tau]) + nO_METHOD_BINDING_ERROR_ID error_msg dflags = L inst_loc (HsLit (HsStringPrim "" - (unsafeMkByteString (error_string dflags)))) + (unsafeMkByteString (error_string dflags)))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) error_string dflags = showSDoc dflags (hcat [ppr inst_loc, vbar, ppr sel_id ]) @@ -1284,8 +1297,9 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- you to apply a function to a dictionary *expression*. ; self_dict <- newDict clas inst_tys - ; let self_ev_bind = mkWantedEvBind self_dict - (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars) + ; let ev_term = EvDFunApp dfun_id (mkTyVarTys tyvars) + (map EvId dfun_ev_vars) + self_ev_bind = mkWantedEvBind self_dict ev_term ; (meth_id, local_meth_sig, hs_wrap) <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars inst_tys sel_id @@ -1353,7 +1367,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys ; global_meth_id <- addInlinePrags global_meth_id prags ; spec_prags <- tcSpecPrags global_meth_id prags - ; (meth_implic, (tc_bind, _)) + ; (meth_implic, ev_binds_var, (tc_bind, _)) <- checkInstConstraints $ tcPolyCheck NonRecursive no_prag_fn local_meth_sig (L bind_loc lm_bind) @@ -1364,7 +1378,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys , abe_wrap = hs_wrap , abe_prags = specs } - local_ev_binds = TcEvBinds (ic_binds meth_implic) + local_ev_binds = TcEvBinds ev_binds_var full_bind = AbsBinds { abs_tvs = tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] @@ -1402,11 +1416,12 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id do { inst_sigs <- xoptM Opt_InstanceSigs ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty) ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) lhs_ty - ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty + ; let poly_sig_ty = mkInvSigmaTy tyvars theta sig_ty ctxt = FunSigCtxt sel_name True ; tc_sig <- instTcTySig ctxt lhs_ty sig_ty local_meth_name ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $ - tcSubType ctxt poly_sig_ty poly_meth_ty + tcSubType ctxt (Just poly_meth_id) + poly_sig_ty poly_meth_ty ; return (poly_meth_id, tc_sig, hs_wrap) } Nothing -- No type signature @@ -1422,7 +1437,7 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id sel_name = idName sel_id sel_occ = nameOccName sel_name local_meth_ty = instantiateMethod clas sel_id inst_tys - poly_meth_ty = mkSigmaTy tyvars theta local_meth_ty + poly_meth_ty = mkInvSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 180ddd39a4..75399f13ca 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -14,7 +14,6 @@ import TcCanonical import TcFlatten import VarSet import Type -import Kind ( isKind ) import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId ) import CoAxiom( sfInteractTop, sfInteractInert ) @@ -22,8 +21,11 @@ import Var import TcType import Name import PrelNames ( knownNatClassName, knownSymbolClassName, - callStackTyConKey, typeableClassName ) -import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind ) + callStackTyConKey, typeableClassName, coercibleTyConKey, + heqTyConKey ) +import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind, heqDataCon, + coercibleDataCon ) +import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) import Id( idType ) import CoAxiom ( Eqn, CoAxiom(..), CoAxBranch(..), fromBranches ) import Class @@ -32,7 +34,6 @@ import DataCon( dataConWrapId ) import FunDeps import FamInst import FamInstEnv -import Inst( tyVarsOfCt ) import Unify ( tcUnifyTyWithTFs ) import TcEvidence @@ -285,7 +286,7 @@ runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_insol = insols1, wc_impl = where setEv :: (EvTerm,Ct) -> TcS () setEv (ev,ct) = case ctEvidence ct of - CtWanted {ctev_evar = evar} -> setWantedEvBind evar ev + CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" -- | A triple of (given, derived, wanted) constraints to pass to plugins @@ -395,7 +396,7 @@ runSolverPipeline pipeline workItem ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (ptext (sLit "Kept as inert")) ; traceTcS "End solver pipeline (kept as inert) }" $ vcat [ ptext (sLit "final_item =") <+> ppr ct - , pprTvBndrs (varSetElems $ tyVarsOfCt ct) + , pprTvBndrs (varSetElems $ tyCoVarsOfCt ct) , ptext (sLit "inerts =") <+> ppr final_is] ; addInertCan ct } } @@ -521,8 +522,9 @@ solveOneFromTheOther ev_i ev_w , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w = return (IRDelete, False) - | CtWanted { ctev_evar = ev_id } <- ev_w -- Inert is Given or Wanted - = do { setWantedEvBind ev_id (ctEvTerm ev_i) + | CtWanted { ctev_dest = dest } <- ev_w + -- Inert is Given or Wanted + = do { setWantedEvTerm dest (ctEvTerm ev_i) ; return (IRKeep, True) } | CtWanted { ctev_loc = loc_i } <- ev_i -- Work item is Given @@ -531,8 +533,8 @@ solveOneFromTheOther ev_i ev_w -- This never actually happens because -- Givens get processed first - | CtWanted { ctev_evar = ev_id } <- ev_i -- Work item is Given - = do { setWantedEvBind ev_id (ctEvTerm ev_w) + | CtWanted { ctev_dest = dest } <- ev_i + = do { setWantedEvTerm dest (ctEvTerm ev_w) ; return (IRReplace, True) } -- So they are both Given @@ -648,8 +650,9 @@ interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) | let pred = ctEvPred ev_w - (matching_irreds, others) = partitionBag (\ct -> ctPred ct `tcEqType` pred) - (inert_irreds inerts) + (matching_irreds, others) + = partitionBag (\ct -> ctPred ct `tcEqTypeNoKindCheck` pred) + (inert_irreds inerts) , (ct_i : rest) <- bagToList matching_irreds , let ctev_i = ctEvidence ct_i = ASSERT( null rest ) @@ -683,7 +686,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs -- don't ever try to solve CallStack IPs directly from other dicts, -- we always build new dicts instead. -- See Note [Overview of implicit CallStacks] - | Just mkEvCs <- isCallStackIP (ctEvLoc ev_w) cls tys + | Just mkEvCs <- isCallStackIP loc cls tys , isWanted ev_w = do let ev_cs = case lookupInertDict inerts cls tys of @@ -694,7 +697,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs -- be a dictionary, so we have to coerce ev_cs to a -- dictionary for `IP ip CallStack` let ip_ty = mkClassPred cls tys - let ev_tm = mkEvCast (EvCallStack ev_cs) (TcCoercion $ wrapIP ip_ty) + let ev_tm = mkEvCast (EvCallStack ev_cs) (wrapIP ip_ty) addSolvedDict ev_w cls tys setWantedEvBind (ctEvId ev_w) ev_tm stopWith ev_w "Wanted CallStack IP" @@ -717,6 +720,8 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs | otherwise = do { addFunDepWork inerts ev_w cls ; continueWith workItem } + where + loc = ctEvLoc ev_w interactDict _ wi = pprPanic "interactDict" (ppr wi) @@ -854,7 +859,8 @@ interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) -- Try interacting the work item with the inert set interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc , cc_tyargs = args, cc_fsk = fsk }) - | Just (CFunEqCan { cc_ev = ev_i, cc_fsk = fsk_i }) <- matching_inerts + | Just (CFunEqCan { cc_ev = ev_i + , cc_fsk = fsk_i }) <- matching_inerts = if ev_i `canDischarge` ev then -- Rewrite work-item using inert do { traceTcS "reactFunEq (discharge work item):" $ @@ -879,7 +885,7 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc where loc = ctEvLoc ev funeqs = inert_funeqs inerts - matching_inerts = findFunEqs funeqs tc args + matching_inerts = findFunEq funeqs tc args interactFunEq _ workItem = pprPanic "interactFunEq" (ppr workItem) @@ -941,21 +947,26 @@ lookupFlattenTyVar model ftv Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq }) -> rhs _ -> mkTyVarTy ftv -reactFunEq :: CtEvidence -> TcTyVar -- From this :: F tys ~ fsk1 - -> CtEvidence -> TcTyVar -- Solve this :: F tys ~ fsk2 +reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1 + -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2 -> TcS () -reactFunEq from_this fsk1 (CtGiven { ctev_evar = evar, ctev_loc = loc }) fsk2 - = do { let fsk_eq_co = mkTcSymCo (mkTcCoVarCo evar) - `mkTcTransCo` ctEvCoercion from_this +reactFunEq from_this fsk1 solve_this fsk2 + | CtGiven { ctev_evar = evar, ctev_loc = loc } <- solve_this + = do { let fsk_eq_co = mkTcSymCo (mkTcCoVarCo evar) `mkTcTransCo` + ctEvCoercion from_this -- :: fsk2 ~ fsk1 - fsk_eq_pred = mkTcEqPred (mkTyVarTy fsk2) (mkTyVarTy fsk1) + fsk_eq_pred = mkTcEqPredLikeEv solve_this + (mkTyVarTy fsk2) (mkTyVarTy fsk1) + ; new_ev <- newGivenEvVar loc (fsk_eq_pred, EvCoercion fsk_eq_co) ; emitWorkNC [new_ev] } -reactFunEq from_this fuv1 ev fuv2 - = do { traceTcS "reactFunEq" (ppr from_this $$ ppr fuv1 $$ ppr ev $$ ppr fuv2) - ; dischargeFmv ev fuv2 (ctEvCoercion from_this) (mkTyVarTy fuv1) - ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fuv1 $$ ppr ev $$ ppr fuv2) } + | otherwise + = do { traceTcS "reactFunEq" (ppr from_this $$ ppr fsk1 $$ + ppr solve_this $$ ppr fsk2) + ; dischargeFmv solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1) + ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$ + ppr solve_this $$ ppr fsk2) } {- Note [Type inference for type families with injectivity] @@ -1097,7 +1108,11 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv , rhs_i `tcEqType` rhs ] = -- Inert: a ~ b -- Work item: a ~ b - do { setEvBindIfWanted ev (ctEvTerm ev_i) + do { setEvBindIfWanted ev $ + EvCoercion (tcDowngradeRole (eqRelRole eq_rel) + (ctEvRole ev_i) + (ctEvCoercion ev_i)) + ; stopWith ev "Solved from inert" } | Just tv_rhs <- getTyVar_maybe rhs @@ -1107,8 +1122,12 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv , rhs_i `tcEqType` mkTyVarTy tv ] = -- Inert: a ~ b -- Work item: b ~ a - do { setEvBindIfWanted ev - (EvCoercion (mkTcSymCo (ctEvCoercion ev_i))) + do { setEvBindIfWanted ev $ + EvCoercion (mkTcSymCo $ + tcDowngradeRole (eqRelRole eq_rel) + (ctEvRole ev_i) + (ctEvCoercion ev_i)) + ; stopWith ev "Solved from inert (r)" } | otherwise @@ -1164,7 +1183,7 @@ canSolveByUnification tclvl gw eq_rel tv xi solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () -- Solve with the identity coercion --- Precondition: kind(xi) is a sub-kind of kind(tv) +-- Precondition: kind(xi) equals kind(tv) -- Precondition: CtEvidence is Wanted or Derived -- Precondition: CtEvidence is nominal -- Returns: workItem where @@ -1185,13 +1204,8 @@ solveByUnification wd tv xi text "Left Kind is:" <+> ppr (typeKind tv_ty), text "Right Kind is:" <+> ppr (typeKind xi) ] - ; let xi' = defaultKind xi - -- We only instantiate kind unification variables - -- with simple kinds like *, not OpenKind or ArgKind - -- cf TcUnify.uUnboundKVar - - ; unifyTyVar tv xi' - ; setEvBindIfWanted wd (EvCoercion (mkTcNomReflCo xi')) } + ; unifyTyVar tv xi + ; setEvBindIfWanted wd (EvCoercion (mkTcNomReflCo xi)) } ppr_kicked :: Int -> SDoc ppr_kicked 0 = empty @@ -1296,7 +1310,7 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls ; continueWith work_item } | Just ev <- lookupSolvedDict inerts cls xis -- Cached - = do { setEvBindIfWanted fl (ctEvTerm ev); + = do { setEvBindIfWanted fl (ctEvTerm ev) ; stopWith fl "Dict/Top (cached)" } | isDerived fl -- Use type-class instances for Deriveds, in the hope @@ -1306,25 +1320,30 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls = do { dflags <- getDynFlags ; lkup_inst_res <- matchClassInst dflags inerts cls xis dict_loc ; case lkup_inst_res of - GenInst preds _ s -> do { emitNewDeriveds dict_loc preds - ; unless s $ - insertSafeOverlapFailureTcS work_item - ; stopWith fl "Dict/Top (solved)" } + GenInst { lir_new_theta = preds + , lir_safe_over = s } -> + do { emitNewDeriveds dict_loc preds + ; unless s $ insertSafeOverlapFailureTcS work_item + ; stopWith fl "Dict/Top (solved)" } - NoInstance -> do { -- If there is no instance, try improvement - try_fundep_improvement - ; continueWith work_item } } + NoInstance -> + do { -- If there is no instance, try improvement + try_fundep_improvement + ; continueWith work_item } } | otherwise -- Wanted, but not cached = do { dflags <- getDynFlags ; lkup_inst_res <- matchClassInst dflags inerts cls xis dict_loc ; case lkup_inst_res of - GenInst theta mk_ev s -> do { addSolvedDict fl cls xis - ; unless s $ - insertSafeOverlapFailureTcS work_item - ; solve_from_instance theta mk_ev } - NoInstance -> do { try_fundep_improvement - ; continueWith work_item } } + GenInst { lir_new_theta = theta + , lir_mk_ev = mk_ev + , lir_safe_over = s } -> + do { addSolvedDict fl cls xis + ; unless s $ insertSafeOverlapFailureTcS work_item + ; solve_from_instance theta mk_ev } + NoInstance -> + do { try_fundep_improvement + ; continueWith work_item } } where dict_pred = mkClassPred cls xis dict_loc = ctEvLoc fl @@ -1338,7 +1357,8 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls | otherwise = loc - solve_from_instance :: [TcPredType] -> ([EvId] -> EvTerm) -> TcS (StopOrContinue Ct) + solve_from_instance :: [TcPredType] + -> ([EvTerm] -> EvTerm) -> TcS (StopOrContinue Ct) -- Precondition: evidence term matches the predicate workItem solve_from_instance theta mk_ev | null theta @@ -1348,8 +1368,8 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls | otherwise = do { checkReductionDepth deeper_loc dict_pred ; traceTcS "doTopReact/found non-nullary instance for" $ ppr fl - ; evc_vars <- mapM (newWantedEvVar deeper_loc) theta - ; setWantedEvBind (ctEvId fl) (mk_ev (map (ctEvId . fst) evc_vars)) + ; evc_vars <- mapM (newWanted deeper_loc) theta + ; setWantedEvBind (ctEvId fl) (mk_ev (map getEvTerm evc_vars)) ; emitWorkNC (freshGoals evc_vars) ; stopWith fl "Dict/Top (solved, more work)" } @@ -1373,22 +1393,18 @@ doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) -------------------- doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactFunEq work_item = do { fam_envs <- getFamInstEnvs - ; do_top_fun_eq fam_envs work_item } - -do_top_fun_eq :: FamInstEnvs -> Ct -> TcS (StopOrContinue Ct) -do_top_fun_eq fam_envs work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc - , cc_tyargs = args , cc_fsk = fsk }) - | Just (ax_co, rhs_ty) <- reduceTyFamApp_maybe fam_envs Nominal fam_tc args - -- Look up in top-level instances, or built-in axiom - -- See Note [MATCHING-SYNONYMS] - = reduce_top_fun_eq old_ev fsk (TcCoercion ax_co) rhs_ty - - | otherwise - = do { improveTopFunEqs (ctEvLoc old_ev) fam_envs fam_tc args fsk - ; continueWith work_item } - -do_top_fun_eq _ w = pprPanic "doTopReactFunEq" (ppr w) +doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc + , cc_tyargs = args, cc_fsk = fsk }) + = do { match_res <- matchFam fam_tc args + -- Look up in top-level instances, or built-in axiom + -- See Note [MATCHING-SYNONYMS] + ; case match_res of + Nothing -> do { improveTopFunEqs (ctEvLoc old_ev) fam_tc args fsk + ; continueWith work_item } + Just (ax_co, rhs_ty) + -> reduce_top_fun_eq old_ev fsk ax_co rhs_ty } + +doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w) reduce_top_fun_eq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS (StopOrContinue Ct) @@ -1403,13 +1419,13 @@ reduce_top_fun_eq old_ev fsk ax_co rhs_ty | isGiven old_ev -- Not shortcut = do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co -- final_co :: fsk ~ rhs_ty - ; new_ev <- newGivenEvVar deeper_loc (mkTcEqPred (mkTyVarTy fsk) rhs_ty, + ; new_ev <- newGivenEvVar deeper_loc (mkPrimEqPred (mkTyVarTy fsk) rhs_ty, EvCoercion final_co) ; emitWorkNC [new_ev] -- Non-cannonical; that will mean we flatten rhs_ty ; stopWith old_ev "Fun/Top (given)" } -- So old_ev is Wanted or Derived - | not (fsk `elemVarSet` tyVarsOfType rhs_ty) + | not (fsk `elemVarSet` tyCoVarsOfType rhs_ty) = do { dischargeFmv old_ev fsk ax_co rhs_ty ; traceTcS "doTopReactFunEq" $ vcat [ text "old_ev:" <+> ppr old_ev @@ -1418,14 +1434,15 @@ reduce_top_fun_eq old_ev fsk ax_co rhs_ty | otherwise -- We must not assign ufsk := ...ufsk...! = do { alpha_ty <- newFlexiTcSTy (tyVarKind fsk) - ; let pred = mkTcEqPred alpha_ty rhs_ty ; new_ev <- case old_ev of - CtWanted {} -> do { ev <- newWantedEvVarNC loc pred - ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) + CtWanted {} -> do { (ev, _) <- newWantedEq loc Nominal alpha_ty rhs_ty + ; updWorkListTcS $ + extendWorkListEq (mkNonCanonical ev) ; return ev } CtDerived {} -> do { ev <- newDerivedNC loc pred ; updWorkListTcS (extendWorkListDerived loc ev) ; return ev } + where pred = mkPrimEqPred alpha_ty rhs_ty _ -> pprPanic "reduce_top_fun_eq" (ppr old_ev) -- By emitting this as non-canonical, we deal with all @@ -1445,10 +1462,10 @@ reduce_top_fun_eq old_ev fsk ax_co rhs_ty loc = ctEvLoc old_ev deeper_loc = bumpCtLocDepth loc -improveTopFunEqs :: CtLoc -> FamInstEnvs - -> TyCon -> [TcType] -> TcTyVar -> TcS () -improveTopFunEqs loc fam_envs fam_tc args fsk +improveTopFunEqs :: CtLoc -> TyCon -> [TcType] -> TcTyVar -> TcS () +improveTopFunEqs loc fam_tc args fsk = do { model <- getInertModel + ; fam_envs <- getFamInstEnvs ; eqns <- improve_top_fun_eqs fam_envs fam_tc args (lookupFlattenTyVar model fsk) ; mapM_ (unifyDerived loc Nominal) eqns } @@ -1483,7 +1500,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty -> (a -> [Type]) -- get LHS of an axiom -> (a -> Type) -- get RHS of an axiom -> (a -> Maybe CoAxBranch) -- Just => apartness check required - -> [( [Type], TvSubst, TyVarSet, Maybe CoAxBranch )] + -> [( [Type], TCvSubst, TyVarSet, Maybe CoAxBranch )] -- Result: -- ( [arguments of a matching axiom] -- , RHS-unifying substitution @@ -1495,16 +1512,16 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty , let ax_args = axiomLHS axiom , let ax_rhs = axiomRHS axiom , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty] - , let tvs = tyVarsOfTypes ax_args + , let tvs = tyCoVarsOfTypes ax_args notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) - unsubstTvs = filterVarSet notInSubst tvs ] + unsubstTvs = filterVarSet (notInSubst <&&> isTyVar) tvs ] injImproveEqns :: [Bool] - -> ([Type], TvSubst, TyVarSet, Maybe CoAxBranch) + -> ([Type], TCvSubst, TyCoVarSet, Maybe CoAxBranch) -> TcS [Eqn] injImproveEqns inj_args (ax_args, theta, unsubstTvs, cabr) = do (theta', _) <- instFlexiTcS (varSetElems unsubstTvs) - let subst = theta `unionTvSubst` theta' + let subst = theta `unionTCvSubst` theta' return [ Pair arg (substTy subst ax_arg) | case cabr of Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' @@ -1525,7 +1542,7 @@ shortCutReduction old_ev fsk ax_co fam_tc tc_args -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk ; new_ev <- newGivenEvVar deeper_loc - ( mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk) + ( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk) , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos `mkTcTransCo` mkTcSymCo ax_co `mkTcTransCo` ctEvCoercion old_ev) ) @@ -1544,11 +1561,11 @@ shortCutReduction old_ev fsk ax_co fam_tc tc_args -- new_ev :: G xis ~ fsk -- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev - ; new_ev <- newWantedEvVarNC deeper_loc - (mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)) - ; setWantedEvBind (ctEvId old_ev) - (EvCoercion (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos) - `mkTcTransCo` ctEvCoercion new_ev)) + ; (new_ev, new_co) <- newWantedEq deeper_loc Nominal + (mkTyConApp fam_tc xis) (mkTyVarTy fsk) + ; setWantedEq (ctev_dest old_ev) + (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos) + `mkTcTransCo` new_co) ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk } ; emitWorkCt new_ct @@ -1569,7 +1586,7 @@ dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS () -- -- Does not evaluate 'co' if 'ev' is Derived dischargeFmv ev fmv co xi - = ASSERT2( not (fmv `elemVarSet` tyVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) + = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi ) do { setEvBindIfWanted ev (EvCoercion co) ; unflattenFmv fmv xi ; n_kicked <- kickOutAfterUnification fmv @@ -1753,11 +1770,15 @@ type SafeOverlapping = Bool data LookupInstResult = NoInstance - | GenInst [TcPredType] ([EvId] -> EvTerm) SafeOverlapping + | GenInst { lir_new_theta :: [TcPredType] + , lir_mk_ev :: [EvTerm] -> EvTerm + , lir_safe_over :: SafeOverlapping } instance Outputable LookupInstResult where - ppr NoInstance = text "NoInstance" - ppr (GenInst ev _ s) = text "GenInst" <+> ppr ev <+> ss + ppr NoInstance = text "NoInstance" + ppr (GenInst { lir_new_theta = ev + , lir_safe_over = s }) + = text "GenInst" <+> vcat [ppr ev, ss] where ss = text $ if s then "[safe]" else "[unsafe]" @@ -1767,6 +1788,7 @@ matchClassInst dflags inerts clas tys loc -- match this constraint. In that case, do not use top-level -- instances. See Note [Instance and Given overlap] | not (xopt Opt_IncoherentInstances dflags) + , not (naturallyCoherentClass clas) , let matchable_givens = matchableGivens loc pred inerts , not (isEmptyBag matchable_givens) = do { traceTcS "Delaying instance application" $ @@ -1784,11 +1806,13 @@ matchClassInst dflags _ clas tys loc match_class_inst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult match_class_inst dflags clas tys loc - | cls_name == knownNatClassName = matchKnownNat clas tys - | cls_name == knownSymbolClassName = matchKnownSymbol clas tys - | isCTupleClass clas = matchCTuple clas tys - | cls_name == typeableClassName = matchTypeable clas tys - | otherwise = matchInstEnv dflags clas tys loc + | cls_name == knownNatClassName = matchKnownNat clas tys + | cls_name == knownSymbolClassName = matchKnownSymbol clas tys + | isCTupleClass clas = matchCTuple clas tys + | cls_name == typeableClassName = matchTypeable clas tys + | clas `hasKey` heqTyConKey = matchLiftedEquality tys + | clas `hasKey` coercibleTyConKey = matchLiftedCoercible tys + | otherwise = matchInstEnv dflags clas tys loc where cls_name = className clas @@ -1901,7 +1925,9 @@ matchInstEnv dflags clas tys loc match_one so dfun_id mb_inst_tys = do { checkWellStagedDFun pred dfun_id loc ; (tys, theta) <- instDFunType dfun_id mb_inst_tys - ; return $ GenInst theta (EvDFunApp dfun_id tys) so } + ; return $ GenInst { lir_new_theta = theta + , lir_mk_ev = EvDFunApp dfun_id tys + , lir_safe_over = so } } {- ******************************************************************** @@ -1912,7 +1938,9 @@ matchInstEnv dflags clas tys loc matchCTuple :: Class -> [Type] -> TcS LookupInstResult matchCTuple clas tys -- (isCTupleClass clas) holds - = return (GenInst tys tuple_ev True) + = return (GenInst { lir_new_theta = tys + , lir_mk_ev = tuple_ev + , lir_safe_over = True }) -- The dfun *is* the data constructor! where data_con = tyConSingleDataCon (classTyCon clas) @@ -1957,7 +1985,9 @@ makeLitDict clas ty evLit , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] -- SNat n ~ Integer , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep)) - = return $ GenInst [] (\_ -> ev_tm) True + = return $ GenInst { lir_new_theta = [] + , lir_mk_ev = \_ -> ev_tm + , lir_safe_over = True } | otherwise = panicTcS (text "Unexpected evidence for" <+> ppr (className clas) @@ -1981,28 +2011,29 @@ matchTypeable clas [k,t] -- clas = Typeable -- Now cases that do work | k `eqType` typeNatKind = doTyLit knownNatClassName t | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | Just (_, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] - , all isGroundKind ks = doTyConApp t + | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] + , onlyNamedBndrsApplied tc ks = doTyConApp clas t ks | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt matchTypeable _ _ = return NoInstance -doTyConApp :: Type -> TcS LookupInstResult --- Representation for type constructor applied to some (ground) kinds -doTyConApp ty = return $ GenInst [] (\_ -> EvTypeable ty EvTypeableTyCon) True +doTyConApp :: Class -> Type -> [Kind] -> TcS LookupInstResult +-- Representation for type constructor applied to some kinds +doTyConApp clas ty args + = return $ GenInst (map (mk_typeable_pred clas) args) + (\tms -> EvTypeable ty $ EvTypeableTyCon tms) + True -- Representation for concrete kinds. We just use the kind itself, --- but first check to make sure that it is "simple" (i.e., made entirely --- out of kind constructors). -isGroundKind :: KindOrType -> Bool --- Return True if (a) k is a kind and (b) it is a ground kind -isGroundKind k - = isKind k && is_ground k +-- but first we must make sure that we've instantiated all kind- +-- polymorphism, but no more. +onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool +onlyNamedBndrsApplied tc ks + = all isNamedBinder used_bndrs && + not (any isNamedBinder leftover_bndrs) where - is_ground k | Just (_, ks) <- splitTyConApp_maybe k - = all is_ground ks - | otherwise - = False + (bndrs, _) = splitPiTys (tyConKind tc) + (used_bndrs, leftover_bndrs) = splitAtList ks bndrs doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult -- Representation for an application of a type to a type-or-kind. @@ -2013,11 +2044,11 @@ doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult -- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) -- Typeable f doTyApp clas ty f tk - | isKind tk + | isForAllTy (typeKind f) = return NoInstance -- We can't solve until we know the ctr. | otherwise = return $ GenInst [mk_typeable_pred clas f, mk_typeable_pred clas tk] - (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp (EvId t1) (EvId t2)) + (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp t1 t2) True -- Emit a `Typeable` constraint for the given type. @@ -2030,7 +2061,7 @@ mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] doTyLit :: Name -> Type -> TcS LookupInstResult doTyLit kc t = do { kc_clas <- tcLookupClass kc ; let kc_pred = mkClassPred kc_clas [ t ] - mk_ev [ev] = EvTypeable t $ EvTypeableTyLit $ EvId ev + mk_ev [ev] = EvTypeable t $ EvTypeableTyLit ev mk_ev _ = panic "doTyLit" ; return (GenInst [kc_pred] mk_ev True) } @@ -2070,3 +2101,25 @@ a TypeRep for them. For qualified but not polymorphic types, like no other class works with impredicative types. For now we leave it off, until we have a better story for impredicativity. -} + +{- ******************************************************************** +* * + Class lookup for lifted equality +* * +***********************************************************************-} + +matchLiftedEquality :: [Type] -> TcS LookupInstResult +matchLiftedEquality args + = return (GenInst { lir_new_theta = [ mkTyConApp eqPrimTyCon args ] + , lir_mk_ev = EvDFunApp (dataConWrapId heqDataCon) args + , lir_safe_over = True }) + +matchLiftedCoercible :: [Type] -> TcS LookupInstResult +matchLiftedCoercible args@[k, t1, t2] + = return (GenInst { lir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] + , lir_mk_ev = EvDFunApp (dataConWrapId coercibleDataCon) + args + , lir_safe_over = True }) + where + args' = [k, k, t1, t2] +matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args) diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index ea8a11353e..10248c4354 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -9,7 +9,7 @@ This module contains monadic operations over types that contain mutable type variables -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} module TcMType ( TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, @@ -19,7 +19,10 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] + newOpenFlexiTyVarTy, newReturnTyVar, newReturnTyVarTy, + newMaybeReturnTyVarTy, + newOpenReturnTyVar, newMetaKindVar, newMetaKindVars, cloneMetaTyVar, newFmvTyVar, newFskTyVar, @@ -33,60 +36,75 @@ module TcMType ( -------------------------------- -- Creating new evidence variables - newEvVar, newEvVars, newEq, newDict, + newEvVar, newEvVars, newDict, + newWanted, newWanteds, + emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, newTcEvBinds, addTcEvBind, + newCoercionHole, fillCoercionHole, isFilledCoercionHole, + unpackCoercionHole, unpackCoercionHole_maybe, + checkCoercionHole, + -------------------------------- -- Instantiation - tcInstTyVars, tcInstTyVarX, newSigTyVar, newSigKindVar, + tcInstTyVars, tcInstTyVarX, + newSigTyVar, tcInstType, - tcInstSkolTyVars, tcInstSuperSkolTyVarsX, + tcInstSkolTyVars, tcInstSkolTyVarsLoc, tcInstSuperSkolTyVarsX, tcInstSigTyVarsLoc, tcInstSigTyVars, tcInstSkolType, tcSkolDFunType, tcSuperSkolTyVars, - instSkolTyVars, freshenTyVarBndrs, + instSkolTyCoVars, freshenTyVarBndrs, freshenCoVarBndrsX, -------------------------------- -- Zonking and tidying - zonkTcPredType, zonkTidyTcType, zonkTidyOrigin, + zonkTidyTcType, zonkTidyOrigin, + mkTypeErrorThing, mkTypeErrorThingArgs, tidyEvVar, tidyCt, tidySkolemInfo, skolemiseUnboundMetaTyVar, - zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkTcTypeAndFV, - zonkQuantifiedTyVar, quantifyTyVars, - zonkTcTyVarBndr, zonkTcType, zonkTcTypes, zonkTcThetaType, + zonkTcTyVar, zonkTcTyVars, zonkTyCoVarsAndFV, zonkTcTypeAndFV, + zonkQuantifiedTyVar, zonkQuantifiedTyVarOrType, quantifyTyVars, + defaultKindVar, + zonkTcTyCoVarBndr, zonkTcType, zonkTcTypes, zonkCo, + zonkTyCoVarKind, zonkTcTypeMapper, - zonkTcKind, defaultKindVarToStar, zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo, - tcGetGlobalTyVars + tcGetGlobalTyCoVars ) where #include "HsVersions.h" -- friends: -import TypeRep +import TyCoRep ( CoercionHole(..) ) import TcType import Type +import Coercion import Class import Var -import VarEnv -- others: import TcRnMonad -- TcType, amongst others +import TcEvidence import Id import Name import VarSet +import TysWiredIn +import TysPrim +import VarEnv import PrelNames -import DynFlags import Util import Outputable import FastString import SrcLoc import Bag +import Pair +import DynFlags import Control.Monad -import Data.List ( partition, mapAccumL ) +import Maybes +import Data.List ( mapAccumL, partition ) {- ************************************************************************ @@ -106,7 +124,7 @@ kind_var_occ = mkOccName tvName "k" newMetaKindVar :: TcM TcKind newMetaKindVar = do { uniq <- newUnique ; details <- newMetaDetails TauTv - ; let kv = mkTcTyVar (mkKindName uniq) superKind details + ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details ; return (mkTyVarTy kv) } newMetaKindVars :: Int -> TcM [TcKind] @@ -125,15 +143,56 @@ newEvVars theta = mapM newEvVar theta -------------- -newEvVar :: TcPredType -> TcM EvVar +newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar -- Creates new *rigid* variables for predicates newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalId name ty) } - -newEq :: TcType -> TcType -> TcM EvVar -newEq ty1 ty2 - = do { name <- newSysName (mkVarOccFS (fsLit "cobox")) - ; return (mkLocalId name (mkTcEqPred ty1 ty2)) } + ; return (mkLocalIdOrCoVar name ty) } + +-- deals with both equality and non-equality predicates +newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence +newWanted orig t_or_k pty + = do loc <- getCtLocM orig t_or_k + d <- if isEqPred pty then HoleDest <$> newCoercionHole + else EvVarDest <$> newEvVar pty + return $ CtWanted { ctev_dest = d + , ctev_pred = pty + , ctev_loc = loc } + +newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] +newWanteds orig = mapM (newWanted orig Nothing) + +-- | Emits a new Wanted. Deals with both equalities and non-equalities. +emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm +emitWanted origin pty + = do { ev <- newWanted origin Nothing pty + ; emitSimple $ mkNonCanonical ev + ; return $ ctEvTerm ev } + +-- | Emits a new equality constraint +emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion +emitWantedEq origin t_or_k role ty1 ty2 + = do { hole <- newCoercionHole + ; loc <- getCtLocM origin (Just t_or_k) + ; emitSimple $ mkNonCanonical $ + CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole, ctev_loc = loc } + ; return (mkHoleCo hole role ty1 ty2) } + where + pty = mkPrimEqPredRole role ty1 ty2 + +-- | Creates a new EvVar and immediately emits it as a Wanted. +-- No equality predicates here. +emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar +emitWantedEvVar origin ty + = do { new_cv <- newEvVar ty + ; loc <- getCtLocM origin Nothing + ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv + , ctev_pred = ty + , ctev_loc = loc } + ; emitSimple $ mkNonCanonical ctev + ; return new_cv } + +emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] +emitWantedEvVars orig = mapM (emitWantedEvVar orig) newDict :: Class -> [TcType] -> TcM DictId newDict cls tys @@ -146,6 +205,72 @@ predTypeOccName ty = case classifyPredType ty of EqPred _ _ _ -> mkVarOccFS (fsLit "cobox") IrredPred _ -> mkVarOccFS (fsLit "irred") +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +newCoercionHole :: TcM CoercionHole +newCoercionHole + = do { u <- newUnique + ; traceTc "New coercion hole:" (ppr u) + ; ref <- newMutVar Nothing + ; return $ CoercionHole u ref } + +-- | Put a value in a coercion hole +fillCoercionHole :: CoercionHole -> Coercion -> TcM () +fillCoercionHole (CoercionHole u ref) co + = do { +#ifdef DEBUG + ; cts <- readTcRef ref + ; whenIsJust cts $ \old_co -> + pprPanic "Filling a filled coercion hole" (ppr u $$ ppr co $$ ppr old_co) +#endif + ; traceTc "Filling coercion hole" (ppr u <+> text ":=" <+> ppr co) + ; writeTcRef ref (Just co) } + +-- | Is a coercion hole filled in? +isFilledCoercionHole :: CoercionHole -> TcM Bool +isFilledCoercionHole (CoercionHole _ ref) = isJust <$> readTcRef ref + +-- | Retrieve the contents of a coercion hole. Panics if the hole +-- is unfilled +unpackCoercionHole :: CoercionHole -> TcM Coercion +unpackCoercionHole hole + = do { contents <- unpackCoercionHole_maybe hole + ; case contents of + Just co -> return co + Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } + +-- | Retrieve the contents of a coercion hole, if it is filled +unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) +unpackCoercionHole_maybe (CoercionHole _ ref) = readTcRef ref + +-- | Check that a coercion is appropriate for filling a hole. (The hole +-- itself is needed only for printing. NB: This must be /lazy/ in the coercion, +-- as it's used in TcHsSyn in the presence of knots. +-- Always returns the checked coercion, but this return value is necessary +-- so that the input coercion is forced only when the output is forced. +checkCoercionHole :: Coercion -> CoercionHole -> Role -> Type -> Type -> TcM Coercion +checkCoercionHole co h r t1 t2 +-- co is already zonked, but t1 and t2 might not be + | debugIsOn + = do { t1 <- zonkTcType t1 + ; t2 <- zonkTcType t2 + ; let (Pair _t1 _t2, _role) = coercionKindRole co + ; return $ + ASSERT2( t1 `eqType` _t1 && t2 `eqType` _t2 && r == _role + , (text "Bad coercion hole" <+> + ppr h <> colon <+> vcat [ ppr _t1, ppr _t2, ppr _role + , ppr co, ppr t1, ppr t2 + , ppr r ]) ) + co } + | otherwise + = return co + {- ************************************************************************ @@ -155,17 +280,18 @@ predTypeOccName ty = case classifyPredType ty of ************************************************************************ -} -tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar])) -- How to instantiate the type variables - -> TcType -- Type to instantiate - -> TcM ([TcTyVar], TcThetaType, TcType) -- Result - -- (type vars (excl coercion vars), preds (incl equalities), rho) +tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) + -- ^ How to instantiate the type variables + -> TcType -- ^ Type to instantiate + -> TcM ([TcTyVar], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) tcInstType inst_tyvars ty = case tcSplitForAllTys ty of - ([], rho) -> let -- There may be overloading despite no type variables; + ([], rho) -> let -- There may be overloading despite no type variables; -- (?x :: Int) => Int -> Int - (theta, tau) = tcSplitPhiTy rho - in - return ([], theta, tau) + (theta, tau) = tcSplitPhiTy rho + in + return ([], theta, tau) (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars ; let (theta, tau) = tcSplitPhiTy (substTy subst rho) @@ -176,36 +302,41 @@ tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) -- We could give them fresh names, but no need to do so tcSkolDFunType ty = tcInstType tcInstSuperSkolTyVars ty -tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar]) +tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above -- Moreover, make them "super skolems"; see comments with superSkolemTv -- see Note [Kind substitution when instantiating] --- Precondition: tyvars should be ordered (kind vars first) -tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) +-- Precondition: tyvars should be ordered by scoping +tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTCvSubst []) -tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar) +tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) tcSuperSkolTyVar subst tv - = (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv) + = (extendTCvSubst subst tv (mkTyVarTy new_tv), new_tv) where kind = substTy subst (tyVarKind tv) new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv -tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) -tcInstSkolTyVars = tcInstSkolTyVars' False emptyTvSubst +-- Wrappers +-- we need to be able to do this from outside the TcM monad: +tcInstSkolTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsLoc loc = instSkolTyCoVars (mkTcSkolTyVar loc False) -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) -tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTvSubst +tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVars = tcInstSkolTyVars' False emptyTCvSubst -tcInstSuperSkolTyVarsX :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst + +tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst -tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSkolTyVars' :: Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Precondition: tyvars should be ordered (kind vars first) -- see Note [Kind substitution when instantiating] -- Get the location from the monad; this is a complete freshening operation tcInstSkolTyVars' overlappable subst tvs = do { loc <- getSrcSpanM - ; instSkolTyVarsX (mkTcSkolTyVar loc overlappable) subst tvs } + ; instSkolTyCoVarsX (mkTcSkolTyVar loc overlappable) subst tvs } mkTcSkolTyVar :: SrcSpan -> Bool -> Unique -> Name -> Kind -> TcTyVar mkTcSkolTyVar loc overlappable uniq old_name kind @@ -213,14 +344,15 @@ mkTcSkolTyVar loc overlappable uniq old_name kind kind (SkolemTv overlappable) -tcInstSigTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar]) +tcInstSigTyVarsLoc :: SrcSpan -> [TyVar] + -> TcRnIf gbl lcl (TCvSubst, [TcTyVar]) -- We specify the location -tcInstSigTyVarsLoc loc = instSkolTyVars (mkTcSkolTyVar loc False) +tcInstSigTyVarsLoc loc = instSkolTyCoVars (mkTcSkolTyVar loc False) -tcInstSigTyVars :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar]) +tcInstSigTyVars :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TcTyVar]) -- Get the location from the TyVar itself, not the monad tcInstSigTyVars - = instSkolTyVars mk_tv + = instSkolTyCoVars mk_tv where mk_tv uniq old_name kind = mkTcTyVar (setNameUnique old_name uniq) kind (SkolemTv False) @@ -231,32 +363,43 @@ tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) tcInstSkolType ty = tcInstType tcInstSkolTyVars ty ------------------ -freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) +freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar]) -- ^ Give fresh uniques to a bunch of TyVars, but they stay -- as TyVars, rather than becoming TcTyVars -- Used in FamInst.newFamInst, and Inst.newClsInst -freshenTyVarBndrs = instSkolTyVars mk_tv +freshenTyVarBndrs = instSkolTyCoVars mk_tv where mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind +freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcRnIf gbl lcl (TCvSubst, [CoVar]) +-- ^ Give fresh uniques to a bunch of CoVars +-- Used in FamInst.newFamInst +freshenCoVarBndrsX subst = instSkolTyCoVarsX mk_cv subst + where + mk_cv uniq old_name kind = mkCoVar (setNameUnique old_name uniq) kind + ------------------ -instSkolTyVars :: (Unique -> Name -> Kind -> TyVar) - -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) -instSkolTyVars mk_tv = instSkolTyVarsX mk_tv emptyTvSubst +instSkolTyCoVars :: (Unique -> Name -> Kind -> TyCoVar) + -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar]) +instSkolTyCoVars mk_tcv = instSkolTyCoVarsX mk_tcv emptyTCvSubst -instSkolTyVarsX :: (Unique -> Name -> Kind -> TyVar) - -> TvSubst -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar]) -instSkolTyVarsX mk_tv = mapAccumLM (instSkolTyVarX mk_tv) +instSkolTyCoVarsX :: (Unique -> Name -> Kind -> TyCoVar) + -> TCvSubst -> [TyCoVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar]) +instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv) -instSkolTyVarX :: (Unique -> Name -> Kind -> TyVar) - -> TvSubst -> TyVar -> TcRnIf gbl lcl (TvSubst, TyVar) -instSkolTyVarX mk_tv subst tyvar +instSkolTyCoVarX :: (Unique -> Name -> Kind -> TyCoVar) + -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar) +instSkolTyCoVarX mk_tcv subst tycovar = do { uniq <- newUnique - ; let new_tv = mk_tv uniq old_name kind - ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } + ; let new_tv = mk_tcv uniq old_name kind + ; return (extendTCvSubst subst tycovar (mk_ty_co new_tv), new_tv) } where - old_name = tyVarName tyvar - kind = substTy subst (tyVarKind tyvar) + old_name = tyVarName tycovar + kind = substTy subst (tyVarKind tycovar) + + mk_ty_co v + | isTyVar v = mkTyVarTy v + | otherwise = mkCoercionTy $ mkCoVarCo v newFskTyVar :: TcType -> TcM TcTyVar newFskTyVar fam_ty @@ -268,17 +411,17 @@ newFskTyVar fam_ty Note [Kind substitution when instantiating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we instantiate a bunch of kind and type variables, first we -expect them to be sorted (kind variables first, then type variables). +expect them to be topologically sorted. Then we have to instantiate the kind variables, build a substitution from old variables to the new variables, then instantiate the type variables substituting the original kind. Exemple: If we want to instantiate - [(k1 :: BOX), (k2 :: BOX), (a :: k1 -> k2), (b :: k1)] + [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] we want - [(?k1 :: BOX), (?k2 :: BOX), (?a :: ?k1 -> ?k2), (?b :: ?k1)] + [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] instead of the buggous - [(?k1 :: BOX), (?k2 :: BOX), (?a :: k1 -> k2), (?b :: k1)] + [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)] ************************************************************************ @@ -307,17 +450,10 @@ newMetaTyVar meta_info kind ; details <- newMetaDetails meta_info ; return (mkTcTyVar name kind details) } -newSigKindVar :: Name -> TcM TcTyVar -newSigKindVar name = newSigTyVar name superKind - newSigTyVar :: Name -> Kind -> TcM TcTyVar newSigTyVar name kind = do { details <- newMetaDetails SigTv - ; uniq <- newUnique - ; let fresh_name = setNameUnique name uniq - -- Use the same OccName so that the tidy-er - -- doesn't gratuitously rename 'a' to 'a0' etc - ; return (mkTcTyVar fresh_name kind details) } + ; return (mkTcTyVar name kind details) } newFmvTyVar :: TcType -> TcM TcTyVar -- Very like newMetaTyVar, except sets mtv_tclvl to one less @@ -359,7 +495,6 @@ readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) isFilledMetaTyVar :: TyVar -> TcM Bool -- True of a filled-in (Indirect) meta type variable isFilledMetaTyVar tv - | not (isTcTyVar tv) = return False | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref ; return (isIndirect details) } @@ -368,7 +503,6 @@ isFilledMetaTyVar tv isUnfilledMetaTyVar :: TyVar -> TcM Bool -- True of a un-filled-in (Flexi) meta type variable isUnfilledMetaTyVar tv - | not (isTcTyVar tv) = return False | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref ; return (isFlexi details) } @@ -401,15 +535,16 @@ writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- the ref cell must be for the same tyvar writeMetaTyVarRef tyvar ref ty | not debugIsOn - = do { traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - ; writeMutVar ref (Indirect ty) } + = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) + <+> text ":=" <+> ppr ty) + ; writeTcRef ref (Indirect ty) } -- Everything from here on only happens if DEBUG is on | otherwise = do { meta_details <- readMutVar ref; -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcKind tv_kind - ; zonked_ty_kind <- zonkTcKind ty_kind + ; zonked_tv_kind <- zonkTcType tv_kind + ; zonked_ty_kind <- zonkTcType ty_kind -- Check for double updates ; ASSERT2( isFlexi meta_details, @@ -420,7 +555,7 @@ writeMetaTyVarRef tyvar ref ty ; writeMutVar ref (Indirect ty) ; when ( not (isPredTy tv_kind) -- Don't check kinds for updates to coercion variables - && not (zonked_ty_kind `tcIsSubKind` zonked_tv_kind)) + && not (zonked_ty_kind `tcEqKind` zonked_tv_kind)) $ WARN( True, hang (text "Ill-kinded update to meta tyvar") 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) <+> text ":=" @@ -434,12 +569,13 @@ writeMetaTyVarRef tyvar ref ty % Generating fresh variables for pattern match check -} --- UNINSTANTIATED VERSION OF tcInstSkolTyVars -genInstSkolTyVarsX :: SrcSpan -> TvSubst -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar]) --- Precondition: tyvars should be ordered (kind vars first) +-- UNINSTANTIATED VERSION OF tcInstSkolTyCoVars +genInstSkolTyVarsX :: SrcSpan -> TCvSubst -> [TyVar] + -> TcRnIf gbl lcl (TCvSubst, [TcTyVar]) +-- Precondition: tyvars should be scoping-ordered -- see Note [Kind substitution when instantiating] -- Get the location from the monad; this is a complete freshening operation -genInstSkolTyVarsX loc subst tvs = instSkolTyVarsX (mkTcSkolTyVar loc False) subst tvs +genInstSkolTyVarsX loc subst tvs = instSkolTyCoVarsX (mkTcSkolTyVar loc False) subst tvs {- ************************************************************************ @@ -447,6 +583,36 @@ genInstSkolTyVarsX loc subst tvs = instSkolTyVarsX (mkTcSkolTyVar loc False) sub MetaTvs: TauTvs * * ************************************************************************ + +Note [Sort-polymorphic tyvars accept foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a common paradigm: + foo :: (forall a. a -> a) -> Int + foo = error "urk" +To make this work we need to instantiate 'error' with a polytype. +A similar case is + bar :: Bool -> (forall a. a->a) -> Int + bar True = \x. (x 3) + bar False = error "urk" +Here we need to instantiate 'error' with a polytype. + +But 'error' has an sort-polymorphic type variable, precisely so that +we can instantiate it with Int#. So we also allow such type variables +to be instantiate with foralls. It's a bit of a hack, but seems +straightforward. + +Note [Never need to instantiate coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With coercion variables sloshing around in types, it might seem that we +sometimes need to instantiate coercion variables. This would be problematic, +because coercion variables inhabit unboxed equality (~#), and the constraint +solver thinks in terms only of boxed equality (~). The solution is that +we never need to instantiate coercion variables in the first place. + +The tyvars that we need to instantiate come from the types of functions, +data constructors, and patterns. These will never be quantified over +coercion variables, except for the special case of the promoted Eq#. But, +that can't ever appear in user code, so we're safe! -} newFlexiTyVar :: Kind -> TcM TcTyVar @@ -455,7 +621,7 @@ newFlexiTyVar kind = newMetaTyVar TauTv kind newFlexiTyVarTy :: Kind -> TcM TcType newFlexiTyVarTy kind = do tc_tyvar <- newFlexiTyVar kind - return (TyVarTy tc_tyvar) + return (mkTyVarTy tc_tyvar) newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) @@ -464,35 +630,76 @@ newReturnTyVar :: Kind -> TcM TcTyVar newReturnTyVar kind = newMetaTyVar ReturnTv kind newReturnTyVarTy :: Kind -> TcM TcType -newReturnTyVarTy kind = TyVarTy <$> newReturnTyVar kind - -tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar]) +newReturnTyVarTy kind = mkTyVarTy <$> newReturnTyVar kind + +-- | Either makes a normal Flexi or a ReturnTv Flexi +newMaybeReturnTyVarTy :: Bool -- True <=> make a ReturnTv + -> Kind -> TcM TcType +newMaybeReturnTyVarTy True = newReturnTyVarTy +newMaybeReturnTyVarTy False = newFlexiTyVarTy + +-- | Create a tyvar that can be a lifted or unlifted type. +newOpenFlexiTyVarTy :: TcM TcType +newOpenFlexiTyVarTy + = do { lev <- newFlexiTyVarTy levityTy + ; newFlexiTyVarTy (tYPE lev) } + +-- | Create a *return* tyvar that can be a lifted or unlifted type. +newOpenReturnTyVar :: TcM (TcTyVar, TcKind) +newOpenReturnTyVar + = do { lev <- newFlexiTyVarTy levityTy -- this doesn't need ReturnTv + ; let k = tYPE lev + ; tv <- newReturnTyVar k + ; return (tv, k) } + +tcInstTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables --- Note that this works for a sequence of kind and type --- variables. Eg [ (k:BOX), (a:k->k) ] --- Gives [ (k7:BOX), (a8:k7->k7) ] -tcInstTyVars tyvars = mapAccumLM tcInstTyVarX emptyTvSubst tyvars - -- emptyTvSubst has an empty in-scope set, but that's fine here +-- Note that this works for a sequence of kind, type, and coercion variables +-- variables. Eg [ (k:*), (a:k->k) ] +-- Gives [ (k7:*), (a8:k7->k7) ] +tcInstTyVars = mapAccumLM tcInstTyVarX emptyTCvSubst + -- emptyTCvSubst has an empty in-scope set, but that's fine here -- Since the tyvars are freshly made, they cannot possibly be -- captured by any existing for-alls. -tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar) +tcInstTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. tcInstTyVarX subst tyvar = do { uniq <- newUnique - ; details <- newMetaDetails TauTv + -- See Note [Levity polymorphic variables accept foralls] + ; let info = if isLevityPolymorphic (tyVarKind tyvar) + then ReturnTv + else TauTv + ; details <- newMetaDetails info ; let name = mkSystemName uniq (getOccName tyvar) -- See Note [Name of an instantiated type variable] kind = substTy subst (tyVarKind tyvar) new_tv = mkTcTyVar name kind details - ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } + ; return (extendTCvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } {- Note [Name of an instantiated type variable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At the moment we give a unification variable a System Name, which influences the way it is tidied; see TypeRep.tidyTyVarBndr. +Note [Levity polymorphic variables accept foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a common paradigm: + foo :: (forall a. a -> a) -> Int + foo = error "urk" +To make this work we need to instantiate 'error' with a polytype. +A similar case is + bar :: Bool -> (forall a. a->a) -> Int + bar True = \x. (x 3) + bar False = error "urk" +Here we need to instantiate 'error' with a polytype. + +But 'error' has a levity polymorphic type variable, precisely so that +we can instantiate it with Int#. So we also allow such type variables +to be instantiated with foralls. It's a bit of a hack, but seems +straightforward. + ************************************************************************ * * Quantification @@ -501,67 +708,96 @@ influences the way it is tidied; see TypeRep.tidyTyVarBndr. Note [quantifyTyVars] ~~~~~~~~~~~~~~~~~~~~~ -quantifyTyVars is give the free vars of a type that we +quantifyTyVars is given the free vars of a type that we are about to wrap in a forall. -It takes these free type/kind variables and - 1. Zonks them and remove globals - 2. Partitions into type and kind variables (kvs1, tvs) - 3. Extends kvs1 with free kind vars in the kinds of tvs (removing globals) - 4. Calls zonkQuantifiedTyVar on each +It takes these free type/kind variables (partitioned into dependent and +non-dependent variables) and + 1. Zonks them and remove globals and covars + 2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals) + 3. Calls zonkQuantifiedTyVar on each -Step (3) is often unimportant, because the kind variable is often +Step (2) is often unimportant, because the kind variable is often also free in the type. Eg Typeable k (a::k) has free vars {k,a}. But the type (see Trac #7916) (f::k->*) (a::k) has free vars {f,a}, but we must add 'k' as well! Hence step (3). + +This function bothers to distinguish between dependent and non-dependent +variables only to keep correct defaulting behavior with -XNoPolyKinds. +With -XPolyKinds, it treats both classes of variables identically. + +Note that this function can accept covars, but will never return them. +This is because we never want to infer a quantified covar! -} -quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] +quantifyTyVars :: TcTyCoVarSet -- global tvs + -> Pair TcTyCoVarSet -- dependent tvs We only distinguish + -- nondependent tvs between these for + -- -XNoPolyKinds + -> TcM [TcTyVar] -- See Note [quantifyTyVars] --- The input is a mixture of type and kind variables; a kind variable k --- may occur *after* a tyvar mentioning k in its kind -- Can be given a mixture of TcTyVars and TyVars, in the case of --- associated type declarations +-- associated type declarations. Also accepts covars, but *never* returns any. + +quantifyTyVars gbl_tvs (Pair dep_tkvs nondep_tkvs) + = do { dep_tkvs <- zonkTyCoVarsAndFV dep_tkvs + ; nondep_tkvs <- (`minusVarSet` dep_tkvs) <$> + zonkTyCoVarsAndFV nondep_tkvs + ; gbl_tvs <- zonkTyCoVarsAndFV gbl_tvs -quantifyTyVars gbl_tvs tkvs - = do { tkvs <- zonkTyVarsAndFV tkvs - ; gbl_tvs <- zonkTyVarsAndFV gbl_tvs - ; let (kvs, tvs) = partitionVarSet isKindVar $ - closeOverKinds tkvs `minusVarSet` gbl_tvs - -- NB kinds of tvs are zonked by zonkTyVarsAndFV - kvs2 = varSetElems kvs - qtvs = varSetElems tvs + ; let all_cvs = filterVarSet isCoVar $ + dep_tkvs `unionVarSet` nondep_tkvs `minusVarSet` gbl_tvs + dep_kvs = varSetElemsWellScoped $ + dep_tkvs `minusVarSet` gbl_tvs + `minusVarSet` (closeOverKinds all_cvs) + -- remove any tvs that a covar depends on + + nondep_tvs = varSetElemsWellScoped $ + nondep_tkvs `minusVarSet` gbl_tvs + -- no worry about dependent cvs here, as these vars + -- are non-dependent + + -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV -- In the non-PolyKinds case, default the kind variables -- to *, and zonk the tyvars as usual. Notice that this -- may make quantifyTyVars return a shorter list -- than it was passed, but that's ok ; poly_kinds <- xoptM Opt_PolyKinds - ; qkvs <- if poly_kinds - then return kvs2 - else do { let (meta_kvs, skolem_kvs) = partition is_meta kvs2 - is_meta kv = isTcTyVar kv && isMetaTyVar kv - ; mapM_ defaultKindVarToStar meta_kvs - ; return skolem_kvs } -- should be empty - - ; mapM zonk_quant (qkvs ++ qtvs) } + ; dep_vars2 <- if poly_kinds + then return dep_kvs + else do { let (meta_kvs, skolem_kvs) = partition is_meta dep_kvs + is_meta kv = isTcTyVar kv && isMetaTyVar kv + + ; mapM_ defaultKindVar meta_kvs + ; return skolem_kvs } -- should be empty + + ; let quant_vars = dep_vars2 ++ nondep_tvs + + ; traceTc "quantifyTyVars" + (vcat [ text "globals:" <+> ppr gbl_tvs + , text "nondep:" <+> ppr nondep_tvs + , text "dep:" <+> ppr dep_kvs + , text "dep2:" <+> ppr dep_vars2 + , text "quant_vars:" <+> ppr quant_vars ]) + + ; mapMaybeM zonk_quant quant_vars } -- Because of the order, any kind variables -- mentioned in the kinds of the type variables refer to -- the now-quantified versions where zonk_quant tkv | isTcTyVar tkv = zonkQuantifiedTyVar tkv - | otherwise = return tkv + | otherwise = return $ Just tkv -- For associated types, we have the class variables -- in scope, and they are TyVars not TcTyVars -zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar +zonkQuantifiedTyVar :: TcTyVar -> TcM (Maybe TcTyVar) -- The quantified type variables often include meta type variables -- we want to freeze them into ordinary type variables, and --- default their kind (e.g. from OpenTypeKind to TypeKind) --- -- see notes with Kind.defaultKind +-- default their kind (e.g. from TYPE v to TYPE Lifted) -- The meta tyvar is updated to point to the new skolem TyVar. Now any -- bound occurrences of the original type variable will get zonked to -- the immutable version. @@ -570,11 +806,24 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- -- This function is called on both kind and type variables, -- but kind variables *only* if PolyKinds is on. -zonkQuantifiedTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - SkolemTv {} -> do { kind <- zonkTcKind (tyVarKind tv) - ; return $ setTyVarKind tv kind } +-- +-- This returns a tyvar if it should be quantified over; otherwise, +-- it returns Nothing. Nothing is +-- returned only if zonkQuantifiedTyVar is passed a Levity meta-tyvar, +-- in order to default to Lifted. +zonkQuantifiedTyVar tv = left_only `liftM` zonkQuantifiedTyVarOrType tv + where left_only :: Either a b -> Maybe a + left_only (Left x) = Just x + left_only (Right _) = Nothing + +-- | Like zonkQuantifiedTyVar, but if zonking reveals that the tyvar +-- should become a type (when defaulting a levity var to Lifted), it +-- returns the type instead. +zonkQuantifiedTyVarOrType :: TcTyVar -> TcM (Either TcTyVar TcType) +zonkQuantifiedTyVarOrType tv + = case tcTyVarDetails tv of + SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) + ; return $ Left $ setTyVarKind tv kind } -- It might be a skolem type variable, -- for example from a user type signature @@ -587,19 +836,25 @@ zonkQuantifiedTyVar tv Flexi -> return () Indirect ty -> WARN( True, ppr tv $$ ppr ty ) return () - skolemiseUnboundMetaTyVar tv vanillaSkolemTv + if isLevityVar tv + then do { writeMetaTyVar tv liftedDataConTy + ; return (Right liftedDataConTy) } + else Left `liftM` skolemiseUnboundMetaTyVar tv vanillaSkolemTv _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk -defaultKindVarToStar :: TcTyVar -> TcM Kind --- We have a meta-kind: unify it with '*' -defaultKindVarToStar kv - = do { ASSERT( isKindVar kv && isMetaTyVar kv ) - writeMetaTyVar kv liftedTypeKind - ; return liftedTypeKind } +-- | Take an (unconstrained) meta tyvar and default it. Works only for +-- kind vars (of type BOX) and levity vars (of type Levity). +defaultKindVar :: TcTyVar -> TcM Kind +defaultKindVar kv + | ASSERT( isMetaTyVar kv ) + isLevityVar kv + = writeMetaTyVar kv liftedDataConTy >> return liftedDataConTy + | otherwise + = writeMetaTyVar kv liftedTypeKind >> return liftedTypeKind skolemiseUnboundMetaTyVar :: TcTyVar -> TcTyVarDetails -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it --- Skolemise it, including giving it a new Name, so that +-- Skolemise it, so that -- we are totally out of Meta-tyvar-land -- We create a skolem TyVar, not a regular TyVar -- See Note [Zonking to Skolem] @@ -607,12 +862,14 @@ skolemiseUnboundMetaTyVar tv details = ASSERT2( isMetaTyVar tv, ppr tv ) do { span <- getSrcSpanM -- Get the location from "here" -- ie where we are generalising - ; kind <- zonkTcKind (tyVarKind tv) + ; kind <- zonkTcType (tyVarKind tv) ; let uniq = getUnique tv + -- NB: Use same Unique as original tyvar. This is + -- important for TcHsType.splitTelescopeTvs to work properly + tv_name = getOccName tv final_name = mkInternalName uniq tv_name span - final_kind = defaultKind kind - final_tv = mkTcTyVar final_name final_kind details + final_tv = mkTcTyVar final_name kind details ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) @@ -691,58 +948,59 @@ a \/\a in the final result but all the occurrences of a will be zonked to () * * ************************************************************************ -@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. -To improve subsequent calls to the same function it writes the zonked set back into -the environment. -} -tcGetGlobalTyVars :: TcM TcTyVarSet -tcGetGlobalTyVars +-- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in +-- the environment. To improve subsequent calls to the same function it writes +-- the zonked set back into the environment. Note that this returns all +-- variables free in anything (term-level or type-level) in scope. We thus +-- don't have to worry about clashes with things that are not in scope, because +-- if they are reachable, then they'll be returned here. +tcGetGlobalTyCoVars :: TcM TcTyVarSet +tcGetGlobalTyCoVars = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv ; gbl_tvs <- readMutVar gtv_var - ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs + ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs ; writeMutVar gtv_var gbl_tvs' ; return gbl_tvs' } - where -zonkTcTypeAndFV :: TcType -> TcM TyVarSet +zonkTcTypeAndFV :: TcType -> TcM TyCoVarSet -- Zonk a type and take its free variables -- With kind polymorphism it can be essential to zonk *first* -- so that we find the right set of free variables. Eg -- forall k1. forall (a:k2). a -- where k2:=k1 is in the substitution. We don't want -- k2 to look free in this type! -zonkTcTypeAndFV ty = do { ty <- zonkTcType ty; return (tyVarsOfType ty) } +-- NB: This might be called from within the knot, so don't use +-- smart constructors. See Note [Zonking within the knot] in TcHsType +zonkTcTypeAndFV ty + = tyCoVarsOfType <$> mapType (zonkTcTypeMapper { tcm_smart = False }) () ty -zonkTyVar :: TyVar -> TcM TcType +zonkTyCoVar :: TyCoVar -> TcM TcType -- Works on TyVars and TcTyVars -zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv - | otherwise = return (mkTyVarTy tv) +zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv + | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv + | otherwise = ASSERT2( isCoVar tv, ppr tv ) + mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv -- Hackily, when typechecking type and class decls -- we have TyVars in scopeadded (only) in -- TcHsType.tcTyClTyVars, but it seems -- painful to make them into TcTyVars there -zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet -zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars) +zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet +zonkTyCoVarsAndFV tycovars = tyCoVarsOfTypes <$> mapM zonkTyCoVar (varSetElems tycovars) zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars ----------------- Types -zonkTyVarKind :: TyVar -> TcM TyVar -zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv) - ; return (setTyVarKind tv kind') } +zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar +zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) + ; return (setTyVarKind tv kind') } zonkTcTypes :: [TcType] -> TcM [TcType] zonkTcTypes tys = mapM zonkTcType tys -zonkTcThetaType :: TcThetaType -> TcM TcThetaType -zonkTcThetaType theta = mapM zonkTcPredType theta - -zonkTcPredType :: TcPredType -> TcM TcPredType -zonkTcPredType = zonkTcType - {- ************************************************************************ * * @@ -756,8 +1014,8 @@ zonkImplication implic@(Implic { ic_skols = skols , ic_given = given , ic_wanted = wanted , ic_info = info }) - = do { skols' <- mapM zonkTcTyVarBndr skols -- Need to zonk their kinds! - -- as Trac #7230 showed + = do { skols' <- mapM zonkTcTyCoVarBndr skols -- Need to zonk their kinds! + -- as Trac #7230 showed ; given' <- mapM zonkEvVar given ; info' <- zonkSkolemInfo info ; wanted' <- zonkWCRec wanted @@ -801,9 +1059,13 @@ zonkCtEvidence :: CtEvidence -> TcM CtEvidence zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) = do { pred' <- zonkTcType pred ; return (ctev { ctev_pred = pred'}) } -zonkCtEvidence ctev@(CtWanted { ctev_pred = pred }) +zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest }) = do { pred' <- zonkTcType pred - ; return (ctev { ctev_pred = pred' }) } + ; let dest' = case dest of + EvVarDest ev -> EvVarDest $ setVarType ev pred' + -- necessary in simplifyInfer + HoleDest h -> HoleDest h + ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) } zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) = do { pred' <- zonkTcType pred ; return (ctev { ctev_pred = pred' }) } @@ -818,13 +1080,14 @@ zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys zonkSkolemInfo skol_info = return skol_info {- -************************************************************************ -* * +%************************************************************************ +%* * \subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar} * * * For internal use only! * * * ************************************************************************ + -} -- zonkId is used *during* typechecking just to zonk the Id's type @@ -833,59 +1096,53 @@ zonkId id = do { ty' <- zonkTcType (idType id) ; return (Id.setIdType id ty') } +-- | A suitable TyCoMapper for zonking a type inside the knot, and +-- before all metavars are filled in. +zonkTcTypeMapper :: TyCoMapper () TcM +zonkTcTypeMapper = TyCoMapper + { tcm_smart = True + , tcm_tyvar = const zonkTcTyVar + , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) + , tcm_hole = hole + , tcm_tybinder = \_env tv _vis -> ((), ) <$> zonkTcTyCoVarBndr tv } + where + hole :: () -> CoercionHole -> Role -> Type -> Type + -> TcM Coercion + hole _ h r t1 t2 + = do { contents <- unpackCoercionHole_maybe h + ; case contents of + Just co -> do { co <- zonkCo co + ; checkCoercionHole co h r t1 t2 } + Nothing -> do { t1 <- zonkTcType t1 + ; t2 <- zonkTcType t2 + ; return $ mkHoleCo h r t1 t2 } } + + -- For unbound, mutable tyvars, zonkType uses the function given to it -- For tyvars bound at a for-all, zonkType zonks them to an immutable -- type variable and zonks the kind too - zonkTcType :: TcType -> TcM TcType -zonkTcType ty - = go ty - where - go (TyConApp tc tys) = do tys' <- mapM go tys - return (TyConApp tc tys') - -- Do NOT establish Type invariants, because - -- doing so is strict in the TyCOn. - -- See Note [Zonking inside the knot] in TcHsType - - go (LitTy n) = return (LitTy n) - - go (FunTy arg res) = do arg' <- go arg - res' <- go res - return (FunTy arg' res') - - go (AppTy fun arg) = do fun' <- go fun - arg' <- go arg - return (mkAppTy fun' arg') - -- NB the mkAppTy; we might have instantiated a - -- type variable to a type constructor, so we need - -- to pull the TyConApp to the top. - -- OK to do this because only strict in the structure - -- not in the TyCon. - -- See Note [Zonking inside the knot] in TcHsType - - -- The two interesting cases! - go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar - | otherwise = TyVarTy <$> updateTyVarKindM go tyvar - -- Ordinary (non Tc) tyvars occur inside quantified types - - go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv - ; ty' <- go ty - ; return (ForAllTy tv' ty') } - -zonkTcTyVarBndr :: TcTyVar -> TcM TcTyVar +zonkTcType = mapType zonkTcTypeMapper () + +-- | "Zonk" a coercion -- really, just zonk any types in the coercion +zonkCo :: Coercion -> TcM Coercion +zonkCo = mapCoercion zonkTcTypeMapper () + +zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar -- A tyvar binder is never a unification variable (MetaTv), -- rather it is always a skolems. BUT it may have a kind -- that has not yet been zonked, and may include kind -- unification variables. -zonkTcTyVarBndr tyvar - = ASSERT2( isImmutableTyVar tyvar, ppr tyvar ) do +zonkTcTyCoVarBndr tyvar + -- can't use isCoVar, because it looks at a TyCon. Argh. + = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), ppr tyvar ) do updateTyVarKindM zonkTcType tyvar zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis zonkTcTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) do - case tcTyVarDetails tv of + | isTcTyVar tv + = case tcTyVarDetails tv of SkolemTv {} -> zonk_kind_and_return RuntimeUnk {} -> zonk_kind_and_return FlatSkol ty -> zonkTcType ty @@ -894,24 +1151,16 @@ zonkTcTyVar tv ; case cts of Flexi -> zonk_kind_and_return Indirect ty -> zonkTcType ty } - where - zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv - ; return (TyVarTy z_tv) } - -{- -************************************************************************ -* * - Zonking kinds -* * -************************************************************************ --} -zonkTcKind :: TcKind -> TcM TcKind -zonkTcKind k = zonkTcType k + | otherwise -- coercion variable + = zonk_kind_and_return + where + zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv + ; return (mkTyVarTy z_tv) } {- -************************************************************************ -* * +%************************************************************************ +%* * Tidying * * ************************************************************************ @@ -921,20 +1170,36 @@ zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) zonkTidyTcType env ty = do { ty' <- zonkTcType ty ; return (tidyOpenType env ty') } +-- | Make an 'ErrorThing' storing a type. +mkTypeErrorThing :: TcType -> ErrorThing +mkTypeErrorThing ty = ErrorThing ty (Just $ length $ snd $ splitAppTys ty) + zonkTidyTcType + +-- | Make an 'ErrorThing' storing a type, with some extra args known about +mkTypeErrorThingArgs :: TcType -> Int -> ErrorThing +mkTypeErrorThingArgs ty num_args + = ErrorThing ty (Just $ (length $ snd $ splitAppTys ty) + num_args) + zonkTidyTcType + zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) zonkTidyOrigin env (GivenOrigin skol_info) = do { skol_info1 <- zonkSkolemInfo skol_info ; let (env1, skol_info2) = tidySkolemInfo env skol_info1 ; return (env1, GivenOrigin skol_info2) } -zonkTidyOrigin env (TypeEqOrigin { uo_actual = act, uo_expected = exp }) +zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_thing = m_thing }) = do { (env1, act') <- zonkTidyTcType env act ; (env2, exp') <- zonkTidyTcType env1 exp - ; return ( env2, TypeEqOrigin { uo_actual = act', uo_expected = exp' }) } -zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig) + ; (env3, m_thing') <- zonkTidyErrorThing env2 m_thing + ; return ( env3, orig { uo_actual = act' + , uo_expected = exp' + , uo_thing = m_thing' }) } +zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) = do { (env1, ty1') <- zonkTidyTcType env ty1 ; (env2, ty2') <- zonkTidyTcType env1 ty2 ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' ty2' orig') } + ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2) = do { (env1, p1') <- zonkTidyTcType env p1 ; (env2, p2') <- zonkTidyTcType env1 p2 @@ -946,6 +1211,14 @@ zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } zonkTidyOrigin env orig = return (env, orig) +zonkTidyErrorThing :: TidyEnv -> Maybe ErrorThing + -> TcM (TidyEnv, Maybe ErrorThing) +zonkTidyErrorThing env (Just (ErrorThing thing n_args zonker)) + = do { (env', thing') <- zonker env thing + ; return (env', Just $ ErrorThing thing' n_args zonker) } +zonkTidyErrorThing env Nothing + = return (env, Nothing) + ---------------- tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting @@ -988,8 +1261,8 @@ tidySkolemInfo env (InferSkol ids) tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) = (env1, UnifyForAllSkol skol_tvs' ty') where - env1 = tidyFreeTyVars env (tyVarsOfType ty `delVarSetList` skol_tvs) - (env2, skol_tvs') = tidyTyVarBndrs env1 skol_tvs + env1 = tidyFreeTyCoVars env (tyCoVarsOfType ty `delVarSetList` skol_tvs) + (env2, skol_tvs') = tidyTyCoVarBndrs env1 skol_tvs ty' = tidyType env2 ty tidySkolemInfo env info = (env, info) diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 26397761c1..cd0f029eb5 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -40,7 +40,6 @@ import SrcLoc import FastString import DynFlags import PrelNames (monadFailClassName) -import Inst -- Create chunkified tuple tybes for monad comprehensions import MkCore @@ -462,7 +461,8 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts tup_ty = mkBigCoreVarTupTy bndr_ids poly_arg_ty = m_app alphaTy poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + using_poly_ty = mkNamedForAllTy alphaTyVar Invisible $ + by_arrow $ poly_arg_ty `mkFunTy` poly_res_ty ; using' <- tcPolyExpr using using_poly_ty @@ -472,7 +472,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts -- typically something like [(Int,Bool,Int)] -- We don't know what tuple_ty is yet, so we use a variable ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` @@ -573,7 +573,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap , trS_by = by, trS_using = using, trS_form = form , trS_ret = return_op, trS_bind = bind_op , trS_fmap = fmap_op }) res_ty thing_inside - = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind ; m1_ty <- newFlexiTyVarTy star_star_kind ; m2_ty <- newFlexiTyVarTy star_star_kind ; tup_ty <- newFlexiTyVarTy liftedTypeKind @@ -595,7 +595,8 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap using_arg_ty = m1_ty `mkAppTy` tup_ty poly_res_ty = m2_ty `mkAppTy` n_app alphaTy using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + using_poly_ty = mkNamedForAllTy alphaTyVar Invisible $ + by_arrow $ poly_arg_ty `mkFunTy` poly_res_ty -- 'stmts' returns a result of type (m1_ty tuple_ty), @@ -629,7 +630,8 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ; fmap_op' <- case form of ThenForm -> return noSyntaxExpr _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ - mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $ + mkNamedForAllTy alphaTyVar Invisible $ + mkNamedForAllTy betaTyVar Invisible $ (alphaTy `mkFunTy` betaTy) `mkFunTy` (n_app alphaTy) `mkFunTy` (n_app betaTy) @@ -642,7 +644,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap --------------- Bulding the bindersMap ---------------- ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` @@ -689,10 +691,10 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- -> m (st1, (st2, st3)) -- tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside - = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind ; m_ty <- newFlexiTyVarTy star_star_kind - ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $ + ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ (m_ty `mkAppTy` alphaTy) `mkFunTy` (m_ty `mkAppTy` betaTy) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index de6772e0c7..074532276e 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -43,6 +43,7 @@ import PrelNames import BasicTypes hiding (SuccessFlag(..)) import DynFlags import SrcLoc +import VarSet import Util import Outputable import FastString @@ -159,7 +160,7 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty , Just poly_id <- completeIdSigPolyId_maybe sig = do { bndr_id <- addInlinePrags poly_id (lookupPragEnv prags bndr_name) ; traceTc "tcPatBndr(gbl,sig)" (ppr bndr_id $$ ppr (idType bndr_id)) - ; co <- unifyPatType (idType bndr_id) pat_ty + ; co <- unifyPatType bndr_id (idType bndr_id) pat_ty ; return (co, bndr_id) } | otherwise @@ -344,7 +345,7 @@ tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside -- Check that the expected pattern type is itself lifted ; pat_ty' <- newFlexiTyVarTy liftedTypeKind - ; _ <- unifyType pat_ty pat_ty' + ; _ <- unifyType noThing pat_ty pat_ty' ; return (LazyPat pat', res) } @@ -381,7 +382,7 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside -- we will only be able to use view at one instantation in the -- rest of the view ; (expr_co, pat_ty) <- tcInfer $ \ pat_ty -> - unifyType expr'_inferred (mkFunTy overall_pat_ty pat_ty) + unifyType (Just expr) expr'_inferred (mkFunTy overall_pat_ty pat_ty) -- pattern must have pat_ty ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -393,7 +394,8 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty - ; (pat', res) <- tcExtendTyVarEnv2 (wcs ++ tv_binds) $ + ; (pat', res) <- tcExtendTyVarEnv2 wcs $ + tcExtendTyVarEnv tv_binds $ tc_lpat pat inner_ty penv thing_inside ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } @@ -423,9 +425,14 @@ tc_pat penv (PArrPat pats _) pat_ty thing_inside } tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside - = do { let tc = tupleTyCon boxity (length pats) + = do { let arity = length pats + tc = tupleTyCon boxity arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConAppR tc) pat_ty - ; (pats', res) <- tc_lpats penv pats arg_tys thing_inside + -- Unboxed tuples have levity vars, which we discard: + -- See Note [Unboxed tuple levity vars] in TyCon + ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys + Boxed -> arg_tys + ; (pats', res) <- tc_lpats penv pats con_arg_tys thing_inside ; dflags <- getDynFlags @@ -434,14 +441,14 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside -- This is a pretty odd place to make the switch, but -- it was easy to do. ; let - unmangled_result = TuplePat pats' boxity arg_tys + unmangled_result = TuplePat pats' boxity con_arg_tys -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags && isBoxed boxity = LazyPat (noLoc unmangled_result) | otherwise = unmangled_result - ; ASSERT( length arg_tys == length pats ) -- Syntactically enforced + ; ASSERT( length con_arg_tys == length pats ) -- Syntactically enforced return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } @@ -454,7 +461,7 @@ tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside -- Literal patterns tc_pat _ (LitPat simple_lit) pat_ty thing_inside = do { let lit_ty = hsLitType simple_lit - ; co <- unifyPatType lit_ty pat_ty + ; co <- unifyPatType simple_lit lit_ty pat_ty -- coi is of kind: pat_ty ~ lit_ty ; res <- thing_inside ; return ( mkHsWrapPatCo co (LitPat simple_lit) pat_ty @@ -497,13 +504,13 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut ---------------- -unifyPatType :: TcType -> TcType -> TcM TcCoercion +unifyPatType :: Outputable a => a -> TcType -> TcType -> TcM TcCoercion -- In patterns we want a coercion from the -- context type (expected) to the actual pattern type -- But we don't want to reverse the args to unifyType because -- that controls the actual/expected stuff in error messages -unifyPatType actual_ty expected_ty - = do { coi <- unifyType actual_ty expected_ty +unifyPatType thing actual_ty expected_ty + = do { coi <- unifyType (Just thing) actual_ty expected_ty ; return (mkTcSymCo coi) } {- @@ -627,9 +634,10 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside -- Add the stupid theta ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys - ; checkExistentials ex_tvs penv + ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys + ; checkExistentials ex_tvs all_arg_tys penv ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX - (zipTopTvSubst univ_tvs ctxt_res_tys) ex_tvs + (zipTopTCvSubst univ_tvs ctxt_res_tys) ex_tvs -- Get location from monad, not from ex_tvs ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys @@ -638,8 +646,10 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside arg_tys' = substTys tenv arg_tys - ; traceTc "tcConPat" (vcat [ ppr con_name, ppr univ_tvs, ppr ex_tvs, ppr eq_spec - , ppr ex_tvs', ppr ctxt_res_tys, ppr arg_tys' ]) + ; traceTc "tcConPat" (vcat [ ppr con_name, ppr univ_tvs, ppr ex_tvs + , ppr eq_spec + , ppr ex_tvs', ppr ctxt_res_tys, ppr arg_tys' + , ppr arg_pats ]) ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) @@ -656,10 +666,10 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside else do -- The general case, with existential, -- and local equality constraints - { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) + { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) -- order is *important* as we generate the list of -- dictionary binders from theta' - no_equalities = not (any isEqPred theta') + no_equalities = not (any isNomEqPred theta') skol_info = case pe_ctxt penv of LamPat mc -> PatSkol (RealDataCon data_con) mc LetPat {} -> UnkSkol -- Doesn't matter @@ -697,14 +707,15 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside ; (subst, univ_tvs') <- tcInstTyVars univ_tvs - ; checkExistentials ex_tvs penv + ; let all_arg_tys = ty : prov_theta ++ arg_tys + ; checkExistentials ex_tvs all_arg_tys penv ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs ; let ty' = substTy tenv ty arg_tys' = substTys tenv arg_tys prov_theta' = substTheta tenv prov_theta req_theta' = substTheta tenv req_theta - ; wrap <- mkWpCastN <$> unifyType ty' pat_ty + ; wrap <- mkWpCastN <$> unifyType noThing ty' pat_ty ; traceTc "tcPatSynPat" (ppr pat_syn $$ ppr pat_ty $$ ppr ty' $$ @@ -794,11 +805,11 @@ matchExpectedConTy data_tc pat_ty ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, ppr (tyConTyVars data_tc), ppr fam_tc, ppr fam_args]) - ; co1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty + ; co1 <- unifyType noThing (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty -- co1 : T (ty1,ty2) ~N pat_ty ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo co_tc tys' + co2 = mkTcUnbranchedAxInstCo co_tc tys' [] -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 ; return (mkTcSymCo co2 `mkTcTransCo` mkTcSubCo co1, tys') } @@ -910,7 +921,7 @@ addDataConStupidTheta data_con inst_tys -- The origin should always report "occurrence of C" -- even when C occurs in a pattern stupid_theta = dataConStupidTheta data_con - tenv = mkTopTvSubst (dataConUnivTyVars data_con `zip` inst_tys) + tenv = mkTopTCvSubst (dataConUnivTyVars data_con `zip` inst_tys) -- NB: inst_tys can be longer than the univ tyvars -- because the constructor might have existentials inst_theta = substTheta tenv stupid_theta @@ -1022,13 +1033,16 @@ maybeWrapPatCtxt pat tcm thing_inside msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat) ----------------------------------------------- -checkExistentials :: [TyVar] -> PatEnv -> TcM () +checkExistentials :: [TyVar] -- existentials + -> [Type] -- argument types + -> PatEnv -> TcM () -- See Note [Arrows and patterns] -checkExistentials [] _ = return () -checkExistentials _ (PE { pe_ctxt = LetPat {}}) = failWithTc existentialLetPat -checkExistentials _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat -checkExistentials _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat -checkExistentials _ _ = return () +checkExistentials ex_tvs tys _ + | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return () +checkExistentials _ _ (PE { pe_ctxt = LetPat {}}) = failWithTc existentialLetPat +checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat +checkExistentials _ _ (PE { pe_lazy = True }) = failWithTc existentialLazyPat +checkExistentials _ _ _ = return () existentialLazyPat :: SDoc existentialLazyPat diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 69eeef06cb..5480ab899d 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -17,8 +17,9 @@ import TcRnMonad import TcEnv import TcMType import TysPrim -import TypeRep +import TysWiredIn ( levityTy ) import Name +import Coercion ( emptyCvSubstEnv ) import SrcLoc import PatSyn import NameSet @@ -71,7 +72,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details ; (tclvl, wanted, (lpat', (args, pat_ty))) <- pushLevelAndCaptureConstraints $ - do { pat_ty <- newFlexiTyVarTy openTypeKind + do { pat_ty <- newOpenFlexiTyVarTy ; tcPat PatSyn lpat pat_ty $ do { args <- mapM tcLookupId arg_names ; return (args, pat_ty) } } @@ -89,7 +90,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, ; traceTc "tcInferPatSynDecl }" $ ppr name ; tc_patsyn_finish lname dir is_infix lpat' (univ_tvs, req_theta, ev_binds, req_dicts) - (ex_tvs, map mkTyVarTy ex_tvs, prov_theta, emptyTcEvBinds, prov_dicts) + (ex_tvs, mkTyVarTys ex_tvs, prov_theta, emptyTcEvBinds, map EvId prov_dicts) (zip args $ repeat idHsWrapper) pat_ty rec_fields } @@ -133,14 +134,15 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, buildImplication skol_info univ_tvs req_dicts $ tcPat PatSyn lpat pat_ty $ do { ex_sigtvs <- mapM (\tv -> newSigTyVar (getName tv) (tyVarKind tv)) ex_tvs - ; let subst = mkTvSubst (mkInScopeSet (zipVarEnv ex_sigtvs ex_sigtvs)) $ - zipTyEnv ex_tvs (map mkTyVarTy ex_sigtvs) - ; let ex_tys = substTys subst $ map mkTyVarTy ex_tvs + ; let subst = mkTCvSubst (mkInScopeSet (zipVarEnv ex_sigtvs ex_sigtvs)) $ + ( zipTyEnv ex_tvs (mkTyVarTys ex_sigtvs) + , emptyCvSubstEnv ) + ; let ex_tys = substTys subst $ mkTyVarTys ex_tvs prov_theta' = substTheta subst prov_theta ; wrapped_args <- forM (zipEqual "tcCheckPatSynDecl" arg_names arg_tys) $ \(arg_name, arg_ty) -> do { arg <- tcLookupId arg_name ; let arg_ty' = substTy subst arg_ty - ; coi <- unifyType (varType arg) arg_ty' + ; coi <- unifyType (Just arg) (varType arg) arg_ty' ; return (setVarType arg arg_ty, mkWpCastN coi) } ; return (ex_tys, prov_theta', wrapped_args) } @@ -151,7 +153,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, ; (implic2, prov_ev_binds, prov_dicts) <- buildImplication skol_info ex_tvs_rhs prov_dicts_rhs $ do { let origin = PatOrigin -- TODO - ; emitWanteds origin prov_theta' } + ; mapM (emitWanted origin) prov_theta' } -- Solve the constraints now, because we are about to make a PatSyn, -- which should not contain unification variables and the like (Trac #10997) @@ -194,7 +196,7 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name -> Bool -- ^ Whether infix -> LPat Id -- ^ Pattern of the PatSyn -> ([TcTyVar], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVar], [TcType], [PredType], TcEvBinds, [EvVar]) + -> ([TcTyVar], [TcType], [PredType], TcEvBinds, [EvTerm]) -> [(Var, HsWrapper)] -- ^ Pattern arguments -> TcType -- ^ Pattern type -> [Name] -- ^ Selector names @@ -207,10 +209,10 @@ tc_patsyn_finish lname dir is_infix lpat' pat_ty field_labels = do { -- Zonk everything. We are about to build a final PatSyn -- so there had better be no unification variables in there - univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs - ; ex_tvs <- mapM zonkQuantifiedTyVar ex_tvs - ; prov_theta <- zonkTcThetaType prov_theta - ; req_theta <- zonkTcThetaType req_theta + univ_tvs <- mapMaybeM zonkQuantifiedTyVar univ_tvs + ; ex_tvs <- mapMaybeM zonkQuantifiedTyVar ex_tvs + ; prov_theta <- zonkTcTypes prov_theta + ; req_theta <- zonkTcTypes req_theta ; pat_ty <- zonkTcType pat_ty ; wrapped_args <- mapM zonk_wrapped_arg wrapped_args ; let qtvs = univ_tvs ++ ex_tvs @@ -281,7 +283,7 @@ tc_patsyn_finish lname dir is_infix lpat' tcPatSynMatcher :: Located Name -> LPat Id -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) - -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvVar]) + -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvTerm]) -> [(Var, HsWrapper)] -> TcType -> TcM ((Id, Bool), LHsBinds Id) @@ -290,9 +292,13 @@ tcPatSynMatcher (L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts) wrapped_args pat_ty - = do { uniq <- newUnique - ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc - res_tv = mkTcTyVar tv_name openTypeKind (SkolemTv False) + = do { lev_uniq <- newUnique + ; tv_uniq <- newUnique + ; let lev_name = mkInternalName lev_uniq (mkTyVarOcc "rlev") loc + tv_name = mkInternalName tv_uniq (mkTyVarOcc "r") loc + lev_tv = mkTcTyVar lev_name levityTy (SkolemTv False) + lev = mkTyVarTy lev_tv + res_tv = mkTcTyVar tv_name (tYPE lev) (SkolemTv False) is_unlifted = null wrapped_args && null prov_dicts res_ty = mkTyVarTy res_tv (cont_arg_tys, cont_args) @@ -300,7 +306,7 @@ tcPatSynMatcher (L loc name) lpat | otherwise = unzip [ (varType arg, mkLHsWrap wrap $ nlHsVar arg) | (arg, wrap) <- wrapped_args ] - cont_ty = mkSigmaTy ex_tvs prov_theta $ + cont_ty = mkInvSigmaTy ex_tvs prov_theta $ mkFunTys cont_arg_tys res_ty fail_ty = mkFunTy voidPrimTy res_ty @@ -311,13 +317,14 @@ tcPatSynMatcher (L loc name) lpat ; fail <- newSysLocalId (fsLit "fail") fail_ty ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty - matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau + matcher_sigma = mkInvSigmaTy (lev_tv:res_tv:univ_tvs) req_theta matcher_tau matcher_id = mkExportedLocalId PatSynId matcher_name matcher_sigma -- See Note [Exported LocalIds] in Id - cont_dicts = map nlHsVar prov_dicts cont' = mkLHsWrap (mkWpLet prov_ev_binds) $ - nlHsTyApps cont ex_tys (cont_dicts ++ cont_args) + foldl nlHsApp + (mkLHsWrap (mkWpEvApps prov_dicts) + (nlHsTyApp cont ex_tys)) cont_args fail' = nlHsApps fail [nlHsVar voidPrimId] @@ -342,7 +349,7 @@ tcPatSynMatcher (L loc name) lpat , mg_res_ty = res_ty , mg_origin = Generated } - match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') + match = mkMatch [] (mkHsLams (lev_tv:res_tv:univ_tvs) req_dicts body') (noLoc EmptyLocalBinds) mg = MG{ mg_alts = L (getLoc match) [match] , mg_arg_tys = [] @@ -393,7 +400,7 @@ mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty = return Nothing | otherwise = do { builder_name <- newImplicitBinder name mkBuilderOcc - ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty) + ; let builder_sigma = mkInvSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty) builder_id = -- See Note [Exported LocalIds] in Id mkExportedLocalId VanillaId builder_name builder_sigma diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs index ecf8ed9e45..7ba1f51892 100644 --- a/compiler/typecheck/TcPluginM.hs +++ b/compiler/typecheck/TcPluginM.hs @@ -43,6 +43,7 @@ module TcPluginM ( newWanted, newDerived, newGiven, + newCoercionHole, -- * Manipulating evidence bindings newEvVar, @@ -53,12 +54,11 @@ module TcPluginM ( ) where #ifdef GHCI -import qualified TcRnMonad -import qualified TcSMonad -import qualified TcEnv -import qualified TcMType -import qualified Inst -import qualified FamInst +import qualified TcRnMonad as TcM +import qualified TcSMonad as TcS +import qualified TcEnv as TcM +import qualified TcMType as TcM +import qualified FamInst as TcM import qualified IfaceEnv import qualified Finder @@ -68,7 +68,8 @@ import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM , liftIO, traceTc ) import TcMType ( TcTyVar, TcType ) import TcEnv ( TcTyThing ) -import TcEvidence ( TcCoercion, EvTerm, EvBind, EvBindsVar, mkGivenEvBind ) +import TcEvidence ( TcCoercion, CoercionHole + , EvTerm, EvBind, EvBindsVar, mkGivenEvBind ) import TcRnTypes ( CtEvidence(..) ) import Var ( EvVar ) @@ -106,62 +107,61 @@ lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod tcLookupGlobal :: Name -> TcPluginM TyThing -tcLookupGlobal = unsafeTcPluginTcM . TcEnv.tcLookupGlobal +tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal tcLookupTyCon :: Name -> TcPluginM TyCon -tcLookupTyCon = unsafeTcPluginTcM . TcEnv.tcLookupTyCon +tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon tcLookupDataCon :: Name -> TcPluginM DataCon -tcLookupDataCon = unsafeTcPluginTcM . TcEnv.tcLookupDataCon +tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon tcLookupClass :: Name -> TcPluginM Class -tcLookupClass = unsafeTcPluginTcM . TcEnv.tcLookupClass +tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass tcLookup :: Name -> TcPluginM TcTyThing -tcLookup = unsafeTcPluginTcM . TcEnv.tcLookup +tcLookup = unsafeTcPluginTcM . TcM.tcLookup tcLookupId :: Name -> TcPluginM Id -tcLookupId = unsafeTcPluginTcM . TcEnv.tcLookupId +tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId getTopEnv :: TcPluginM HscEnv -getTopEnv = unsafeTcPluginTcM TcRnMonad.getTopEnv +getTopEnv = unsafeTcPluginTcM TcM.getTopEnv getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) -getEnvs = unsafeTcPluginTcM TcRnMonad.getEnvs +getEnvs = unsafeTcPluginTcM TcM.getEnvs getInstEnvs :: TcPluginM InstEnvs -getInstEnvs = unsafeTcPluginTcM Inst.tcGetInstEnvs +getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv) -getFamInstEnvs = unsafeTcPluginTcM FamInst.tcGetFamInstEnvs - -matchFam :: TyCon -> [Type] -> TcPluginM (Maybe (TcCoercion, TcType)) -matchFam tycon args = unsafeTcPluginTcM $ TcSMonad.matchFamTcM tycon args +getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs +matchFam :: TyCon -> [Type] + -> TcPluginM (Maybe (TcCoercion, TcType)) +matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args newUnique :: TcPluginM Unique -newUnique = unsafeTcPluginTcM TcRnMonad.newUnique +newUnique = unsafeTcPluginTcM TcM.newUnique newFlexiTyVar :: Kind -> TcPluginM TcTyVar -newFlexiTyVar = unsafeTcPluginTcM . TcMType.newFlexiTyVar +newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool -isTouchableTcPluginM = unsafeTcPluginTcM . TcRnMonad.isTouchableTcM +isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM zonkTcType :: TcType -> TcPluginM TcType -zonkTcType = unsafeTcPluginTcM . TcMType.zonkTcType +zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType zonkCt :: Ct -> TcPluginM Ct -zonkCt = unsafeTcPluginTcM . TcMType.zonkCt +zonkCt = unsafeTcPluginTcM . TcM.zonkCt -- | Create a new wanted constraint. newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted loc pty = do - new_ev <- newEvVar pty - return CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } +newWanted loc pty + = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty) -- | Create a new derived constraint. newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence @@ -178,14 +178,18 @@ newGiven loc pty evtm = do -- | Create a fresh evidence variable. newEvVar :: PredType -> TcPluginM EvVar -newEvVar = unsafeTcPluginTcM . TcMType.newEvVar +newEvVar = unsafeTcPluginTcM . TcM.newEvVar + +-- | Create a fresh coercion hole. +newCoercionHole :: TcPluginM CoercionHole +newCoercionHole = unsafeTcPluginTcM $ TcM.newCoercionHole -- | Bind an evidence variable. This must not be invoked from -- 'tcPluginInit' or 'tcPluginStop', or it will panic. setEvBind :: EvBind -> TcPluginM () setEvBind ev_bind = do tc_evbinds <- getEvBindsTcPluginM - unsafeTcPluginTcM $ TcMType.addTcEvBind tc_evbinds ev_bind + unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind -- | Access the 'EvBindsVar' carried by the 'TcPluginM' during -- constraint solving. This must not be invoked from 'tcPluginInit' diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 59f1ab85dc..07d519376e 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -918,7 +918,7 @@ checkSuccess = Nothing ---------------- checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc checkBootTyCon tc1 tc2 - | not (eqKind (tyConKind tc1) (tyConKind tc2)) + | not (eqType (tyConKind tc1) (tyConKind tc2)) = Just $ text "The types have different kinds" -- First off, check the kind | Just c1 <- tyConClass_maybe tc1 @@ -927,7 +927,7 @@ checkBootTyCon tc1 tc2 = classExtraBigSig c1 (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) = classExtraBigSig c2 - , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 + , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 = let eqSig (id1, def_meth1) (id2, def_meth2) = check (name1 == name2) @@ -973,14 +973,14 @@ checkBootTyCon tc1 tc2 (text "The functional dependencies do not match") `andThenCheck` checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $ -- Above tests for an "abstract" class - check (eqListBy (eqPredX env) sc_theta1 sc_theta2) + check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) (text "The class constraints do not match") `andThenCheck` checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` checkListBy eqAT ats1 ats2 (text "associated types") | Just syn_rhs1 <- synTyConRhs_maybe tc1 , Just syn_rhs2 <- synTyConRhs_maybe tc2 - , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) check (roles1 == roles2) roles_msg `andThenCheck` check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say @@ -1005,10 +1005,10 @@ checkBootTyCon tc1 tc2 check (injInfo1 == injInfo2) empty | isAlgTyCon tc1 && isAlgTyCon tc2 - , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) check (roles1 == roles2) roles_msg `andThenCheck` - check (eqListBy (eqPredX env) + check (eqListBy (eqTypeX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2)) (text "The datatype contexts do not match") `andThenCheck` eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) @@ -1066,9 +1066,12 @@ checkBootTyCon tc1 tc2 branch_list1 = fromBranches branches1 branch_list2 = fromBranches branches2 - eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) - | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2 + eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 + , cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 + , cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 + , Just env <- eqVarBndrs env1 cvs1 cvs2 = eqListBy (eqTypeX env) lhs1 lhs2 && eqTypeX env rhs1 rhs2 @@ -1938,7 +1941,9 @@ tcGhciStmts stmts -- if they were overloaded, since they aren't applied to anything.) ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; - mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) + mk_item id = let ty_args = [idType id, unitTy] in + nlHsApp (nlHsTyApp unsafeCoerceId + (map (getLevity "tcGhciStmts") ty_args ++ ty_args)) (nlHsVar id) ; stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; @@ -2013,7 +2018,7 @@ tcRnExpr hsc_env rdr_expr -- Ignore the dictionary bindings _ <- simplifyInteractive (andWC stWC lie_top) ; - let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; + let { all_expr_ty = mkInvForAllTys qtvs (mkPiTypes dicts res_ty) } ; ty <- zonkTcType all_expr_ty ; -- We normalise type families, so that the type of an expression is the @@ -2058,22 +2063,22 @@ tcRnType hsc_env normalise rdr_type -- It can have any rank or kind -- First bring into scope any wildcards ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) - ; (ty, kind) <- tcWildCardBinders wcs $ \ _ -> + ; (ty, kind) <- solveEqualities $ + tcWildCardBinders wcs $ \ _ -> tcLHsType rn_type -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- zonkTcTypeAndFV kind - ; kvs <- kindGeneralize kvs + ; kvs <- kindGeneralize kind ; ty <- zonkTcTypeToType emptyZonkEnv ty ; ty' <- if normalise then do { fam_envs <- tcGetFamInstEnvs - ; return (snd (normaliseType fam_envs Nominal ty)) } - -- normaliseType returns a coercion - -- which we discard, so the Role is irrelevant + ; let (_, ty') + = normaliseType fam_envs Nominal ty + ; return ty' } else return ty ; - ; return (ty', mkForAllTys kvs (typeKind ty')) } + ; return (ty', mkInvForAllTys kvs (typeKind ty')) } {- Note [Kind-generalise in tcRnType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index d5654aee89..0fc310f3ed 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -452,7 +452,7 @@ newName occ ; loc <- getSrcSpanM ; return (mkInternalName uniq occ loc) } -newSysName :: OccName -> TcM Name +newSysName :: OccName -> TcRnIf gbl lcl Name newSysName occ = do { uniq <- newUnique ; return (mkSystemName uniq occ) } @@ -460,12 +460,12 @@ newSysName occ newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId newSysLocalId fs ty = do { u <- newUnique - ; return (mkSysLocal fs u ty) } + ; return (mkSysLocalOrCoVar fs u ty) } newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } + ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) } instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique @@ -686,7 +686,7 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: MsgDoc -> TcRn () -- Ignores the context stack +addErr :: MsgDoc -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } failWith :: MsgDoc -> TcRn a @@ -985,12 +985,13 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) -getCtLocM :: CtOrigin -> TcM CtLoc -getCtLocM origin +getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc +getCtLocM origin t_or_k = do { env <- getLclEnv ; return (CtLoc { ctl_origin = origin - , ctl_env = env - , ctl_depth = initialSubGoalDepth }) } + , ctl_env = env + , ctl_t_or_k = t_or_k + , ctl_depth = initialSubGoalDepth }) } setCtLocM :: CtLoc -> TcM a -> TcM a -- Set the SrcSpan and error context from the CtLoc @@ -1047,10 +1048,20 @@ checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err +checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +checkTcM True _ = return () +checkTcM False err = failWithTcM err + failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false failIfTc False _ = return () failIfTc True err = failWithTc err +failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () + -- Check that the boolean is false +failIfTcM False _ = return () +failIfTcM True err = failWithTcM err + + -- Warnings have no 'M' variant, nor failure warnTc :: Bool -> MsgDoc -> TcM () @@ -1058,6 +1069,11 @@ warnTc warn_if_true warn_msg | warn_if_true = addWarnTc warn_msg | otherwise = return () +warnTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +warnTcM warn_if_true warn_msg + | warn_if_true = addWarnTcM warn_msg + | otherwise = return () + addWarnTc :: MsgDoc -> TcM () addWarnTc msg = do { env0 <- tcInitTidyEnv ; addWarnTcM (env0, msg) } @@ -1092,6 +1108,15 @@ tcInitTidyEnv = do { lcl_env <- getLclEnv ; return (tcl_tidy lcl_env) } +-- | Get a 'TidyEnv' that includes mappings for all vars free in the given +-- type. Useful when tidying open types. +tcInitOpenTidyEnv :: TyCoVarSet -> TcM TidyEnv +tcInitOpenTidyEnv tvs + = do { env1 <- tcInitTidyEnv + ; let env2 = tidyFreeTyCoVars env1 tvs + ; return env2 } + + {- ----------------------------------- Other helper functions @@ -1144,12 +1169,14 @@ debugTc thing newTcEvBinds :: TcM EvBindsVar newTcEvBinds = do { ref <- newTcRef emptyEvBindMap ; uniq <- newUnique + ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) ; return (EvBindsVar ref uniq) } addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar ev_ref _) ev_bind - = do { traceTc "addTcEvBind" $ ppr ev_bind +addTcEvBind (EvBindsVar ev_ref u) ev_bind + = do { traceTc "addTcEvBind" $ ppr u $$ + ppr ev_bind ; bnds <- readTcRef ev_ref ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } @@ -1158,6 +1185,10 @@ getTcEvBinds (EvBindsVar ev_ref _) = do { bnds <- readTcRef ev_ref ; return (evBindMapBinds bnds) } +getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap +getTcEvBindsMap (EvBindsVar ev_ref _) + = readTcRef ev_ref + chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName chooseUniqueOccTc fn = do { env <- getGblEnv @@ -1206,6 +1237,10 @@ emitInsoluble ct v <- readTcRef lie_var ; traceTc "emitInsoluble" (ppr v) } +-- | Throw out any constraints emitted by the thing_inside +discardConstraints :: TcM a -> TcM a +discardConstraints thing_inside = fst <$> captureConstraints thing_inside + captureConstraints :: TcM a -> TcM (a, WantedConstraints) -- (captureConstraints m) runs m, and returns the type constraints it generates captureConstraints thing_inside @@ -1271,7 +1306,7 @@ traceTcConstraints msg emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () emitWildCardHoleConstraints wcs - = do { ctLoc <- getCtLocM HoleOrigin + = do { ctLoc <- getCtLocM HoleOrigin Nothing ; forM_ wcs $ \(name, tv) -> do { ; let real_span = case nameSrcSpan name of RealSrcSpan span -> span @@ -1280,7 +1315,8 @@ emitWildCardHoleConstraints wcs -- Wildcards are defined locally, and so have RealSrcSpans ctLoc' = setCtLocSpan ctLoc real_span ty = mkTyVarTy tv - can = CHoleCan { cc_ev = CtDerived { ctev_pred = ty, ctev_loc = ctLoc' } + can = CHoleCan { cc_ev = CtDerived { ctev_pred = ty + , ctev_loc = ctLoc' } , cc_occ = occName name , cc_hole = TypeHole } ; emitInsoluble can } } diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index b5748f4f99..932b7ddcc7 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -16,7 +16,8 @@ For state that is global and should be returned at the end (e.g not part of the stack mechanism), you should use an TcRef (= IORef) to store them. -} -{-# LANGUAGE CPP, ExistentialQuantification, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, ExistentialQuantification, GeneralizedNewtypeDeriving, + ViewPatterns #-} module TcRnTypes( TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module @@ -68,13 +69,18 @@ module TcRnTypes( isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, isUserTypeErrorCt, getUserTypeErrorMsg, ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, + mkTcEqPredLikeEv, mkNonCanonical, mkNonCanonicalCt, ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, ctEvTerm, ctEvCoercion, ctEvId, + tyCoVarsOfCt, tyCoVarsOfCts, + tyCoVarsOfCtList, tyCoVarsOfCtsList, + toDerivedCt, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, + toDerivedWC, andWC, unionsWC, addSimples, addImplics, mkSimpleWC, addInsols, - dropDerivedWC, dropDerivedSimples, dropDerivedInsols, + tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols, isDroppableDerivedLoc, insolubleImplic, trulyInsoluble, arisesFromGivens, @@ -82,15 +88,18 @@ module TcRnTypes( SubGoalDepth, initialSubGoalDepth, bumpSubGoalDepth, subGoalDepthExceeded, CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, + ctLocTypeOrKind_maybe, ctLocDepth, bumpCtLocDepth, setCtLocOrigin, setCtLocEnv, setCtLocSpan, - CtOrigin(..), pprCtOrigin, pprCtLoc, + CtOrigin(..), ErrorThing(..), mkErrorThing, errorThingNumArgs_maybe, + TypeOrKind(..), isTypeLevel, isKindLevel, + pprCtOrigin, pprCtLoc, pushErrCtxt, pushErrCtxtSameOrigin, SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, - CtEvidence(..), - mkGivenLoc, + CtEvidence(..), TcEvDest(..), + mkGivenLoc, mkKindLoc, toKindLoc, isWanted, isGiven, isDerived, ctEvRole, @@ -122,6 +131,7 @@ import Type import CoAxiom ( Role ) import Class ( Class ) import TyCon ( TyCon ) +import Coercion ( Coercion, mkHoleCo ) import ConLike ( ConLike(..) ) import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) import PatSyn ( PatSyn, patSynType ) @@ -139,6 +149,7 @@ import NameEnv import NameSet import Avail import Var +import FV import VarEnv import Module import SrcLoc @@ -261,7 +272,6 @@ data IfLclEnv -- plus which bit is currently being examined if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings - -- (and coercions) if_id_env :: UniqFM Id -- Nested id binding } @@ -686,7 +696,7 @@ data TcLclEnv -- Changes as we move inside an expression -- Namely, the in-scope TyVars bound in tcl_env, -- plus the tyvars mentioned in the types of Ids bound -- in tcl_lenv. - -- Why mutable? see notes with tcGetGlobalTyVars + -- Why mutable? see notes with tcGetGlobalTyCoVars tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints tcl_errs :: TcRef Messages -- Place to accumulate errors @@ -877,6 +887,8 @@ data PromotionErr | RecDataConPE -- Data constructor in a recursive loop -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls | NoDataKinds -- -XDataKinds not enabled + | NoTypeInTypeTC -- -XTypeInType not enabled (for a tycon) + | NoTypeInTypeDC -- -XTypeInType not enabled (for a datacon) instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = pprTyThing g @@ -889,11 +901,13 @@ instance Outputable TcTyThing where -- Debugging only ppr (APromotionErr err) = text "APromotionErr" <+> ppr err instance Outputable PromotionErr where - ppr ClassPE = text "ClassPE" - ppr TyConPE = text "TyConPE" - ppr FamDataConPE = text "FamDataConPE" - ppr RecDataConPE = text "RecDataConPE" - ppr NoDataKinds = text "NoDataKinds" + ppr ClassPE = text "ClassPE" + ppr TyConPE = text "TyConPE" + ppr FamDataConPE = text "FamDataConPE" + ppr RecDataConPE = text "RecDataConPE" + ppr NoDataKinds = text "NoDataKinds" + ppr NoTypeInTypeTC = text "NoTypeInTypeTC" + ppr NoTypeInTypeDC = text "NoTypeInTypeDC" pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing @@ -903,11 +917,13 @@ pprTcTyThingCategory (AThing {}) = ptext (sLit "Kinded thing") pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe pprPECategory :: PromotionErr -> SDoc -pprPECategory ClassPE = ptext (sLit "Class") -pprPECategory TyConPE = ptext (sLit "Type constructor") -pprPECategory FamDataConPE = ptext (sLit "Data constructor") -pprPECategory RecDataConPE = ptext (sLit "Data constructor") -pprPECategory NoDataKinds = ptext (sLit "Data constructor") +pprPECategory ClassPE = ptext (sLit "Class") +pprPECategory TyConPE = ptext (sLit "Type constructor") +pprPECategory FamDataConPE = ptext (sLit "Data constructor") +pprPECategory RecDataConPE = ptext (sLit "Data constructor") +pprPECategory NoDataKinds = ptext (sLit "Data constructor") +pprPECategory NoTypeInTypeTC = ptext (sLit "Type constructor") +pprPECategory NoTypeInTypeDC = ptext (sLit "Data constructor") {- Note [Bindings with closed types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1187,7 +1203,7 @@ instance Outputable TcIdSigInfo where ppr (TISI { sig_bndr = bndr, sig_skols = tyvars , sig_theta = theta, sig_tau = tau }) = ppr (tcIdSigBndrName bndr) <+> dcolon <+> - vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau) + vcat [ pprSigmaType (mkInvSigmaTy (map snd tyvars) theta tau) , ppr (map fst tyvars) ] instance Outputable TcIdSigBndr where @@ -1341,16 +1357,17 @@ data Ct -- * tv not in tvs(rhs) (occurs check) -- * If tv is a TauTv, then rhs has no foralls -- (this avoids substituting a forall for the tyvar in other types) - -- * typeKind ty `subKind` typeKind tv - -- See Note [Kind orientation for CTyEqCan] - -- * rhs is not necessarily function-free, + -- * typeKind ty `tcEqKind` typeKind tv + -- * rhs may have at most one top-level cast + -- * rhs (perhaps under the one cast) is not necessarily function-free, -- but it has no top-level function. -- E.g. a ~ [F b] is fine -- but a ~ F b is not -- * If the equality is representational, rhs has no top-level newtype -- See Note [No top-level newtypes on RHS of representational -- equalities] in TcCanonical - -- * If rhs is also a tv, then it is oriented to give best chance of + -- * If rhs (perhaps under the cast) is also a tv, then it is oriented + -- to give best chance of -- unification happening; eg if rhs is touchable then lhs is too cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_tyvar :: TcTyVar, @@ -1377,7 +1394,7 @@ data Ct -- See Note [The flattening story] in TcFlatten } - | CNonCanonical { -- See Note [NonCanonical Semantics] + | CNonCanonical { -- See Note [NonCanonical Semantics] in TcSMonad cc_ev :: CtEvidence } @@ -1406,51 +1423,6 @@ distinguished by cc_hole: e.g. f :: _ -> _ f x = [x,True] -Note [Kind orientation for CTyEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given an equality (t:* ~ s:Open), we can't solve it by updating t:=s, -ragardless of how touchable 't' is, because the kinds don't work. - -Instead we absolutely must re-orient it. Reason: if that gets into the -inert set we'll start replacing t's by s's, and that might make a -kind-correct type into a kind error. After re-orienting, -we may be able to solve by updating s:=t. - -Hence in a CTyEqCan, (t:k1 ~ xi:k2) we require that k2 is a subkind of k1. - -If the two have incompatible kinds, we just don't use a CTyEqCan at all. -See Note [Equalities with incompatible kinds] in TcCanonical - -We can't require *equal* kinds, because - * wanted constraints don't necessarily have identical kinds - eg alpha::? ~ Int - * a solved wanted constraint becomes a given - -Note [Kind orientation for CFunEqCan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For (F xis ~ rhs) we require that kind(lhs) is a subkind of kind(rhs). -This really only maters when rhs is an Open type variable (since only type -variables have Open kinds): - F ty ~ (a:Open) -which can happen, say, from - f :: F a b - f = undefined -- The a:Open comes from instantiating 'undefined' - -Note that the kind invariant is maintained by rewriting. -Eg wanted1 rewrites wanted2; if both were compatible kinds before, - wanted2 will be afterwards. Similarly givens. - -Caveat: - - Givens from higher-rank, such as: - type family T b :: * -> * -> * - type instance T Bool = (->) - - f :: forall a. ((T a ~ (->)) => ...) -> a -> ... - flop = f (...) True - Whereas we would be able to apply the type instance, we would not be able to - use the given (T Bool ~ (->)) in the body of 'flop' - - Note [CIrredEvCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CIrredEvCan constraints are used for constraints that are "stuck" @@ -1476,7 +1448,7 @@ of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, This holds by construction; look at the unique place where CDictCan is built (in TcCanonical). -In contrast, the type of the evidence *term* (ccev_evtm or ctev_evar) in +In contrast, the type of the evidence *term* (ccev_evtm or ctev_evar/dest) in the evidence may *not* be fully zonked; we are careful not to look at it during constraint solving. See Note [Evidence field of CtEvidence] -} @@ -1503,6 +1475,26 @@ ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] ctPred ct = ctEvPred (cc_ev ct) +-- | Convert a Wanted to a Derived +toDerivedCt :: Ct -> Ct +toDerivedCt ct + = case ctEvidence ct of + CtWanted { ctev_pred = pred, ctev_loc = loc } + -> ct {cc_ev = CtDerived {ctev_pred = pred, ctev_loc = loc}} + + CtDerived {} -> ct + CtGiven {} -> pprPanic "to_derived" (ppr ct) + +-- | Makes a new equality predicate with the same role as the given +-- evidence. +mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType +mkTcEqPredLikeEv ev + = case predTypeEqRel pred of + NomEq -> mkPrimEqPred + ReprEq -> mkReprPrimEqPred + where + pred = ctEvPred ev + -- | Get the flavour of the given 'Ct' ctFlavour :: Ct -> CtFlavour ctFlavour = ctEvFlavour . ctEvidence @@ -1518,6 +1510,70 @@ dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols }) , wc_insol = dropDerivedInsols insols } -- The wc_impl implications are already (recursively) filtered +{- +************************************************************************ +* * + Simple functions over evidence variables +* * +************************************************************************ +-} + +---------------- Getting free tyvars ------------------------- + +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCt :: Ct -> TcTyCoVarSet +tyCoVarsOfCt = runFVSet . tyCoVarsOfCtAcc + +-- | Returns free variables of constraints as a deterministically ordered. +-- list. See Note [Deterministic FV] in FV. +tyCoVarsOfCtList :: Ct -> [TcTyCoVar] +tyCoVarsOfCtList = runFVList . tyCoVarsOfCtAcc + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in FV. +tyCoVarsOfCtAcc :: Ct -> FV +tyCoVarsOfCtAcc (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) + = tyCoVarsOfTypeAcc xi `unionFV` oneVar tv `unionFV` tyCoVarsOfTypeAcc (tyVarKind tv) +tyCoVarsOfCtAcc (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) + = tyCoVarsOfTypesAcc tys `unionFV` oneVar fsk `unionFV` tyCoVarsOfTypeAcc (tyVarKind fsk) +tyCoVarsOfCtAcc (CDictCan { cc_tyargs = tys }) = tyCoVarsOfTypesAcc tys +tyCoVarsOfCtAcc (CIrredEvCan { cc_ev = ev }) = tyCoVarsOfTypeAcc (ctEvPred ev) +tyCoVarsOfCtAcc (CHoleCan { cc_ev = ev }) = tyCoVarsOfTypeAcc (ctEvPred ev) +tyCoVarsOfCtAcc (CNonCanonical { cc_ev = ev }) = tyCoVarsOfTypeAcc (ctEvPred ev) + +-- | Returns free variables of a bag of constraints as a non-deterministic +-- set. See Note [Deterministic FV] in FV. +tyCoVarsOfCts :: Cts -> TcTyCoVarSet +tyCoVarsOfCts = runFVSet . tyCoVarsOfCtsAcc + +-- | Returns free variables of a bag of constraints as a deterministically +-- odered list. See Note [Deterministic FV] in FV. +tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] +tyCoVarsOfCtsList = runFVList . tyCoVarsOfCtsAcc + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in FV. +tyCoVarsOfCtsAcc :: Cts -> FV +tyCoVarsOfCtsAcc = foldrBag (unionFV . tyCoVarsOfCtAcc) noVars + +tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol }) + = tyCoVarsOfCts simple `unionVarSet` + tyCoVarsOfBag tyCoVarsOfImplic implic `unionVarSet` + tyCoVarsOfCts insol + +tyCoVarsOfImplic :: Implication -> TyCoVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoVarsOfImplic (Implic { ic_skols = skols + , ic_given = givens, ic_wanted = wanted }) + = (tyCoVarsOfWC wanted `unionVarSet` tyCoVarsOfTypes (map evVarPred givens)) + `delVarSetList` skols + +tyCoVarsOfBag :: (a -> TyCoVarSet) -> Bag a -> TyCoVarSet +tyCoVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet + +-------------------------- dropDerivedSimples :: Cts -> Cts dropDerivedSimples simples = filterBag isWantedCt simples -- simples are all Wanted or Derived @@ -1764,6 +1820,16 @@ andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 }) unionsWC :: [WantedConstraints] -> WantedConstraints unionsWC = foldr andWC emptyWC +-- | Convert all Wanteds into Deriveds (ignoring insolubles) +toDerivedWC :: WantedConstraints -> WantedConstraints +toDerivedWC wc@(WC { wc_simple = simples, wc_impl = implics }) + = wc { wc_simple = mapBag toDerivedCt simples + , wc_impl = mapBag to_derived_implic implics } + where + to_derived_implic implic@(Implic { ic_wanted = inner_wanted }) + = implic { ic_wanted = toDerivedWC inner_wanted } + + addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints addSimples wc cts = wc { wc_simple = wc_simple wc `unionBags` cts } @@ -1841,8 +1907,12 @@ data Implication ic_wanted :: WantedConstraints, -- The wanted - ic_binds :: EvBindsVar, -- Points to the place to fill in the - -- abstraction and bindings + ic_binds :: Maybe EvBindsVar, + -- Points to the place to fill in the + -- abstraction and bindings. + -- is Nothing if we can't deal with + -- non-equality constraints here + -- (this happens in TcS.deferTcSForAllEq) ic_status :: ImplicStatus } @@ -1971,8 +2041,8 @@ pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) Note [Evidence field of CtEvidence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During constraint solving we never look at the type of ctev_evar; -instead we look at the cte_pred field. The evtm/evar field +During constraint solving we never look at the type of ctev_evar/ctev_dest; +instead we look at the ctev_pred field. The evtm/evar field may be un-zonked. Note [Bind new Givens immediately] @@ -2000,6 +2070,10 @@ For Givens we make new EvVars and bind them immediately. Two main reasons: So a Given has EvVar inside it rather that (as previously) an EvTerm. -} +-- | A place for type-checking evidence to go after it is generated. +data TcEvDest + = EvVarDest EvVar -- ^ bind this var to the evidence + | HoleDest CoercionHole -- ^ fill in this hole with the evidence data CtEvidence = CtGiven { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] @@ -2009,7 +2083,7 @@ data CtEvidence -- NB: Spontaneous unifications belong here | CtWanted { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] + , ctev_dest :: TcEvDest , ctev_loc :: CtLoc } -- Wanted goal @@ -2038,20 +2112,30 @@ ctEvRole :: CtEvidence -> Role ctEvRole = eqRelRole . ctEvEqRel ctEvTerm :: CtEvidence -> EvTerm +ctEvTerm ev@(CtWanted { ctev_dest = HoleDest _ }) = EvCoercion $ ctEvCoercion ev ctEvTerm ev = EvId (ctEvId ev) -ctEvCoercion :: CtEvidence -> TcCoercion -ctEvCoercion ev = mkTcCoVarCo (ctEvId ev) +ctEvCoercion :: CtEvidence -> Coercion +ctEvCoercion ev@(CtWanted { ctev_dest = HoleDest hole, ctev_pred = pred }) + = case getEqPredTys_maybe pred of + Just (role, ty1, ty2) -> mkHoleCo hole role ty1 ty2 + _ -> pprPanic "ctEvTerm" (ppr ev) +ctEvCoercion (CtGiven { ctev_evar = ev_id }) = mkTcCoVarCo ev_id +ctEvCoercion ev = pprPanic "ctEvCoercion" (ppr ev) ctEvId :: CtEvidence -> TcId -ctEvId (CtWanted { ctev_evar = ev }) = ev +ctEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev ctEvId (CtGiven { ctev_evar = ev }) = ev ctEvId ctev = pprPanic "ctEvId:" (ppr ctev) +instance Outputable TcEvDest where + ppr (HoleDest h) = text "hole" <> ppr h + ppr (EvVarDest ev) = ppr ev + instance Outputable CtEvidence where ppr fl = case fl of CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evar fl) <+> ppr_pty - CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty + CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_dest fl) <+> ppr_pty CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty where ppr_pty = dcolon <+> ppr (ctEvPred fl) @@ -2093,14 +2177,15 @@ ctEvFlavour (CtGiven {}) = Given ctEvFlavour (CtDerived {}) = Derived -- | Whether or not one 'Ct' can rewrite another is determined by its --- flavour and its equality relation +-- flavour and its equality relation. See also +-- Note [Flavours with roles] in TcSMonad type CtFlavourRole = (CtFlavour, EqRel) --- | Extract the flavour and role from a 'CtEvidence' +-- | Extract the flavour, role, and boxity from a 'CtEvidence' ctEvFlavourRole :: CtEvidence -> CtFlavourRole ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) --- | Extract the flavour and role from a 'Ct' +-- | Extract the flavour, role, and boxity from a 'Ct' ctFlavourRole :: Ct -> CtFlavourRole ctFlavourRole = ctEvFlavourRole . cc_ev @@ -2172,30 +2257,30 @@ Definition [Can-rewrite relation] in TcSMonad. -} eqCanRewrite :: CtEvidence -> CtEvidence -> Bool -eqCanRewrite ev1 ev2 = ctEvFlavourRole ev1 `eqCanRewriteFR` ctEvFlavourRole ev2 +eqCanRewrite ev1 ev2 = eqCanRewriteFR (ctEvFlavourRole ev1) + (ctEvFlavourRole ev2) eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool -- Very important function! -- See Note [eqCanRewrite] -- See Note [Wanteds do not rewrite Wanteds] -- See Note [Deriveds do rewrite Deriveds] -eqCanRewriteFR (Given, NomEq) (_, _) = True -eqCanRewriteFR (Given, ReprEq) (_, ReprEq) = True -eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True -eqCanRewriteFR _ _ = False +eqCanRewriteFR (Given, NomEq) (_, _) = True +eqCanRewriteFR (Given, ReprEq) (_, ReprEq) = True +eqCanRewriteFR _ _ = False canDischarge :: CtEvidence -> CtEvidence -> Bool -- See Note [canDischarge] -canDischarge ev1 ev2 = ctEvFlavourRole ev1 `canDischargeFR` ctEvFlavourRole ev2 +canDischarge ev1 ev2 = canDischargeFR (ctEvFlavourRole ev1) + (ctEvFlavourRole ev2) canDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool canDischargeFR (_, ReprEq) (_, NomEq) = False -canDischargeFR (Given, _) _ = True -canDischargeFR (Wanted, _) (Wanted, _) = True -canDischargeFR (Wanted, _) (Derived, _) = True +canDischargeFR (Given, _) _ = True +canDischargeFR (Wanted, _) (Wanted, _) = True +canDischargeFR (Wanted, _) (Derived, _) = True canDischargeFR (Derived, _) (Derived, _) = True -canDischargeFR _ _ = False - +canDischargeFR _ _ = False {- ************************************************************************ @@ -2282,6 +2367,7 @@ type will evolve... data CtLoc = CtLoc { ctl_origin :: CtOrigin , ctl_env :: TcLclEnv + , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure , ctl_depth :: !SubGoalDepth } -- The TcLclEnv includes particularly -- source location: tcl_loc :: RealSrcSpan @@ -2293,8 +2379,19 @@ mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc mkGivenLoc tclvl skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info , ctl_env = env { tcl_tclvl = tclvl } + , ctl_t_or_k = Nothing -- this only matters for error msgs , ctl_depth = initialSubGoalDepth } +mkKindLoc :: TcType -> TcType -- original *types* being compared + -> CtLoc -> CtLoc +mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) + (KindEqOrigin s1 s2 (ctLocOrigin loc) + (ctLocTypeOrKind_maybe loc)) + +-- | Take a CtLoc and moves it to the kind level +toKindLoc :: CtLoc -> CtLoc +toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } + ctLocEnv :: CtLoc -> TcLclEnv ctLocEnv = ctl_env @@ -2310,6 +2407,9 @@ ctLocOrigin = ctl_origin ctLocSpan :: CtLoc -> RealSrcSpan ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl +ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind +ctLocTypeOrKind_maybe = ctl_t_or_k + setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (lcl { tcl_loc = loc }) @@ -2347,7 +2447,6 @@ data SkolemInfo Type -- a programmer-supplied type signature -- Location of the binding site is on the TyVar - -- The rest are for non-scoped skolems | ClsSkol Class -- Bound at a class decl | InstSkol -- Bound at an instance decl @@ -2407,7 +2506,7 @@ pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") , vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]] -pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkForAllTys tvs ty) +pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkInvForAllTys tvs ty) -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. @@ -2458,10 +2557,15 @@ data CtOrigin -- function or instance | TypeEqOrigin { uo_actual :: TcType - , uo_expected :: TcType } + , uo_expected :: TcType + , uo_thing :: Maybe ErrorThing + -- ^ The thing that has type "actual" + } + | KindEqOrigin TcType TcType -- A kind equality arising from unifying these two types CtOrigin -- originally arising from this + (Maybe TypeOrKind) -- the level of the eq this arises from | IPOccOrigin HsIPName -- Occurrence of an implicit parameter | OverLabelOrigin FastString -- Occurrence of an overloaded label @@ -2520,6 +2624,43 @@ data CtOrigin -- MonadFail Proposal (MFP). Obsolete when -- actual desugaring to MonadFail.fail is live. +-- | A thing that can be stored for error message generation only. +-- It is stored with a function to zonk and tidy the thing. +data ErrorThing + = forall a. Outputable a => ErrorThing a + (Maybe Arity) -- # of args, if known + (TidyEnv -> a -> TcM (TidyEnv, a)) + +-- | Flag to see whether we're type-checking terms or kind-checking types +data TypeOrKind = TypeLevel | KindLevel + deriving Eq + +instance Outputable TypeOrKind where + ppr TypeLevel = text "TypeLevel" + ppr KindLevel = text "KindLevel" + +isTypeLevel :: TypeOrKind -> Bool +isTypeLevel TypeLevel = True +isTypeLevel KindLevel = False + +isKindLevel :: TypeOrKind -> Bool +isKindLevel TypeLevel = False +isKindLevel KindLevel = True + +-- | Make an 'ErrorThing' that doesn't need tidying or zonking +mkErrorThing :: Outputable a => a -> ErrorThing +mkErrorThing thing = ErrorThing thing Nothing (\env x -> return (env, x)) + +-- | Retrieve the # of arguments in the error thing, if known +errorThingNumArgs_maybe :: ErrorThing -> Maybe Arity +errorThingNumArgs_maybe (ErrorThing _ args _) = args + +instance Outputable CtOrigin where + ppr = pprCtOrigin + +instance Outputable ErrorThing where + ppr (ErrorThing thing _ _) = ppr thing + ctoHerald :: SDoc ctoHerald = ptext (sLit "arising from") @@ -2553,7 +2694,7 @@ pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) , hang (ptext (sLit "instance") <+> quotes (ppr pred2)) 2 (ptext (sLit "at") <+> ppr loc2) ]) -pprCtOrigin (KindEqOrigin t1 t2 _) +pprCtOrigin (KindEqOrigin t1 t2 _ _) = hang (ctoHerald <+> ptext (sLit "a kind equality arising from")) 2 (sep [ppr t1, char '~', ppr t2]) @@ -2617,7 +2758,7 @@ pprCtO DefaultOrigin = ptext (sLit "a 'default' declaration") pprCtO DoOrigin = ptext (sLit "a do statement") pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = ptext (sLit "a proc expression") -pprCtO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] +pprCtO (TypeEqOrigin t1 t2 _)= ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] pprCtO AnnOrigin = ptext (sLit "an annotation") pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") pprCtO ListOrigin = ptext (sLit "an overloaded list") diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 0d1c6d5baa..d90b9a7305 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -6,6 +6,8 @@ TcRules: Typechecking transformation rules -} +{-# LANGUAGE ViewPatterns #-} + module TcRules ( tcRules ) where import HsSyn @@ -16,6 +18,7 @@ import TcType import TcHsType import TcExpr import TcEnv +import TcEvidence import TcUnify( buildImplicationFor ) import Type import Id @@ -57,7 +60,7 @@ tcRuleDecls (HsRules src decls) tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) = addErrCtxt (ruleCtxt $ snd $ unLoc name) $ - do { traceTc "---- Rule ------" (ppr name) + do { traceTc "---- Rule ------" (pprFullRuleName name) -- Note [Typechecking rules] ; (vars, bndr_wanted) <- captureConstraints $ @@ -76,9 +79,13 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty) ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) } - ; (lhs_evs, other_lhs_wanted) <- simplifyRule (snd $ unLoc name) - (bndr_wanted `andWC` lhs_wanted) - rhs_wanted + ; traceTc "tcRule 1" (vcat [ pprFullRuleName name + , ppr lhs_wanted + , ppr rhs_wanted ]) + ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted + ; lhs_evs <- simplifyRule (snd $ unLoc name) + all_lhs_wanted + rhs_wanted -- Now figure out what to quantify over -- c.f. TcSimplify.simplifyInfer @@ -92,13 +99,14 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- the LHS, lest they otherwise get defaulted to Any; but we do that -- during zonking (see TcHsSyn.zonkRule) - ; let tpl_ids = lhs_evs ++ id_bndrs - forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) - ; gbls <- tcGetGlobalTyVars -- Even though top level, there might be top-level + ; let tpl_ids = lhs_evs ++ id_bndrs + forall_tkvs = splitDepVarsOfTypes $ + rule_ty : map idType tpl_ids + ; gbls <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level -- monomorphic bindings from the MR; test tc111 - ; qtkvs <- quantifyTyVars gbls forall_tvs - ; traceTc "tcRule" (vcat [ doubleQuotes (ftext $ snd $ unLoc name) - , ppr forall_tvs + ; qtkvs <- quantifyTyVars gbls forall_tkvs + ; traceTc "tcRule" (vcat [ pprFullRuleName name + , ppr forall_tkvs , ppr qtkvs , ppr rule_ty , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] @@ -113,7 +121,10 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- (a) so that we report insoluble ones -- (b) so that we bind any soluble ones ; (lhs_implic, lhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs - lhs_evs other_lhs_wanted + lhs_evs + (all_lhs_wanted { wc_simple = emptyBag }) + -- simplifyRule consumed all simple + -- constraints ; emitImplications (lhs_implic `unionBags` rhs_implic) ; return (HsRule name act @@ -125,7 +136,7 @@ tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var] tcRuleBndrs [] = return [] tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs) - = do { ty <- newFlexiTyVarTy openTypeKind + = do { ty <- newOpenFlexiTyVarTy ; vars <- tcRuleBndrs rule_bndrs ; return (mkLocalId name ty : vars) } tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) @@ -133,12 +144,8 @@ tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a = do { let ctxt = RuleSigCtxt name - ; (id_ty, tv_prs, _) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalId name id_ty - tvs = map snd tv_prs - -- tcHsPatSigType returns (Name,TyVar) pairs - -- for for RuleSigCtxt their Names are not - -- cloned, so we get (n, tv-with-name-n) pairs + ; (id_ty, tvs, _) <- tcHsPatSigType ctxt rn_ty + ; let id = mkLocalIdOrCoVar name id_ty -- See Note [Pattern signature binders] in TcHsType -- The type variables scope over subsequent bindings; yuk @@ -269,50 +276,89 @@ Deciding which equalities to quantify over is tricky: The difficulty is that it's hard to tell what is insoluble! So we see whether the simplification step yielded any type errors, and if so refrain from quantifying over *any* equalities. + +Note [Quantifying over coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Equality constraints from the LHS will emit coercion hole Wanteds. +These don't have a name, so we can't quantify over them directly. +Instead, because we really do want to quantify here, invent a new +EvVar for the coercion, fill the hole with the invented EvVar, and +then quantify over the EvVar. Not too tricky -- just some +impedence matching, really. + +Note [Simplify *derived* constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this stage, we're simplifying constraints only for insolubility +and for unification. Note that all the evidence is quickly discarded. +We make this explicit by working over derived constraints, for which +there is no evidence. Using derived constraints also prevents solved +equalities from being written to coercion holes. If we don't do this, +then RHS coercion-hole constraints get filled in, only to get filled +in *again* when solving the implications emitted from tcRule. That's +terrible, so we avoid the problem by using derived constraints. + -} simplifyRule :: RuleName -> WantedConstraints -- Constraints from LHS -> WantedConstraints -- Constraints from RHS - -> TcM ([EvVar], WantedConstraints) -- LHS evidence variables --- See Note [Simplifying RULE constraints] --- --- This function could be in TcSimplify, but that's a very big --- module and this is a small one. Moreover, it's easier to --- understand tcRule when you can see simplifyRule too + -> TcM [EvVar] -- LHS evidence variables, +-- See Note [Simplifying RULE constraints] in TcRule +-- NB: This consumes all simple constraints on the LHS, but not +-- any LHS implication constraints. simplifyRule name lhs_wanted rhs_wanted = do { -- We allow ourselves to unify environment -- variables: runTcS runs with topTcLevel - tc_lvl <- getTcLevel - ; (insoluble, _) <- runTcS $ + ; tc_lvl <- getTcLevel + ; insoluble <- runTcSDeriveds $ do { -- First solve the LHS and *then* solve the RHS -- See Note [Solve order for RULES] - lhs_resid <- solveWanteds lhs_wanted - ; rhs_resid <- solveWanteds rhs_wanted - ; return (insolubleWC tc_lvl lhs_resid || insolubleWC tc_lvl rhs_resid) } - - ; zonked_lhs_simples <- zonkSimples (wc_simple lhs_wanted) - ; let (q_cts, non_q_cts) = partitionBag quantify_me zonked_lhs_simples - quantify_me -- Note [RULE quantification over equalities] - | insoluble = quantify_insol - | otherwise = quantify_normal + -- See Note [Simplify *derived* constraints] + lhs_resid <- solveWanteds $ toDerivedWC lhs_wanted + ; rhs_resid <- solveWanteds $ toDerivedWC rhs_wanted + ; return ( insolubleWC tc_lvl lhs_resid || + insolubleWC tc_lvl rhs_resid ) } - quantify_insol ct = not (isEqPred (ctPred ct)) - quantify_normal ct - | EqPred NomEq t1 t2 <- classifyPredType (ctPred ct) - = not (t1 `tcEqType` t2) - | otherwise - = True + ; zonked_lhs_simples <- zonkSimples (wc_simple lhs_wanted) + ; ev_ids <- mapMaybeM (quantify_ct insoluble) $ + bagToList zonked_lhs_simples ; traceTc "simplifyRule" $ vcat [ ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) , text "lhs_wantd" <+> ppr lhs_wanted , text "rhs_wantd" <+> ppr rhs_wanted , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples - , text "q_cts" <+> ppr q_cts - , text "non_q_cts" <+> ppr non_q_cts ] - - ; return ( map (ctEvId . ctEvidence) (bagToList q_cts) - , lhs_wanted { wc_simple = non_q_cts }) } - + , text "ev_ids" <+> ppr ev_ids + ] + + ; return ev_ids } + + where + quantify_ct insol -- Note [RULE quantification over equalities] + | insol = quantify_insol + | otherwise = quantify_normal + + quantify_insol ct + | isEqPred (ctPred ct) + = return Nothing + | otherwise + = return $ Just $ ctEvId $ ctEvidence ct + + quantify_normal (ctEvidence -> CtWanted { ctev_dest = dest + , ctev_pred = pred }) + = case dest of -- See Note [Quantifying over coercion holes] + HoleDest hole + | EqPred NomEq t1 t2 <- classifyPredType pred + , t1 `tcEqType` t2 + -> do { -- These are trivial. Don't quantify. But do fill in + -- the hole. + ; fillCoercionHole hole (mkTcNomReflCo t1) + ; return Nothing } + + | otherwise + -> do { ev_id <- newEvVar pred + ; fillCoercionHole hole (mkTcCoVarCo ev_id) + ; return (Just ev_id) } + EvVarDest evar -> return (Just evar) + quantify_normal ct = pprPanic "simplifyRule.quantify_normal" (ppr ct) diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index d9c56382a6..1cc7533d5a 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -12,8 +12,9 @@ module TcSMonad ( updWorkListTcS, -- The TcS monad - TcS, runTcS, runTcSWithEvBinds, - failTcS, tryTcS, nestTcS, nestImplicTcS, recoverTcS, + TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, failTcS, + runTcSEqualities, + nestTcS, nestImplicTcS, runTcPluginTcS, addUsedDataCons, deferTcSForAllEq, @@ -23,17 +24,22 @@ module TcSMonad ( wrapErrTcS, wrapWarnTcS, -- Evidence creation and transformation - Freshness(..), freshGoals, isFresh, + MaybeNew(..), freshGoals, isFresh, getEvTerm, - newTcEvBinds, newWantedEvVar, newWantedEvVarNC, newDerivedNC, + newTcEvBinds, + newWantedEq, + newWanted, newWantedEvVar, newWantedEvVarNC, newDerivedNC, + newBoundEvVarId, unifyTyVar, unflattenFmv, reportUnifications, - setEvBind, setWantedEvBind, setEvBindIfWanted, + setEvBind, setWantedEq, setEqIfWanted, + setWantedEvTerm, setWantedEvBind, setEvBindIfWanted, newEvVar, newGivenEvVar, newGivenEvVars, emitNewDerived, emitNewDeriveds, emitNewDerivedEq, checkReductionDepth, getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, getTcEvBinds, getTcLevel, + getTopEnv, getGblEnv, getLclEnv, + getTcEvBinds, getTcEvBindsFromVar, getTcLevel, getTcEvBindsMap, tcLookupClass, @@ -74,17 +80,18 @@ module TcSMonad ( -- Inert CFunEqCans updInertFunEqs, findFunEq, sizeFunEqMap, filterFunEqs, - findFunEqsByTyCon, findFunEqs, partitionFunEqs, foldFunEqs, + findFunEqsByTyCon, partitionFunEqs, foldFunEqs, instDFunType, -- Instantiation -- MetaTyVars - newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS, + newFlexiTcSTy, instFlexiTcS, cloneMetaTyVar, demoteUnfilledFmv, TcLevel, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe, isFilledMetaTyVar, - zonkTyVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkSimples, zonkWC, + zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, + zonkSimples, zonkWC, -- References newTcRef, readTcRef, updTcRef, @@ -117,6 +124,7 @@ import Kind import TcType import DynFlags import Type +import Coercion import Unify import TcEvidence @@ -139,11 +147,10 @@ import TcRnTypes import Unique import UniqFM -import Maybes ( orElse, firstJusts ) +import Maybes import TrieMap -import Control.Arrow ( first ) -import Control.Monad( ap, when, unless, MonadPlus(..) ) +import Control.Monad #if __GLASGOW_HASKELL__ > 710 import qualified Control.Monad.Fail as MonadFail #endif @@ -297,7 +304,8 @@ selectNextWorkItem ; try (selectWorkItem wl) $ do { ics <- getInertCans - ; if inert_count ics == 0 + ; solve_deriveds <- keepSolvingDeriveds + ; if inert_count ics == 0 && not solve_deriveds then return Nothing else try (selectDerivedWorkItem wl) (return Nothing) } } @@ -331,7 +339,7 @@ data InertSet -- Canonical Given, Wanted, Derived (no Solved) -- Sometimes called "the inert set" - , inert_flat_cache :: FunEqMap (TcCoercion, TcType, CtFlavour) + , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) -- See Note [Type family equations] -- If F tys :-> (co, ty, ev), -- then co :: F tys ~ ty @@ -343,6 +351,8 @@ data InertSet -- when allocating a new flatten-skolem. -- Not necessarily inert wrt top-level equations (or inert_cans) + -- NB: An ExactFunEqMap -- this doesn't match via loose types! + , inert_solved_dicts :: DictMap CtEvidence -- Of form ev :: C t1 .. tn -- See Note [Solved dictionaries] @@ -363,7 +373,7 @@ emptyInert , inert_irreds = emptyCts , inert_insols = emptyCts , inert_model = emptyVarEnv } - , inert_flat_cache = emptyFunEqs + , inert_flat_cache = emptyExactFunEqs , inert_solved_dicts = emptyDictMap } @@ -768,7 +778,7 @@ The idea is that TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed this but haven't done the empirical study to check. -* Assume we have G>=G, G>=W, D>=D, and that's all. Then, when performing +* Assume we have G>=G, G>=W and that's all. Then, when performing a unification we add a new given a -G-> ty. But doing so does NOT require us to kick out an inert wanted that mentions a, because of (K2a). This is a common case, hence good not to kick out. @@ -817,7 +827,7 @@ Key lemma to make it watertight. Under the conditions of the Main Theorem, forall f st fw >= f, a is not in S^k(f,t), for any k -Also, consider roles more carefully. See Note [Flavours with roles]. +Also, consider roles more carefully. See Note [Flavours with roles] Note [K3: completeness of solving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -897,12 +907,15 @@ they are not. E.g. Note [Flavours with roles] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -The system described in Note [The inert equalities] discusses an abstract -set of flavours. In GHC, flavours have two components: the flavour proper, -taken from {Wanted, Derived, Given}; and the equality relation (often called -role), taken from {NomEq, ReprEq}. When substituting w.r.t. the inert set, -as described in Note [The inert equalities], we must be careful to respect -roles. For example, if we have +The system described in Note [inert_eqs: the inert equalities] +discusses an abstract +set of flavours. In GHC, flavours have three components: the flavour proper, +taken from {Wanted, Derived, Given}; the equality relation (often called +role), taken from {NomEq, ReprEq}; and the levity, taken from {Lifted, Unlifted}. +When substituting w.r.t. the inert set, +as described in Note [inert_eqs: the inert equalities], +we must be careful to respect all components of a flavour. +For example, if we have inert set: a -G/R-> Int b -G/R-> Bool @@ -1130,7 +1143,7 @@ Note [Emitting shadow constraints] See modelCanRewrite. -NB the use of rewritableTyVars. ou might wonder whether, given the new +NB the use of rewritableTyVars. You might wonder whether, given the new constraint [D] fmv ~ ty and the inert [W] F alpha ~ fmv, do we want to emit a shadow constraint [D] F alpha ~ fmv? No, we don't, because it'll literally be a duplicate (since we do not rewrite the RHS of a @@ -1160,12 +1173,12 @@ eg in Trac #9587. addInertEq :: Ct -> TcS () -- This is a key function, because of the kick-out stuff -- Precondition: item /is/ canonical -addInertEq ct@(CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel, cc_tyvar = tv }) +addInertEq ct@(CTyEqCan { cc_tyvar = tv }) = do { traceTcS "addInertEq {" $ text "Adding new inert equality:" <+> ppr ct ; ics <- getInertCans - ; let (kicked_out, ics1) = kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics + ; let (kicked_out, ics1) = kickOutRewritable (ctFlavourRole ct) tv ics ; ics2 <- add_inert_eq ics1 ct ; setInertCans ics2 @@ -1184,7 +1197,8 @@ add_inert_eq :: InertCans -> Ct -> TcS InertCans add_inert_eq ics@(IC { inert_count = n , inert_eqs = old_eqs , inert_model = old_model }) - ct@(CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel, cc_tyvar = tv }) + ct@(CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel, cc_tyvar = tv + , cc_rhs = rhs }) | isDerived ev = do { emitDerivedShadows ics tv ; return (ics { inert_model = extendVarEnv old_model tv ct }) } @@ -1194,8 +1208,8 @@ add_inert_eq ics@(IC { inert_count = n -- Nominal equality (tv ~N ty), Given/Wanted -- See Note [Emitting shadow constraints] - | modelCanRewrite old_model rw_tvs -- Shadow of new constraint is - = do { emitNewDerivedEq loc pred -- not inert, so emit it + | modelCanRewrite old_model rw_tvs -- Shadow of new ct isn't inert; emit it + = do { emitNewDerivedEq loc (eqRelRole eq_rel) (mkTyVarTy tv) rhs ; return new_ics } | otherwise -- Shadow of new constraint is inert wrt model @@ -1206,7 +1220,7 @@ add_inert_eq ics@(IC { inert_count = n where loc = ctEvLoc ev pred = ctEvPred ev - rw_tvs = tyVarsOfType pred + rw_tvs = tyCoVarsOfType pred new_ics = ics { inert_eqs = addTyEq old_eqs tv ct , inert_count = bumpUnsolvedCount ev n } new_model = extendVarEnv old_model tv derived_ct @@ -1246,21 +1260,21 @@ emitDerivedShadows IC { inert_eqs = tv_eqs && not (modelCanRewrite model rw_tvs)-- We have not alrady created a -- shadow where - rw_tvs = rewritableTyVars ct + rw_tvs = rewritableTyCoVars ct -modelCanRewrite :: InertModel -> TcTyVarSet -> Bool +modelCanRewrite :: InertModel -> TcTyCoVarSet -> Bool -- See Note [Emitting shadow constraints] -- True if there is any intersection between dom(model) and tvs modelCanRewrite model tvs = not (disjointUFM model tvs) -- The low-level use of disjointUFM might e surprising. -- InertModel = TyVarEnv Ct, and we want to see if its domain - -- is disjoint from that of a TcTyVarSet. So we drop down + -- is disjoint from that of a TcTyCoVarSet. So we drop down -- to the underlying UniqFM. A bit yukky, but efficient. -rewritableTyVars :: Ct -> TcTyVarSet +rewritableTyCoVars :: Ct -> TcTyVarSet -- The tyvars of a Ct that can be rewritten -rewritableTyVars (CFunEqCan { cc_tyargs = tys }) = tyVarsOfTypes tys -rewritableTyVars ct = tyVarsOfType (ctPred ct) +rewritableTyCoVars (CFunEqCan { cc_tyargs = tys }) = tyCoVarsOfTypes tys +rewritableTyCoVars ct = tyCoVarsOfType (ctPred ct) -------------- addInertCan :: Ct -> TcS () -- Constraints *other than* equalities @@ -1275,7 +1289,7 @@ addInertCan ct -- See Note [Emitting shadow constraints] ; let ev = ctEvidence ct pred = ctEvPred ev - rw_tvs = rewritableTyVars ct + rw_tvs = rewritableTyCoVars ct ; when (not (isDerived ev) && modelCanRewrite (inert_model ics) rw_tvs) (emitNewDerived (ctEvLoc ev) pred) @@ -1311,8 +1325,8 @@ bumpUnsolvedCount ev n | isWanted ev = n+1 ----------------------------------------- -kickOutRewritable :: CtFlavourRole -- Flavour and role of the equality that is - -- being added to the inert set +kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that + -- is being added to the inert set -> TcTyVar -- The new equality is tv ~ ty -> InertCans -> (WorkList, InertCans) @@ -1371,8 +1385,8 @@ kickOutRewritable new_fr new_tv (IC { inert_eqs = tv_eqs (tv_eqs_out, tv_eqs_in) = foldVarEnv kick_out_eqs ([], emptyVarEnv) tv_eqs (feqs_out, feqs_in) = partitionFunEqs kick_out_fe funeqmap (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_irred irreds - (insols_out, insols_in) = partitionBag kick_out_ct insols + (irs_out, irs_in) = partitionBag kick_out_ct irreds + (insols_out, insols_in) = partitionBag kick_out_ct insols -- Kick out even insolubles; see Note [Kick out insolubles] fr_can_rewrite :: CtEvidence -> Bool @@ -1388,14 +1402,9 @@ kickOutRewritable new_fr new_tv (IC { inert_eqs = tv_eqs kick_out_ctev :: CtEvidence -> Bool kick_out_ctev ev = fr_can_rewrite ev - && new_tv `elemVarSet` tyVarsOfType (ctEvPred ev) + && new_tv `elemVarSet` tyCoVarsOfType (ctEvPred ev) -- See Note [Kicking out inert constraints] - kick_out_irred :: Ct -> Bool - kick_out_irred ct = fr_can_rewrite (cc_ev ct) - && new_tv `elemVarSet` closeOverKinds (TcM.tyVarsOfCt ct) - -- See Note [Kicking out Irreds] - kick_out_eqs :: EqualCtList -> ([Ct], TyVarEnv EqualCtList) -> ([Ct], TyVarEnv EqualCtList) kick_out_eqs eqs (acc_out, acc_in) @@ -1415,10 +1424,10 @@ kickOutRewritable new_fr new_tv (IC { inert_eqs = tv_eqs = check_k2 && check_k3 where fs = ctEvFlavourRole ev - check_k2 = not (fs `eqCanRewriteFR` fs) -- (K2a) - || (fs `eqCanRewriteFR` new_fr) -- (K2b) - || not (new_fr `eqCanRewriteFR` fs) -- (K2c) - || not (new_tv `elemVarSet` tyVarsOfType rhs_ty) -- (K2d) + check_k2 = not (fs `eqCanRewriteFR` fs) -- (K2a) + || (fs `eqCanRewriteFR` new_fr) -- (K2b) + || not (new_fr `eqCanRewriteFR` fs) -- (K2c) + || not (new_tv `elemVarSet` tyCoVarsOfType rhs_ty) -- (K2d) check_k3 | new_fr `eqCanRewriteFR` fs @@ -1435,7 +1444,8 @@ kickOutAfterUnification :: TcTyVar -> TcS Int kickOutAfterUnification new_tv = do { ics <- getInertCans ; let (kicked_out1, ics1) = kickOutModel new_tv ics - (kicked_out2, ics2) = kickOutRewritable (Given,NomEq) new_tv ics1 + (kicked_out2, ics2) = kickOutRewritable (Given,NomEq) + new_tv ics1 -- Given because the tv := xi is given; NomEq because -- only nominal equalities are solved by unification kicked_out = appendWorkList kicked_out1 kicked_out2 @@ -1458,7 +1468,7 @@ kickOutModel new_tv ics@(IC { inert_model = model, inert_eqs = eqs }) kick_out_der :: Ct -> Bool kick_out_der (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs }) - = new_tv == tv || new_tv `elemVarSet` tyVarsOfType rhs + = new_tv == tv || new_tv `elemVarSet` tyCoVarsOfType rhs kick_out_der _ = False add :: Ct -> WorkList -> WorkList @@ -1482,22 +1492,7 @@ the kind variables/ that are directly visible in the type. Hence we will have exposed all the rewriting we care about to make the most precise kinds visible for matching classes etc. No need to kick out constraints that mention type variables whose kinds contain this -variable! (Except see Note [Kicking out Irreds].) - -Note [Kicking out Irreds] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There is an awkward special case for Irreds. When we have a -kind-mis-matched equality constraint (a:k1) ~ (ty:k2), we turn it into -an Irred (see Note [Equalities with incompatible kinds] in -TcCanonical). So in this case the free kind variables of k1 and k2 -are not visible. More precisely, the type looks like - (~) k1 (a:k1) (ty:k2) -because (~) has kind forall k. k -> k -> Constraint. So the constraint -itself is ill-kinded. We can "see" k1 but not k2. That's why we use -closeOverKinds to make sure we see k2. - -This is not pretty. Maybe (~) should have kind - (~) :: forall k1 k1. k1 -> k2 -> Constraint +variable! Note [Kick out insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1622,7 +1617,6 @@ updInertIrreds :: (Cts -> Cts) -> TcS () updInertIrreds upd_fn = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } - getInertEqs :: TcS (TyVarEnv EqualCtList) getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } @@ -1883,12 +1877,14 @@ lookupFlatCache fam_tc tys lookup_flats flat_cache]) } where lookup_inerts inert_funeqs - | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk }) - <- findFunEqs inert_funeqs fam_tc tys + | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis }) + <- findFunEq inert_funeqs fam_tc tys + , tys `eqTypes` xis -- the lookup might find a near-match; see + -- Note [Use loose types in inert set] = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) | otherwise = Nothing - lookup_flats flat_cache = findFunEq flat_cache fam_tc tys + lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence) @@ -1901,12 +1897,16 @@ lookupInInerts pty | otherwise -- NB: No caching for equalities, IPs, holes, or errors = return Nothing +-- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not +-- match the input exactly. Note [Use loose types in inert set]. lookupInertDict :: InertCans -> Class -> [Type] -> Maybe CtEvidence lookupInertDict (IC { inert_dicts = dicts }) cls tys = case findDict dicts cls tys of Just ct -> Just (ctEvidence ct) _ -> Nothing +-- | Look up a solved inert. NB: the returned 'CtEvidence' might not +-- match the input exactly. See Note [Use loose types in inert set]. lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence -- Returns just if exactly this predicate type exists in the solved. lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys @@ -1964,10 +1964,24 @@ delTyEq m tv t = modifyVarEnv (filter (not . isThisOne)) m tv * * TcAppMap * * -********************************************************************* -} +************************************************************************ -type TcAppMap a = UniqFM (ListMap TypeMap a) - -- Indexed by tycon then the arg types +Note [Use loose types in inert set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly +solvable from the other. So, we do lookup in the inert set using +loose types, which omit the kind-check. + +We must be careful when using the result of a lookup because it may +not match the requsted info exactly! + +-} + +type TcAppMap a = UniqFM (ListMap LooseTypeMap a) + -- Indexed by tycon then the arg types, using "loose" matching, where + -- we don't require kind equality. This allows, for example, (a |> co) + -- to match (a). + -- See Note [Use loose types in inert set] -- Used for types and classes; hence UniqFM isEmptyTcAppMap :: TcAppMap a -> Bool @@ -2086,9 +2100,6 @@ sizeFunEqMap m = foldFunEqs (\ _ x -> x+1) m 0 findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a findFunEq m tc tys = findTcApp m (getUnique tc) tys -findFunEqs :: FunEqMap a -> TyCon -> [Type] -> Maybe a -findFunEqs m tc tys = findTcApp m (getUnique tc) tys - funEqsToBag :: FunEqMap a -> Bag a funEqsToBag m = foldTcAppMap consBag m emptyBag @@ -2134,6 +2145,20 @@ partitionFunEqs f m = (yeses, foldr del m yeses) delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a delFunEq m tc tys = delTcApp m (getUnique tc) tys +------------------------------ +type ExactFunEqMap a = UniqFM (ListMap TypeMap a) + +emptyExactFunEqs :: ExactFunEqMap a +emptyExactFunEqs = emptyUFM + +findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a +findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc) + ; lookupTM tys tys_map } + +insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a +insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc) + where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM)) + {- ************************************************************************ * * @@ -2157,19 +2182,30 @@ added. This is initialised from the innermost implication constraint. data TcSEnv = TcSEnv { - tcs_ev_binds :: EvBindsVar, + tcs_ev_binds :: Maybe EvBindsVar, + -- this could be Nothing if we can't deal with non-equality + -- constraints, because, say, we're in a top-level type signature - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero + tcs_unified :: IORef Int, + -- The number of unification variables we have filled + -- The important thing is whether it is non-zero - tcs_count :: IORef Int, -- Global step count + tcs_count :: IORef Int, -- Global step count tcs_inerts :: IORef InertSet, -- Current inert set -- The main work-list and the flattening worklist -- See Note [Work list priorities] and - tcs_worklist :: IORef WorkList -- Current worklist + tcs_worklist :: IORef WorkList, -- Current worklist + + tcs_used_tcvs :: IORef TyCoVarSet, + -- these variables were used when filling holes. Don't discard! + -- See also Note [Tracking redundant constraints] in TcSimplify + + tcs_need_deriveds :: Bool + -- should we keep trying to solve even if all the unsolved + -- constraints are Derived? Usually False, but used whenever + -- toDerivedWC is used. } --------------- @@ -2221,7 +2257,7 @@ traceTcS :: String -> SDoc -> TcS () traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) runTcPluginTcS :: TcPluginM a -> TcS a -runTcPluginTcS m = wrapTcS . runTcPluginM m . Just =<< getTcEvBinds +runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBinds instance HasDynFlags TcS where getDynFlags = wrapTcS getDynFlags @@ -2234,6 +2270,11 @@ bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env ; n <- TcM.readTcRef ref ; TcM.writeTcRef ref (n+1) } +-- | Mark variables as used filling a coercion hole +useVars :: TyCoVarSet -> TcS () +useVars vars = TcS $ \env -> do { let ref = tcs_used_tcvs env + ; TcM.updTcRef ref (`unionVarSet` vars) } + csTraceTcS :: SDoc -> TcS () csTraceTcS doc = wrapTcS $ csTraceTcM 1 (return doc) @@ -2259,27 +2300,44 @@ csTraceTcM trace_level mk_doc ; TcM.traceTcRn Opt_D_dump_cs_trace msg } } runTcS :: TcS a -- What to run - -> TcM (a, Bag EvBind) + -> TcM (a, EvBindMap) runTcS tcs = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; res <- runTcSWithEvBinds False (Just ev_binds_var) tcs + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; return (res, ev_binds) } -runTcSWithEvBinds :: EvBindsVar +-- | This variant of 'runTcS' will keep solving, even when only Deriveds +-- are left around. It also doesn't return any evidence, as callers won't +-- need it. +runTcSDeriveds :: TcS a -> TcM a +runTcSDeriveds tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds True (Just ev_binds_var) tcs } + +-- | This can deal only with equality constraints. +runTcSEqualities :: TcS a -> TcM a +runTcSEqualities = runTcSWithEvBinds False Nothing + +runTcSWithEvBinds :: Bool -- ^ keep running even if only Deriveds are left? + -> Maybe EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds ev_binds_var tcs +runTcSWithEvBinds solve_deriveds ev_binds_var tcs = do { unified_var <- TcM.newTcRef 0 ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef is + ; inert_var <- TcM.newTcRef emptyInert ; wl_var <- TcM.newTcRef emptyWorkList + ; used_var <- TcM.newTcRef emptyVarSet -- never read from, but see + -- nestImplicTcS - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_count = step_count - , tcs_inerts = inert_var - , tcs_worklist = wl_var } + ; let env = TcSEnv { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_count = step_count + , tcs_inerts = inert_var + , tcs_worklist = wl_var + , tcs_used_tcvs = used_var + , tcs_need_deriveds = solve_deriveds } -- Run the computation ; res <- unTcS tcs env @@ -2289,13 +2347,12 @@ runTcSWithEvBinds ev_binds_var tcs csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count) #ifdef DEBUG - ; ev_binds <- TcM.getTcEvBinds ev_binds_var - ; checkForCyclicBinds ev_binds + ; whenIsJust ev_binds_var $ \ebv -> + do { ev_binds <- TcM.getTcEvBinds ebv + ; checkForCyclicBinds ev_binds } #endif ; return res } - where - is = emptyInert #ifdef DEBUG checkForCyclicBinds :: Bag EvBind -> TcM () @@ -2311,38 +2368,60 @@ checkForCyclicBinds ev_binds cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges] coercion_cycles = [c | c <- cycles, any is_co_bind c] - is_co_bind (EvBind { eb_lhs = b }) = isEqVar b + is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b) edges :: [(EvBind, EvVar, [EvVar])] - edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) - | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs }) <- bagToList ev_binds] + edges = [ (bind, bndr, varSetElems (evVarsOfTerm rhs)) + | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] #endif -nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a -nestImplicTcS ref inner_tclvl (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = inerts { inert_flat_cache = emptyFunEqs } - -- See Note [Do not inherit the flat cache] - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_count = count - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env +nestImplicTcS :: Maybe EvBindsVar -> TyCoVarSet -- bound in this implication + -> TcLevel -> TcS a + -> TcS (a, TyCoVarSet) -- also returns any vars used when filling + -- coercion holes (for redundant-constraint + -- tracking) +nestImplicTcS m_ref bound_tcvs inner_tclvl (TcS thing_inside) + = do { (res, used_tcvs) <- + TcS $ \ TcSEnv { tcs_unified = unified_var + , tcs_inerts = old_inert_var + , tcs_count = count + , tcs_need_deriveds = solve_deriveds + } -> + do { inerts <- TcM.readTcRef old_inert_var + ; let nest_inert = inerts { inert_flat_cache = emptyExactFunEqs } + -- See Note [Do not inherit the flat cache] + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; new_used_var <- TcM.newTcRef emptyVarSet + ; let nest_env = TcSEnv { tcs_ev_binds = m_ref + , tcs_unified = unified_var + , tcs_count = count + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var + , tcs_used_tcvs = new_used_var + , tcs_need_deriveds = solve_deriveds } + ; res <- TcM.setTcLevel inner_tclvl $ + thing_inside nest_env #ifdef DEBUG - -- Perform a check that the thing_inside did not cause cycles - ; ev_binds <- TcM.getTcEvBinds ref - ; checkForCyclicBinds ev_binds + -- Perform a check that the thing_inside did not cause cycles + ; whenIsJust m_ref $ \ ref -> + do { ev_binds <- TcM.getTcEvBinds ref + ; checkForCyclicBinds ev_binds } #endif + ; used_tcvs <- TcM.readTcRef new_used_var + ; return (res, used_tcvs) } - ; return res } + ; local_ev_vars <- case m_ref of + Nothing -> return emptyVarSet + Just ref -> do { binds <- wrapTcS $ TcM.getTcEvBinds ref + ; return $ mkVarSet $ map evBindVar $ bagToList binds } + ; let all_locals = bound_tcvs `unionVarSet` local_ev_vars + (inner_used_tcvs, outer_used_tcvs) + = partitionVarSet (`elemVarSet` all_locals) used_tcvs + ; useVars outer_used_tcvs + + ; return (res, inner_used_tcvs) } {- Note [Do not inherit the flat cache] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2356,12 +2435,6 @@ flattened out after solving the outer level, but and we don't do that flattening recursively. -} - -recoverTcS :: TcS a -> TcS a -> TcS a -recoverTcS (TcS recovery_code) (TcS thing_inside) - = TcS $ \ env -> - TcM.recoverM (recovery_code env) (thing_inside env) - nestTcS :: TcS a -> TcS a -- Use the current untouchables, augmenting the current -- evidence bindings, and solved dictionaries @@ -2390,22 +2463,6 @@ nestTcS (TcS thing_inside) ; return res } -tryTcS :: TcS a -> TcS a --- Like runTcS, but from within the TcS monad --- Completely fresh inerts and worklist, be careful! --- Moreover, we will simply throw away all the evidence generated. -tryTcS (TcS thing_inside) - = TcS $ \env -> - do { is_var <- TcM.newTcRef emptyInert - ; unified_var <- TcM.newTcRef 0 - ; ev_binds_var <- TcM.newTcEvBinds - ; wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = env { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_inerts = is_var - , tcs_worklist = wl_var } - ; thing_inside nest_env } - {- Note [Propagate the solved dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2449,13 +2506,21 @@ updWorkListTcS f ; let new_work = f wl_curr ; wrapTcS (TcM.writeTcRef wl_var new_work) } +-- | Should we keep solving even only deriveds are left? +keepSolvingDeriveds :: TcS Bool +keepSolvingDeriveds = TcS (return . tcs_need_deriveds) + emitWorkNC :: [CtEvidence] -> TcS () emitWorkNC evs | null evs = return () | otherwise - = do { traceTcS "Emitting fresh work" (vcat (map ppr evs)) - ; updWorkListTcS (extendWorkListCts (map mkNonCanonical evs)) } + = emitWork (map mkNonCanonical evs) + +emitWork :: [Ct] -> TcS () +emitWork cts + = do { traceTcS "Emitting fresh work" (vcat (map ppr cts)) + ; updWorkListTcS (extendWorkListCts cts) } emitWorkCt :: Ct -> TcS () emitWorkCt ct @@ -2485,16 +2550,21 @@ readTcRef ref = wrapTcS (TcM.readTcRef ref) updTcRef :: TcRef a -> (a->a) -> TcS () updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) -getTcEvBinds :: TcS EvBindsVar +getTcEvBinds :: TcS (Maybe EvBindsVar) getTcEvBinds = TcS (return . tcs_ev_binds) +getTcEvBindsFromVar :: EvBindsVar -> TcS (Bag EvBind) +getTcEvBindsFromVar = wrapTcS . TcM.getTcEvBinds + getTcLevel :: TcS TcLevel getTcLevel = wrapTcS TcM.getTcLevel getTcEvBindsMap :: TcS EvBindMap getTcEvBindsMap - = do { EvBindsVar ev_ref _ <- getTcEvBinds - ; wrapTcS $ TcM.readTcRef ev_ref } + = do { ev_binds <- getTcEvBinds + ; case ev_binds of + Just (EvBindsVar ev_ref _) -> wrapTcS $ TcM.readTcRef ev_ref + Nothing -> return emptyEvBindMap } unifyTyVar :: TcTyVar -> TcType -> TcS () -- Unify a meta-tyvar with a type @@ -2506,7 +2576,7 @@ unifyTyVar tv ty TcS $ \ env -> do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) ; TcM.writeMetaTyVar tv ty - ; TcM.updTcRef (tcs_unified env) (+ 1) } + ; TcM.updTcRef (tcs_unified env) (+1) } unflattenFmv :: TcTyVar -> TcType -> TcS () -- Fill a flatten-meta-var, simply by unifying it. @@ -2523,8 +2593,8 @@ reportUnifications (TcS thing_inside) do { inner_unified <- TcM.newTcRef 0 ; res <- thing_inside (env { tcs_unified = inner_unified }) ; n_unifs <- TcM.readTcRef inner_unified - ; TcM.updTcRef (tcs_unified env) (+ n_unifs) -- Inner unifications affect - ; return (n_unifs, res) } -- the outer scope too + ; TcM.updTcRef (tcs_unified env) (+ n_unifs) + ; return (n_unifs, res) } getDefaultInfo :: TcS ([Type], (Bool, Bool)) getDefaultInfo = wrapTcS TcM.tcGetDefaultTys @@ -2578,8 +2648,7 @@ isTouchableMetaTyVarTcS tv isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) isFilledMetaTyVar_maybe tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_ref = ref } -> do { cts <- wrapTcS (TcM.readTcRef ref) ; case cts of @@ -2590,8 +2659,11 @@ isFilledMetaTyVar_maybe tv isFilledMetaTyVar :: TcTyVar -> TcS Bool isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) -zonkTyVarsAndFV :: TcTyVarSet -> TcS TcTyVarSet -zonkTyVarsAndFV tvs = wrapTcS (TcM.zonkTyVarsAndFV tvs) +zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet +zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs) + +zonkCo :: Coercion -> TcS Coercion +zonkCo = wrapTcS . TcM.zonkCo zonkTcType :: TcType -> TcS TcType zonkTcType ty = wrapTcS (TcM.zonkTcType ty) @@ -2663,22 +2735,23 @@ which will result in two Deriveds to end up in the insoluble set: -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ newFlattenSkolem :: CtFlavour -> CtLoc -> TcType -- F xis - -> TcS (CtEvidence, TcTyVar) -- [W] x:: F xis ~ fsk + -> TcS (CtEvidence, Coercion, TcTyVar) -- [W] x:: F xis ~ fsk newFlattenSkolem Given loc fam_ty = do { fsk <- newFsk fam_ty - ; ev <- newGivenEvVar loc (mkTcEqPred fam_ty (mkTyVarTy fsk), - EvCoercion (mkTcNomReflCo fam_ty)) - ; return (ev, fsk) } + ; let co = mkNomReflCo fam_ty + ; ev <- newGivenEvVar loc (mkPrimEqPred fam_ty (mkTyVarTy fsk), + EvCoercion co) + ; return (ev, co, fsk) } newFlattenSkolem Wanted loc fam_ty = do { fmv <- newFmv fam_ty - ; ev <- newWantedEvVarNC loc (mkTcEqPred fam_ty (mkTyVarTy fmv)) - ; return (ev, fmv) } + ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv) + ; return (ev, hole_co, fmv) } newFlattenSkolem Derived loc fam_ty = do { fmv <- newFmv fam_ty - ; ev <- newDerivedNC loc (mkTcEqPred fam_ty (mkTyVarTy fmv)) - ; return (ev, fmv) } + ; ev <- newDerivedNC loc (mkPrimEqPred fam_ty (mkTyVarTy fmv)) + ; return (ev, pprPanic "newFlattenSkolem [D]" (ppr fam_ty), fmv) } newFsk, newFmv :: TcType -> TcS TcTyVar newFsk fam_ty = wrapTcS (TcM.newFskTyVar fam_ty) @@ -2689,7 +2762,7 @@ extendFlatCache tc xi_args stuff = do { dflags <- getDynFlags ; when (gopt Opt_FlatCache dflags) $ updInertTcS $ \ is@(IS { inert_flat_cache = fc }) -> - is { inert_flat_cache = insertFunEq fc tc xi_args stuff } } + is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } -- Instantiations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2713,13 +2786,13 @@ demoteUnfilledFmv fmv do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv) ; TcM.writeMetaTyVar fmv tv_ty } } -instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType]) -instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) +instFlexiTcS :: [TKVar] -> TcS (TCvSubst, [TcType]) +instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTCvSubst tvs) where inst_one subst tv = do { ty' <- instFlexiTcSHelper (tyVarName tv) (substTy subst (tyVarKind tv)) - ; return (extendTvSubst subst tv ty', ty') } + ; return (extendTCvSubst subst tv ty', ty') } instFlexiTcSHelper :: Name -> Kind -> TcM TcType instFlexiTcSHelper tvname kind @@ -2728,26 +2801,50 @@ instFlexiTcSHelper tvname kind ; let name = setNameUnique tvname uniq ; return (mkTyVarTy (mkTcTyVar name kind details)) } -instFlexiTcSHelperTcS :: Name -> Kind -> TcS TcType -instFlexiTcSHelperTcS n k = wrapTcS (instFlexiTcSHelper n k) -- Creating and setting evidence variables and CtFlavors -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -data Freshness = Fresh | Cached +data MaybeNew = Fresh CtEvidence | Cached EvTerm + +isFresh :: MaybeNew -> Bool +isFresh (Fresh {}) = True +isFresh (Cached {}) = False -isFresh :: Freshness -> Bool -isFresh Fresh = True -isFresh Cached = False +freshGoals :: [MaybeNew] -> [CtEvidence] +freshGoals mns = [ ctev | Fresh ctev <- mns ] -freshGoals :: [(CtEvidence, Freshness)] -> [CtEvidence] -freshGoals mns = [ ctev | (ctev, Fresh) <- mns ] +getEvTerm :: MaybeNew -> EvTerm +getEvTerm (Fresh ctev) = ctEvTerm ctev +getEvTerm (Cached evt) = evt setEvBind :: EvBind -> TcS () setEvBind ev_bind = do { tc_evbinds <- getTcEvBinds - ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev_bind } + ; case tc_evbinds of + Just evb -> wrapTcS $ TcM.addTcEvBind evb ev_bind + Nothing -> pprPanic "setEvBind" (ppr ev_bind) } + +-- | Equalities only +setWantedEq :: TcEvDest -> Coercion -> TcS () +setWantedEq (HoleDest hole) co + = do { useVars (tyCoVarsOfCo co) + ; wrapTcS $ TcM.fillCoercionHole hole co } +setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev) + +-- | Equalities only +setEqIfWanted :: CtEvidence -> Coercion -> TcS () +setEqIfWanted (CtWanted { ctev_dest = dest }) co = setWantedEq dest co +setEqIfWanted _ _ = return () + +-- | Good for equalities and non-equalities +setWantedEvTerm :: TcEvDest -> EvTerm -> TcS () +setWantedEvTerm (HoleDest hole) tm + = do { let co = evTermCoercion tm + ; useVars (tyCoVarsOfCo co) + ; wrapTcS $ TcM.fillCoercionHole hole co } +setWantedEvTerm (EvVarDest ev) tm = setWantedEvBind ev tm setWantedEvBind :: EvVar -> EvTerm -> TcS () setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm) @@ -2755,8 +2852,9 @@ setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm) setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () setEvBindIfWanted ev tm = case ev of - CtWanted { ctev_evar = ev_id } -> setWantedEvBind ev_id tm - _ -> return () + CtWanted { ctev_dest = dest } + -> setWantedEvTerm dest tm + _ -> return () newTcEvBinds :: TcS EvBindsVar newTcEvBinds = wrapTcS TcM.newTcEvBinds @@ -2769,61 +2867,33 @@ newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence -- immediately bind it to the given term -- and return its CtEvidence -- See Note [Bind new Givens immediately] in TcRnTypes --- Precondition: this is not a kind equality --- See Note [Do not create Given kind equalities] newGivenEvVar loc (pred, rhs) - = ASSERT2( not (isKindEquality pred), ppr pred $$ pprCtOrigin (ctLocOrigin loc) ) - do { -- checkReductionDepth loc pred - ; new_ev <- newEvVar pred - ; setEvBind (mkGivenEvBind new_ev rhs) + = do { new_ev <- newBoundEvVarId pred rhs ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } +-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the +-- given term +newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar +newBoundEvVarId pred rhs + = do { new_ev <- newEvVar pred + ; setEvBind (mkGivenEvBind new_ev rhs) + ; return new_ev } + newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] --- Like newGivenEvVar, but automatically discard kind equalities --- See Note [Do not create Given kind equalities] -newGivenEvVars loc pts = mapM (newGivenEvVar loc) (filterOut (isKindEquality . fst) pts) - -isKindEquality :: TcPredType -> Bool --- See Note [Do not create Given kind equalities] -isKindEquality pred = case classifyPredType pred of - EqPred _ t1 _ -> isKind t1 - _ -> False - -{- Note [Do not create Given kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to create a Given kind equality like - - [G] kv ~ k -- kv is a skolem kind variable - -- Reason we don't yet support non-Refl kind equalities - -This showed up in Trac #8566, where we had a data type - data I (u :: U *) (r :: [*]) :: * where - A :: I (AA t as) r -- Existential k -so A has type - A :: forall (u:U *) (r:[*]) Universal - (k:BOX) (t:k) (as:[U *]). Existential - (u ~ AA * k t as) => I u r - -There is no direct kind equality, but in a pattern match where 'u' is -instantiated to, say, (AA * kk (t1:kk) as1), we'd decompose to get - k ~ kk, t ~ t1, as ~ as1 -This is bad. We "fix" this by simply ignoring the Given kind equality -But the Right Thing is to add kind equalities! - -But note (Trac #8705) that we *do* create Given (non-canonical) equalities -with un-equal kinds, e.g. - [G] t1::k1 ~ t2::k2 -- k1 and k2 are un-equal kinds -Reason: k1 or k2 might be unification variables that have already been -unified (at this point we have not canonicalised the types), so we want -to emit this t1~t2 as a (non-canonical) Given in the work-list. If k1/k2 -have been unified, we'll find that when we canonicalise it, and the -t1~t2 information may be crucial (Trac #8705 is an example). - -If it turns out that k1 and k2 are really un-equal, then it'll end up -as an Irreducible (see Note [Equalities with incompatible kinds] in -TcCanonical), and will do no harm. --} +newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts + +-- | Make a new equality CtEvidence +newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion) +newWantedEq loc role ty1 ty2 + = do { hole <- wrapTcS $ TcM.newCoercionHole + ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty) + ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole + , ctev_loc = loc} + , mkHoleCo hole role ty1 ty2 ) } + where + pty = mkPrimEqPredRole role ty1 ty2 +-- no equalities here. Use newWantedEqNC instead newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence -- Don't look up in the solved/inerts; we know it's not there newWantedEvVarNC loc pty @@ -2831,18 +2901,29 @@ newWantedEvVarNC loc pty ; new_ev <- newEvVar pty ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ pprCtLoc loc) - ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc })} + ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev + , ctev_loc = loc })} -newWantedEvVar :: CtLoc -> TcPredType -> TcS (CtEvidence, Freshness) +newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew -- For anything except ClassPred, this is the same as newWantedEvVarNC newWantedEvVar loc pty = do { mb_ct <- lookupInInerts pty ; case mb_ct of - Just ctev | not (isDerived ctev) - -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return (ctev, Cached) } + Just ctev + | not (isDerived ctev) + -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev + ; return $ Cached (ctEvTerm ctev) } _ -> do { ctev <- newWantedEvVarNC loc pty - ; return (ctev, Fresh) } } + ; return (Fresh ctev) } } + +-- deals with both equalities and non equalities. Tries to look +-- up non-equalities in the cache +newWanted :: CtLoc -> PredType -> TcS MaybeNew +newWanted loc pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = Fresh . fst <$> newWantedEq loc role ty1 ty2 + | otherwise + = newWantedEvVar loc pty emitNewDerived :: CtLoc -> TcPredType -> TcS () emitNewDerived loc pred @@ -2859,11 +2940,11 @@ emitNewDeriveds loc preds ; traceTcS "Emitting new deriveds" (ppr evs) ; updWorkListTcS (extendWorkListDeriveds loc evs) } -emitNewDerivedEq :: CtLoc -> TcPredType -> TcS () +emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS () -- Create new equality Derived and put it in the work list -- There's no caching, no lookupInInerts -emitNewDerivedEq loc pred - = do { ev <- newDerivedNC loc pred +emitNewDerivedEq loc role ty1 ty2 + = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2) ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc) ; updWorkListTcS (extendWorkListDerived loc ev) } @@ -2883,15 +2964,14 @@ checkReductionDepth loc ty wrapErrTcS $ solverDepthErrorTcS loc ty } -matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType)) +matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType)) matchFam tycon args = wrapTcS $ matchFamTcM tycon args -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (TcCoercion, TcType)) +matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType)) -- Given (F tys) return (ty, co), where co :: F tys ~ ty matchFamTcM tycon args = do { fam_envs <- FamInst.tcGetFamInstEnvs - ; return $ fmap (first TcCoercion) $ - reduceTyFamApp_maybe fam_envs Nominal tycon args } + ; return $ reduceTyFamApp_maybe fam_envs Nominal tycon args } {- Note [Residual implications] @@ -2910,43 +2990,37 @@ See TcSMonad.deferTcSForAllEq deferTcSForAllEq :: Role -- Nominal or Representational -> CtLoc -- Original wanted equality flavor - -> ([TyVar],TcType) -- ForAll tvs1 body1 - -> ([TyVar],TcType) -- ForAll tvs2 body2 - -> TcS EvTerm --- Some of this functionality is repeated from TcUnify, --- consider having a single place where we create fresh implications. -deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2) - = do { (subst1, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1 - ; let tys = mkTyVarTys skol_tvs - phi1 = Type.substTy subst1 body1 - phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 + -> [Coercion] -- among the kinds of the binders + -> ([TyBinder],TcType) -- ForAll tvs1 body1 + -> ([TyBinder],TcType) -- ForAll tvs2 body2 + -> TcS Coercion +deferTcSForAllEq role loc kind_cos (bndrs1,body1) (bndrs2,body2) + = do { let tvs1' = zipWithEqual "deferTcSForAllEq" + mkCastTy (mkTyVarTys tvs1) kind_cos + body2' = substTyWith tvs2 tvs1' body2 + ; (subst, skol_tvs) <- wrapTcS $ TcM.tcInstSkolTyVars tvs1 + ; let phi1 = Type.substTy subst body1 + phi2 = Type.substTy subst body2' skol_info = UnifyForAllSkol skol_tvs phi1 - eq_pred = case role of - Nominal -> mkTcEqPred phi1 phi2 - Representational -> mkCoerciblePred phi1 phi2 - Phantom -> panic "deferTcSForAllEq Phantom" - ; (ctev, freshness) <- newWantedEvVar loc eq_pred - ; coe_inside <- case freshness of - Cached -> return (ctEvCoercion ctev) - Fresh -> do { ev_binds_var <- newTcEvBinds - ; env <- getLclEnv - ; let ev_binds = TcEvBinds ev_binds_var - new_ct = mkNonCanonical ctev - new_co = ctEvCoercion ctev - new_tclvl = pushTcLevel (tcl_tclvl env) - ; let wc = WC { wc_simple = singleCt new_ct - , wc_impl = emptyBag - , wc_insol = emptyCts } - imp = Implic { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_given = [] - , ic_wanted = wc - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_env = env - , ic_info = skol_info } - ; updWorkListTcS (extendWorkListImplic imp) - ; return (TcLetCo ev_binds new_co) } - - ; return $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) } + + ; (ctev, hole_co) <- newWantedEq loc role phi1 phi2 + ; env <- getLclEnv + ; let new_tclvl = pushTcLevel (tcl_tclvl env) + wc = WC { wc_simple = singleCt (mkNonCanonical ctev) + , wc_impl = emptyBag + , wc_insol = emptyCts } + imp = Implic { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_no_eqs = True + , ic_given = [] + , ic_wanted = wc + , ic_status = IC_Unsolved + , ic_binds = Nothing -- no place to put binds + , ic_env = env + , ic_info = skol_info } + ; updWorkListTcS (extendWorkListImplic imp) + ; let cobndrs = zip skol_tvs kind_cos + ; return $ mkForAllCos cobndrs hole_co } + where + tvs1 = map (binderVar "deferTcSForAllEq") bndrs1 + tvs2 = map (binderVar "deferTcSForAllEq") bndrs2 diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 467ea9c2f0..11e71362cd 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -1,46 +1,43 @@ {-# LANGUAGE CPP #-} module TcSimplify( - simplifyInfer, - pickQuantifiablePreds, growThetaTyVars, + simplifyInfer, solveTopConstraints, + growThetaTyVars, simplifyAmbiguityCheck, simplifyDefault, - simplifyTop, simplifyInteractive, - solveWantedsTcM, + simplifyTop, simplifyInteractive, solveEqualities, + simplifyWantedsTcM, tcCheckSatisfiability, - -- For Rules we need these two - solveWanteds, runTcS + -- For Rules we need these + solveWanteds, runTcSDeriveds ) where #include "HsVersions.h" import Bag -import Class ( classKey ) -import Class ( Class ) +import Class ( Class, classKey, classTyCon ) import DynFlags ( ExtensionFlag( Opt_AllowAmbiguousTypes ) , WarningFlag ( Opt_WarnMonomorphism ) , DynFlags( solverIterations ) ) import Inst -import Id ( idType ) -import Kind ( isKind, isSubKind, defaultKind_maybe ) import ListSetOps -import Maybes ( isNothing ) +import Maybes import Name import Outputable +import Pair import PrelInfo import PrelNames import TcErrors import TcEvidence import TcInteract import TcMType as TcM -import TcRnMonad as TcRn +import TcRnMonad as TcM import TcSMonad as TcS import TcType import TrieMap () -- DV: for now -import TyCon ( isTypeFamilyTyCon ) -import Type ( classifyPredType, isIPClass, PredTree(..) - , getClassPredTys_maybe, EqRel(..) ) +import Type +import TysWiredIn ( liftedDataConTy ) import Unify ( tcMatchTy ) import Util import Var @@ -49,8 +46,13 @@ import BasicTypes ( IntWithInf, intGtLimit ) import ErrUtils ( emptyMessages ) import FastString -import Control.Monad ( unless ) +import Control.Monad ( when, unless ) import Data.List ( partition ) +import Data.Foldable ( fold ) + +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable ( traverse ) +#endif {- ********************************************************************************* @@ -80,20 +82,35 @@ simplifyTop wanteds -- update error messages which we'll grab and then restore saved -- messages. ; errs_var <- getErrsVar - ; saved_msg <- TcRn.readTcRef errs_var - ; TcRn.writeTcRef errs_var emptyMessages + ; saved_msg <- TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var emptyMessages ; warnAllUnsolved $ WC { wc_simple = unsafe_ol , wc_insol = emptyCts , wc_impl = emptyBag } - ; whyUnsafe <- fst <$> TcRn.readTcRef errs_var - ; TcRn.writeTcRef errs_var saved_msg + ; whyUnsafe <- fst <$> TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var saved_msg ; recordUnsafeInfer whyUnsafe } ; traceTc "reportUnsolved (unsafe overlapping) }" empty - ; return (binds1 `unionBags` binds2) } + ; return (evBindMapBinds binds1 `unionBags` binds2) } + +-- | Type-check a thing that emits only equality constraints, then +-- solve those constraints. Emits errors -- but does not fail -- +-- if there is trouble. +solveEqualities :: TcM a -> TcM a +solveEqualities thing_inside + = do { (result, wanted) <- captureConstraints thing_inside + ; traceTc "solveEqualities {" $ text "wanted = " <+> ppr wanted + ; (final_wc, _) <- runTcSEqualities $ simpl_top wanted + ; traceTc "End solveEqualities }" empty + + ; traceTc "reportAllUnsolved {" empty + ; reportAllUnsolved final_wc + ; traceTc "reportAllUnsolved }" empty + ; return result } type SafeOverlapFailures = Cts -- ^ See Note [Safe Haskell Overlapping Instances Implementation] @@ -114,19 +131,18 @@ simpl_top wanteds | isEmptyWC wc = return wc | otherwise - = do { free_tvs <- TcS.zonkTyVarsAndFV (tyVarsOfWC wc) + = do { free_tvs <- TcS.zonkTyCoVarsAndFV (tyCoVarsOfWC wc) ; let meta_tvs = varSetElems (filterVarSet isMetaTyVar free_tvs) - -- zonkTyVarsAndFV: the wc_first_go is not yet zonked + -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked -- filter isMetaTyVar: we might have runtime-skolems in GHCi, -- and we definitely don't want to try to assign to those! - ; meta_tvs' <- mapM defaultTyVar meta_tvs -- Has unification side effects - ; if meta_tvs' == meta_tvs -- No defaulting took place; - -- (defaulting returns fresh vars) - then try_class_defaulting wc - else do { wc_residual <- nestTcS (solveWantedsAndDrop wc) + ; defaulted <- mapM defaultTyVarTcS meta_tvs -- Has unification side effects + ; if or defaulted + then do { wc_residual <- nestTcS (solveWanteds wc) -- See Note [Must simplify after defaulting] - ; try_class_defaulting wc_residual } } + ; try_class_defaulting wc_residual } + else try_class_defaulting wc } -- No defaulting took place try_class_defaulting :: WantedConstraints -> TcS WantedConstraints try_class_defaulting wc @@ -140,6 +156,14 @@ simpl_top wanteds ; try_class_defaulting wc_residual } else return wc } +-- | Type-check a thing, returning the result and any EvBinds produced +-- during solving. Emits errors -- but does not fail -- if there is trouble. +solveTopConstraints :: TcM a -> TcM (a, Bag EvBind) +solveTopConstraints thing_inside + = do { (result, wanted) <- captureConstraints thing_inside + ; ev_binds <- simplifyTop wanted + ; return (result, ev_binds) } + {- Note [When to do type-class defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -325,7 +349,7 @@ How is this implemented? It's complicated! So we'll step through it all: simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () simplifyAmbiguityCheck ty wanteds = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds) - ; ((final_wc, _), _binds) <- runTcS $ simpl_top wanteds + ; ((final_wc, _), _) <- runTcS $ simpl_top wanteds ; traceTc "End simplifyAmbiguityCheck }" empty -- Normally report all errors; but with -XAllowAmbiguousTypes @@ -333,7 +357,7 @@ simplifyAmbiguityCheck ty wanteds -- inaccessible code ; allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes ; traceTc "reportUnsolved(ambig) {" empty - ; tc_lvl <- TcRn.getTcLevel + ; tc_lvl <- TcM.getTcLevel ; unless (allow_ambiguous && not (insolubleWC tc_lvl final_wc)) (discardResult (reportUnsolved final_wc)) ; traceTc "reportUnsolved(ambig) }" empty @@ -352,7 +376,7 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it simplifyDefault theta = do { traceTc "simplifyInteractive" empty ; wanted <- newWanteds DefaultOrigin theta - ; unsolved <- solveWantedsTcM wanted + ; unsolved <- simplifyWantedsTcM wanted ; traceTc "reportUnsolved {" empty -- See Note [Deferring coercion errors to runtime] @@ -365,7 +389,7 @@ simplifyDefault theta tcCheckSatisfiability :: Bag EvVar -> TcM Bool -- Return True if satisfiable, False if definitely contradictory tcCheckSatisfiability givens - = do { lcl_env <- TcRn.getLclEnv + = do { lcl_env <- TcM.getLclEnv ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env ; traceTc "checkSatisfiabilty {" (ppr givens) ; (res, _ev_binds) <- runTcS $ @@ -399,6 +423,7 @@ To infer f's type we do the following: This ensures that the implication constraint we generate, if any, has a strictly-increased level compared to the ambient level outside the let binding. + -} simplifyInfer :: TcLevel -- Used when generating the constraints @@ -412,8 +437,9 @@ simplifyInfer :: TcLevel -- Used when generating the constraints TcEvBinds) -- ... binding these evidence variables simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds | isEmptyWC wanteds - = do { gbl_tvs <- tcGetGlobalTyVars - ; qtkvs <- quantify_tvs sigs gbl_tvs (tyVarsOfTypes (map snd name_taus)) + = do { gbl_tvs <- tcGetGlobalTyCoVars + ; qtkvs <- quantify_tvs sigs gbl_tvs $ + splitDepVarsOfTypes (map snd name_taus) ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds) } @@ -437,7 +463,8 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds ; ev_binds_var <- TcM.newTcEvBinds ; wanted_transformed_incl_derivs <- setTcLevel rhs_tclvl $ do { sig_derived <- concatMapM mkSigDerivedWanteds sigs - ; runTcSWithEvBinds ev_binds_var $ + -- the False says we don't really need to solve all Deriveds + ; runTcSWithEvBinds False (Just ev_binds_var) $ solveWanteds (wanteds `addSimples` listToBag sig_derived) } ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs @@ -446,8 +473,7 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds -- NB: We do not do any defaulting when inferring a type, this can lead -- to less polymorphic types, see Note [Default while Inferring] - ; tc_lcl_env <- TcRn.getLclEnv - ; null_ev_binds_var <- TcM.newTcEvBinds + ; tc_lcl_env <- TcM.getLclEnv ; let wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs ; quant_pred_candidates -- Fully zonked <- if insolubleWC rhs_tclvl wanted_transformed_incl_derivs @@ -456,8 +482,9 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds -- hence "incl_derivs" else do { let quant_cand = approximateWC wanted_transformed - meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfCts quant_cand)) - ; gbl_tvs <- tcGetGlobalTyVars + meta_tvs = filter isMetaTyVar (varSetElems (tyCoVarsOfCts quant_cand)) + + ; gbl_tvs <- tcGetGlobalTyCoVars -- Miminise quant_cand. We are not interested in any evidence -- produced, because we are going to simplify wanted_transformed -- again later. All we want here are the predicates over which to @@ -466,30 +493,71 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds -- If any meta-tyvar unifications take place (unlikely), we'll -- pick that up later. + -- See Note [Promote _and_ default when inferring] + ; let def_tyvar tv + = when (not $ tv `elemVarSet` gbl_tvs) $ + defaultTyVar tv + ; mapM_ def_tyvar meta_tvs + ; mapM_ (promoteTyVar rhs_tclvl) meta_tvs + ; WC { wc_simple = simples } - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds null_ev_binds_var $ - do { mapM_ (promoteAndDefaultTyVar rhs_tclvl gbl_tvs) meta_tvs - -- See Note [Promote _and_ default when inferring] - ; solveSimpleWanteds quant_cand } + <- setTcLevel rhs_tclvl $ + runTcSDeriveds $ + solveSimpleWanteds $ mapBag toDerivedCt quant_cand + -- NB: we don't want evidence, so used + -- Derived constraints + + ; simples <- TcM.zonkSimples simples ; return [ ctEvPred ev | ct <- bagToList simples - , let ev = ctEvidence ct - , isWanted ev ] } + , let ev = ctEvidence ct ] } -- NB: quant_pred_candidates is already fully zonked -- Decide what type variables and constraints to quantify ; zonked_taus <- mapM (TcM.zonkTcType . snd) name_taus - ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus - ; (qtvs, bound_theta) <- decideQuantification apply_mr sigs name_taus - quant_pred_candidates zonked_tau_tvs - - -- Emit an implication constraint for the - -- remaining constraints from the RHS - ; bound_ev_vars <- mapM TcM.newEvVar bound_theta - ; let skol_info = InferSkol [ (name, mkSigmaTy [] bound_theta ty) - | (name, ty) <- name_taus ] + ; let zonked_tau_tkvs = splitDepVarsOfTypes zonked_taus + ; (qtvs, bound_theta) + <- decideQuantification apply_mr sigs name_taus + quant_pred_candidates zonked_tau_tkvs + + -- Promote any type variables that are free in the inferred type + -- of the function: + -- f :: forall qtvs. bound_theta => zonked_tau + -- These variables now become free in the envt, and hence will show + -- up whenever 'f' is called. They may currently at rhs_tclvl, but + -- they had better be unifiable at the outer_tclvl! + -- Example: envt mentions alpha[1] + -- tau_ty = beta[2] -> beta[2] + -- consraints = alpha ~ [beta] + -- we don't quantify over beta (since it is fixed by envt) + -- so we must promote it! The inferred type is just + -- f :: beta -> beta + ; outer_tclvl <- TcM.getTcLevel + ; zonked_tau_tvs <- fold <$> + traverse TcM.zonkTyCoVarsAndFV zonked_tau_tkvs + -- decideQuantification turned some meta tyvars into + -- quantified skolems, so we have to zonk again + + ; let phi_tvs = tyCoVarsOfTypes bound_theta + `unionVarSet` zonked_tau_tvs + + promote_tvs = closeOverKinds phi_tvs `delVarSetList` qtvs + ; MASSERT2( closeOverKinds promote_tvs `subVarSet` promote_tvs + , ppr phi_tvs $$ + ppr (closeOverKinds phi_tvs) $$ + ppr promote_tvs $$ + ppr (closeOverKinds promote_tvs) ) + -- we really don't want a type to be promoted when its kind isn't! + + -- promoteTyVar ignores coercion variables + ; mapM_ (promoteTyVar outer_tclvl) (varSetElems promote_tvs) + + -- Emit an implication constraint for the + -- remaining constraints from the RHS + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + ; let skol_info = InferSkol [ (name, mkSigmaTy [] bound_theta ty) + | (name, ty) <- name_taus ] -- Don't add the quantified variables here, because -- they are also bound in ic_skols and we want them -- to be tidied uniformly @@ -497,54 +565,32 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds implic = Implic { ic_tclvl = rhs_tclvl , ic_skols = qtvs , ic_no_eqs = False - , ic_given = bound_ev_vars + , ic_given = bound_theta_vars , ic_wanted = wanted_transformed , ic_status = IC_Unsolved - , ic_binds = ev_binds_var + , ic_binds = Just ev_binds_var , ic_info = skol_info , ic_env = tc_lcl_env } ; emitImplication implic - -- Promote any type variables that are free in the inferred type - -- of the function: - -- f :: forall qtvs. bound_theta => zonked_tau - -- These variables now become free in the envt, and hence will show - -- up whenever 'f' is called. They may currently at rhs_tclvl, but - -- they had better be unifiable at the outer_tclvl! - -- Example: envt mentions alpha[1] - -- tau_ty = beta[2] -> beta[2] - -- consraints = alpha ~ [beta] - -- we don't quantify over beta (since it is fixed by envt) - -- so we must promote it! The inferred type is just - -- f :: beta -> beta - ; outer_tclvl <- TcRn.getTcLevel - ; zonked_tau_tvs <- TcM.zonkTyVarsAndFV zonked_tau_tvs - -- decideQuantification turned some meta tyvars into - -- quantified skolems, so we have to zonk again - ; let phi_tvs = tyVarsOfTypes bound_theta `unionVarSet` zonked_tau_tvs - promote_tvs = varSetElems (closeOverKinds phi_tvs `delVarSetList` qtvs) - ; runTcSWithEvBinds null_ev_binds_var $ -- runTcS just to get the types right :-( - mapM_ (promoteTyVar outer_tclvl) promote_tvs - -- All done! ; traceTc "} simplifyInfer/produced residual implication for quantification" $ vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates , ptext (sLit "zonked_taus") <+> ppr zonked_taus , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs , ptext (sLit "promote_tvs=") <+> ppr promote_tvs - , ptext (sLit "bound_theta =") <+> vcat [ ppr v <+> dcolon <+> ppr (idType v) - | v <- bound_ev_vars] + , ptext (sLit "bound_theta =") <+> ppr bound_theta , ptext (sLit "qtvs =") <+> ppr qtvs , ptext (sLit "implic =") <+> ppr implic ] - ; return ( qtvs, bound_ev_vars, TcEvBinds ev_binds_var) } + ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var ) } mkSigDerivedWanteds :: TcIdSigInfo -> TcM [Ct] -- See Note [Add deriveds for signature contexts] mkSigDerivedWanteds (TISI { sig_bndr = PartialSig { sig_name = name } , sig_theta = theta, sig_tau = tau }) = do { let skol_info = InferSkol [(name, mkSigmaTy [] theta tau)] - ; loc <- getCtLocM (GivenOrigin skol_info) + ; loc <- getCtLocM (GivenOrigin skol_info) (Just TypeLevel) ; return [ mkNonCanonical (CtDerived { ctev_pred = pred , ctev_loc = loc }) | pred <- theta ] } @@ -589,37 +635,42 @@ If the monomorphism restriction does not apply, then we quantify as follows: (This actually unifies each quantifies meta-tyvar with a fresh skolem.) Result is qtvs. - * Filter the constraints using pickQuantifyablePreds and the qtvs. + * Filter the constraints using pickQuantifiablePreds and the qtvs. We have to zonk the constraints first, so they "see" the freshly created skolems. -If the MR does apply, mono_tvs includes all the constrained tyvars, -and the quantified constraints are empty/insoluble +If the MR does apply, mono_tvs includes all the constrained tyvars -- +including all covars -- and the quantified constraints are empty/insoluble. + -} decideQuantification - :: Bool -- Apply monomorphism restriction - -> [TcIdSigInfo] - -> [(Name, TcTauType)] -- Variables to be generalised (just for error msg) - -> [PredType] -> TcTyVarSet -- Constraints and type variables from RHS - -> TcM ( [TcTyVar] -- Quantify over these tyvars (skolems) - , [PredType]) -- and this context (fully zonked) + :: Bool -- try the MR restriction? + -> [TcIdSigInfo] + -> [(Name, TcTauType)] -- variables to be generalised (for errors only) + -> [PredType] -- candidate theta + -> Pair TcTyCoVarSet -- dependent (kind) variables & type variables + -> TcM ( [TcTyVar] -- Quantify over these (skolems) + , [PredType] ) -- and this context (fully zonked) -- See Note [Deciding quantification] -decideQuantification apply_mr sigs name_taus constraints zonked_tau_tvs +decideQuantification apply_mr sigs name_taus constraints + zonked_pair@(Pair zonked_tau_kvs zonked_tau_tvs) | apply_mr -- Apply the Monomorphism restriction - = do { gbl_tvs <- tcGetGlobalTyVars - ; let constrained_tvs = tyVarsOfTypes constraints + = do { gbl_tvs <- tcGetGlobalTyCoVars + ; let constrained_tvs = tyCoVarsOfTypes constraints `unionVarSet` + filterVarSet isCoVar zonked_tkvs mono_tvs = gbl_tvs `unionVarSet` constrained_tvs - ; qtvs <- quantify_tvs sigs mono_tvs zonked_tau_tvs + ; qtvs <- quantify_tvs sigs mono_tvs zonked_pair - -- Warn about the monomorphism restriction + -- Warn about the monomorphism restriction ; warn_mono <- woptM Opt_WarnMonomorphism - ; let mr_bites = constrained_tvs `intersectsVarSet` zonked_tau_tvs + ; let mr_bites = constrained_tvs `intersectsVarSet` zonked_tkvs ; warnTc (warn_mono && mr_bites) $ - hang (ptext (sLit "The Monomorphism Restriction applies to the binding") + hang (text "The Monomorphism Restriction applies to the binding" <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs) - 2 (ptext (sLit "Consider giving a type signature for") - <+> if isSingleton bndrs then pp_bndrs else ptext (sLit "these binders")) + 2 (text "Consider giving a type signature for" + <+> if isSingleton bndrs then pp_bndrs + else ptext (sLit "these binders")) -- All done ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs @@ -627,83 +678,68 @@ decideQuantification apply_mr sigs name_taus constraints zonked_tau_tvs ; return (qtvs, []) } | otherwise - = do { gbl_tvs <- tcGetGlobalTyVars + = do { gbl_tvs <- tcGetGlobalTyCoVars ; let mono_tvs = growThetaTyVars equality_constraints gbl_tvs tau_tvs_plus = growThetaTyVars constraints zonked_tau_tvs - ; qtvs <- quantify_tvs sigs mono_tvs tau_tvs_plus - ; constraints <- zonkTcThetaType constraints - -- quantifyTyVars turned some meta tyvars into - -- quantified skolems, so we have to zonk again - - ; theta <- pickQuantifiablePreds (mkVarSet qtvs) constraints - ; let min_theta = mkMinimalBySCs theta -- See Note [Minimize by Superclasses] - - ; traceTc "decideQuantification 2" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs - , ppr tau_tvs_plus, ppr qtvs, ppr min_theta]) + ; qtvs <- quantify_tvs sigs mono_tvs (Pair zonked_tau_kvs tau_tvs_plus) + -- We don't grow the kvs, as there's no real need to. Recall + -- that quantifyTyVars uses the separation between kvs and tvs + -- only for defaulting, and we don't want (ever) to default a tv + -- to *. So, don't grow the kvs. + + ; constraints <- TcM.zonkTcTypes constraints + -- quantiyTyVars turned some meta tyvars into + -- quantified skolems, so we have to zonk again + + ; let theta = pickQuantifiablePreds (mkVarSet qtvs) constraints + min_theta = mkMinimalBySCs theta + -- See Note [Minimize by Superclasses] + + ; traceTc "decideQuantification 2" + (vcat [ text "constraints:" <+> ppr constraints + , text "gbl_tvs:" <+> ppr gbl_tvs + , text "mono_tvs:" <+> ppr mono_tvs + , text "zonked_kvs:" <+> ppr zonked_tau_kvs + , text "tau_tvs_plus:" <+> ppr tau_tvs_plus + , text "qtvs:" <+> ppr qtvs + , text "min_theta:" <+> ppr min_theta ]) ; return (qtvs, min_theta) } where + zonked_tkvs = zonked_tau_kvs `unionVarSet` zonked_tau_tvs bndrs = map fst name_taus pp_bndrs = pprWithCommas (quotes . ppr) bndrs equality_constraints = filter isEqPred constraints -quantify_tvs :: [TcIdSigInfo] -> TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] --- See Note [Which type variable to quantify] -quantify_tvs sigs mono_tvs tau_tvs - = quantifyTyVars (mono_tvs `delVarSetList` sig_qtvs) - (tau_tvs `extendVarSetList` sig_qtvs `extendVarSetList` sig_wcs) +quantify_tvs :: [TcIdSigInfo] + -> TcTyVarSet -- the monomorphic tvs + -> Pair TcTyVarSet -- kvs, tvs to quantify + -> TcM [TcTyVar] +-- See Note [Which type variables to quantify] +quantify_tvs sigs mono_tvs (Pair tau_kvs tau_tvs) + = quantifyTyVars (mono_tvs `delVarSetList` sig_qtvs) + (Pair tau_kvs + (tau_tvs `extendVarSetList` sig_qtvs + `extendVarSetList` sig_wcs)) -- NB: quantifyTyVars zonks its arguments where sig_qtvs = [ skol | sig <- sigs, (_, skol) <- sig_skols sig ] sig_wcs = [ wc | TISI { sig_bndr = PartialSig { sig_wcs = wcs } } <- sigs , (_, wc) <- wcs ] ------------------- -pickQuantifiablePreds :: TyVarSet -- Quantifying over these - -> TcThetaType -- Proposed constraints to quantify - -> TcM TcThetaType -- A subset that we can actually quantify --- This function decides whether a particular constraint should be --- quantified over, given the type variables that are being quantified -pickQuantifiablePreds qtvs theta - = do { let flex_ctxt = True -- Quantify over non-tyvar constraints, even without - -- -XFlexibleContexts: see Trac #10608, #10351 - -- flex_ctxt <- xoptM Opt_FlexibleContexts - ; return (filter (pick_me flex_ctxt) theta) } - where - pick_me flex_ctxt pred - = case classifyPredType pred of - ClassPred cls tys - | isIPClass cls -> True -- See note [Inheriting implicit parameters] - | otherwise -> pick_cls_pred flex_ctxt tys - - EqPred ReprEq ty1 ty2 -> pick_cls_pred flex_ctxt [ty1, ty2] - -- Representational equality is like a class constraint - - EqPred NomEq ty1 ty2 -> quant_fun ty1 || quant_fun ty2 - IrredPred ty -> tyVarsOfType ty `intersectsVarSet` qtvs - - pick_cls_pred flex_ctxt tys - = tyVarsOfTypes tys `intersectsVarSet` qtvs - && (checkValidClsArgs flex_ctxt tys) - -- Only quantify over predicates that checkValidType - -- will pass! See Trac #10351. - - -- See Note [Quantifying over equality constraints] - quant_fun ty - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) | isTypeFamilyTyCon tc - -> tyVarsOfTypes tys `intersectsVarSet` qtvs - _ -> False ------------------ -growThetaTyVars :: ThetaType -> TyVarSet -> TyVarSet +growThetaTyVars :: ThetaType -> TyCoVarSet -> TyVarSet -- See Note [Growing the tau-tvs using constraints] +-- NB: only returns tyvars, never covars growThetaTyVars theta tvs - | null theta = tvs - | otherwise = transCloVarSet mk_next seed_tvs + | null theta = tvs_only + | otherwise = filterVarSet isTyVar $ + transCloVarSet mk_next seed_tvs where - seed_tvs = tvs `unionVarSet` tyVarsOfTypes ips + tvs_only = filterVarSet isTyVar tvs + seed_tvs = tvs `unionVarSet` tyCoVarsOfTypes ips (ips, non_ips) = partition isIPPred theta - -- See note [Inheriting implicit parameters] + -- See Note [Inheriting implicit parameters] in TcType mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips @@ -711,7 +747,7 @@ growThetaTyVars theta tvs | pred_tvs `intersectsVarSet` so_far = tvs `unionVarSet` pred_tvs | otherwise = tvs where - pred_tvs = tyVarsOfType pred + pred_tvs = tyCoVarsOfType pred {- Note [Which type variables to quantify] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -777,33 +813,6 @@ Notice that growThetaTyVars is conservative if v might be fixed by vs => v `elem` grow(vs,C) -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, because then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you must quantify over implicit -parameters, *even if* they don't mention the bound type variables. -Reason: because implicit parameters, uniquely, have local instance -declarations. See the pickQuantifiablePreds. - Note [Quantification with errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find that the RHS of the definition has some absolutely-insoluble @@ -888,59 +897,25 @@ the constraints before simplifying. This only half-works, but then let-generalisation only half-works. - ********************************************************************************* * * * Main Simplifier * * * *********************************************************************************** -Note [Deferring coercion errors to runtime] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While developing, sometimes it is desirable to allow compilation to succeed even -if there are type errors in the code. Consider the following case: - - module Main where - - a :: Int - a = 'a' - - main = print "b" - -Even though `a` is ill-typed, it is not used in the end, so if all that we're -interested in is `main` it is handy to be able to ignore the problems in `a`. - -Since we treat type equalities as evidence, this is relatively simple. Whenever -we run into a type mismatch in TcUnify, we normally just emit an error. But it -is always safe to defer the mismatch to the main constraint solver. If we do -that, `a` will get transformed into - - co :: Int ~ Char - co = ... - - a :: Int - a = 'a' `cast` co - -The constraint solver would realize that `co` is an insoluble constraint, and -emit an error with `reportUnsolved`. But we can also replace the right-hand side -of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program -to compile, and it will run fine unless we evaluate `a`. This is what -`deferErrorsToRuntime` does. - -It does this by keeping track of which errors correspond to which coercion -in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the -errors, and does not fail if -fdefer-type-errors is on, so that we can -continue compilation. The errors are turned into warnings in `reportUnsolved`. -} -solveWantedsTcM :: [CtEvidence] -> TcM WantedConstraints --- Simplify the input constraints +simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints +-- Zonk the input constraints, and simplify them -- Discard the evidence binds -- Discards all Derived stuff in result --- Result is /not/ guaranteed zonked -solveWantedsTcM wanted - = do { (wanted1, _binds) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted)) - ; return wanted1 } +-- Postcondition: fully zonked and unflattened constraints +simplifyWantedsTcM wanted + = do { traceTc "simplifyWantedsTcM {" (ppr wanted) + ; (result, _) <- runTcS (solveWantedsAndDrop $ mkSimpleWC wanted) + ; result <- TcM.zonkWC result + ; traceTc "simplifyWantedsTcM }" (ppr result) + ; return result } solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints -- Since solveWanteds returns the residual WantedConstraints, @@ -971,7 +946,7 @@ solveWanteds wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics (WC { wc_simple = simples1, wc_impl = implics2 , wc_insol = insols `unionBags` insols1 }) - ; bb <- getTcEvBindsMap + ; bb <- TcS.getTcEvBindsMap ; traceTcS "solveWanteds }" $ vcat [ text "final wc =" <+> ppr final_wc , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] @@ -1043,7 +1018,7 @@ solveImplication :: Implication -- Wanted -- Precondition: The TcS monad contains an empty worklist and given-only inerts -- which after trying to solve this implication we must restore to their original value solveImplication imp@(Implic { ic_tclvl = tclvl - , ic_binds = ev_binds + , ic_binds = m_ev_binds , ic_skols = skols , ic_given = givens , ic_wanted = wanteds @@ -1061,8 +1036,8 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) -- Solve the nested constraints - ; (no_given_eqs, given_insols, residual_wanted) - <- nestImplicTcS ev_binds tclvl $ + ; ((no_given_eqs, given_insols, residual_wanted), used_tcvs) + <- nestImplicTcS m_ev_binds (mkVarSet (skols ++ givens)) tclvl $ do { given_insols <- solveSimpleGivens (mkGivenLoc tclvl info env) givens ; no_eqs <- getNoGivenEqs tclvl skols @@ -1076,13 +1051,15 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; (floated_eqs, residual_wanted) <- floatEqualities skols no_given_eqs residual_wanted - ; traceTcS "solveImplication 2" (ppr given_insols $$ ppr residual_wanted) + ; traceTcS "solveImplication 2" + (ppr given_insols $$ ppr residual_wanted $$ ppr used_tcvs) ; let final_wanted = residual_wanted `addInsols` given_insols ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs , ic_wanted = final_wanted }) + used_tcvs - ; evbinds <- getTcEvBindsMap + ; evbinds <- TcS.getTcEvBindsMap ; traceTcS "solveImplication end }" $ vcat [ text "no_given_eqs =" <+> ppr no_given_eqs , text "floated_eqs =" <+> ppr floated_eqs @@ -1092,16 +1069,18 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; return (floated_eqs, res_implic) } ---------------------- -setImplicationStatus :: Implication -> TcS (Maybe Implication) +setImplicationStatus :: Implication -> TyCoVarSet -- needed variables + -> TcS (Maybe Implication) -- Finalise the implication returned from solveImplication: -- * Set the ic_status field -- * Trim the ic_wanted field to remove Derived constraints -- Return Nothing if we can discard the implication altogether -setImplicationStatus implic@(Implic { ic_binds = EvBindsVar ev_binds_var _ +setImplicationStatus implic@(Implic { ic_binds = m_ev_binds_var , ic_info = info , ic_tclvl = tc_lvl , ic_wanted = wc , ic_given = givens }) + used_tcvs | some_insoluble = return $ Just $ implic { ic_status = IC_Insoluble @@ -1116,8 +1095,11 @@ setImplicationStatus implic@(Implic { ic_binds = EvBindsVar ev_binds_var _ | otherwise -- Everything is solved; look at the implications -- See Note [Tracking redundant constraints] - = do { ev_binds <- TcS.readTcRef ev_binds_var - ; let all_needs = neededEvVars ev_binds implic_needs + = do { ev_binds <- case m_ev_binds_var of + Just (EvBindsVar ref _) -> TcS.readTcRef ref + Nothing -> return emptyEvBindMap + ; let all_needs = neededEvVars ev_binds + (used_tcvs `unionVarSet` implic_needs) dead_givens | warnRedundantGivens info = filterOut (`elemVarSet` all_needs) givens @@ -1191,11 +1173,7 @@ warnRedundantGivens _ = False neededEvVars :: EvBindMap -> VarSet -> VarSet -- Find all the evidence variables that are "needed", -- and then delete all those bound by the evidence bindings --- A variable is "needed" if --- a) it is free in the RHS of a Wanted EvBind (add_wanted), --- b) it is free in the RHS of an EvBind whose LHS is needed (transClo), --- c) it is in the ic_need_evs of a nested implication (initial_seeds) --- (after removing the givens). +-- See note [Tracking redundant constraints] neededEvVars ev_binds initial_seeds = needed `minusVarSet` bndrs where @@ -1278,6 +1256,7 @@ works: a) it is free in the RHS of a Wanted EvBind, b) it is free in the RHS of an EvBind whose LHS is needed, c) it is in the ics_need of a nested implication. + d) it is listed in the tcs_used_tcvs field of the nested TcSEnv * We need to be careful not to discard an implication prematurely, even one that is fully solved, because we might @@ -1365,42 +1344,53 @@ Consider floated_eqs (all wanted or derived): simpl_loop. So we iterate if there any of these -} -promoteTyVar :: TcLevel -> TcTyVar -> TcS TcTyVar +promoteTyVar :: TcLevel -> TcTyVar -> TcM () -- When we float a constraint out of an implication we must restore -- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType -- See Note [Promoting unification variables] promoteTyVar tclvl tv | isFloatedTouchableMetaTyVar tclvl tv - = do { cloned_tv <- TcS.cloneMetaTyVar tv + = do { cloned_tv <- TcM.cloneMetaTyVar tv ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; unifyTyVar tv (mkTyVarTy rhs_tv) - ; return rhs_tv } + ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv) } | otherwise - = return tv + = return () -promoteAndDefaultTyVar :: TcLevel -> TcTyVarSet -> TcTyVar -> TcS TcTyVar --- See Note [Promote _and_ default when inferring] -promoteAndDefaultTyVar tclvl gbl_tvs tv - = do { tv1 <- if tv `elemVarSet` gbl_tvs - then return tv - else defaultTyVar tv - ; promoteTyVar tclvl tv1 } +promoteTyVarTcS :: TcLevel -> TcTyVar -> TcS () +-- When we float a constraint out of an implication we must restore +-- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType +-- See Note [Promoting unification variables] +-- We don't just call promoteTyVar because we want to use unifyTyVar, +-- not writeMetaTyVar +promoteTyVarTcS tclvl tv + | isFloatedTouchableMetaTyVar tclvl tv + = do { cloned_tv <- TcS.cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; unifyTyVar tv (mkTyVarTy rhs_tv) } + | otherwise + = return () -defaultTyVar :: TcTyVar -> TcS TcTyVar +-- | If the tyvar is a levity var, set it to Lifted. Returns whether or +-- not this happened. +defaultTyVar :: TcTyVar -> TcM () -- Precondition: MetaTyVars only -- See Note [DefaultTyVar] defaultTyVar the_tv - | Just default_k <- defaultKind_maybe (tyVarKind the_tv) - = do { tv' <- TcS.cloneMetaTyVar the_tv - ; let new_tv = setTyVarKind tv' default_k - ; traceTcS "defaultTyVar" (ppr the_tv <+> ppr new_tv) - ; unifyTyVar the_tv (mkTyVarTy new_tv) - ; return new_tv } - -- Why not directly derived_pred = mkTcEqPred k default_k? - -- See Note [DefaultTyVar] - -- We keep the same TcLevel on tv' - - | otherwise = return the_tv -- The common case + | isLevityVar the_tv + = do { traceTc "defaultTyVar levity" (ppr the_tv) + ; writeMetaTyVar the_tv liftedDataConTy } + + | otherwise = return () -- The common case + +-- | Like 'defaultTyVar', but in the TcS monad. +defaultTyVarTcS :: TcTyVar -> TcS Bool +defaultTyVarTcS the_tv + | isLevityVar the_tv + = do { traceTcS "defaultTyVarTcS levity" (ppr the_tv) + ; unifyTyVar the_tv liftedDataConTy + ; return True } + | otherwise + = return False -- the common case approximateWC :: WantedConstraints -> Cts -- Postcondition: Wanted or Derived Cts @@ -1408,12 +1398,12 @@ approximateWC :: WantedConstraints -> Cts approximateWC wc = float_wc emptyVarSet wc where - float_wc :: TcTyVarSet -> WantedConstraints -> Cts + float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) = filterBag is_floatable simples `unionBags` do_bag (float_implic new_trapping_tvs) implics where - is_floatable ct = tyVarsOfCt ct `disjointVarSet` new_trapping_tvs + is_floatable ct = tyCoVarsOfCt ct `disjointVarSet` new_trapping_tvs new_trapping_tvs = transCloVarSet grow trapping_tvs grow :: VarSet -> VarSet -- Maps current trapped tyvars to newly-trapped ones @@ -1422,9 +1412,9 @@ approximateWC wc | ct_tvs `intersectsVarSet` so_far = tvs `unionVarSet` ct_tvs | otherwise = tvs where - ct_tvs = tyVarsOfCt ct + ct_tvs = tyCoVarsOfCt ct - float_implic :: TcTyVarSet -> Implication -> Cts + float_implic :: TcTyCoVarSet -> Implication -> Cts float_implic trapping_tvs imp | ic_no_eqs imp -- No equalities, so float = float_wc new_trapping_tvs (ic_wanted imp) @@ -1483,7 +1473,7 @@ There are two caveats: Note [DefaultTyVar] ~~~~~~~~~~~~~~~~~~~ defaultTyVar is used on any un-instantiated meta type variables to -default the kind of OpenKind and ArgKind etc to *. This is important +default any levity variables to Lifted. This is important to ensure that instance declarations match. For example consider instance Show (a->b) @@ -1498,15 +1488,8 @@ are going to affect these type variables, so it's time to do it by hand. However we aren't ready to default them fully to () or whatever, because the type-class defaulting rules have yet to run. -An important point is that if the type variable tv has kind k and the -default is default_k we do not simply generate [D] (k ~ default_k) because: - - (1) k may be ArgKind and default_k may be * so we will fail - - (2) We need to rewrite all occurrences of the tv to be a type - variable with the right kind and we choose to do this by rewriting - the type variable /itself/ by a new variable which does have the - right kind. +An alternate implementation would be to emit a derived constraint setting +the levity variable to Lifted, but this seems unnecessarily indirect. Note [Promote _and_ default when inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1654,8 +1637,7 @@ floatEqualities :: [TcTyVar] -> Bool -- fully zonked, so that we can see their free variables -- -- Postcondition: The returned floated constraints (Cts) are only --- Wanted or Derived and come from the input wanted --- ev vars or deriveds +-- Wanted or Derived -- -- Also performs some unifications (via promoteTyVar), adding to -- monadically-carried ty_binds. These will be used when processing @@ -1663,21 +1645,25 @@ floatEqualities :: [TcTyVar] -> Bool -- -- Subtleties: Note [Float equalities from under a skolem binding] -- Note [Skolem escape] -floatEqualities skols no_given_eqs wanteds@(WC { wc_simple = simples }) +floatEqualities skols no_given_eqs + wanteds@(WC { wc_simple = simples }) | not no_given_eqs -- There are some given equalities, so don't float = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] | otherwise = do { outer_tclvl <- TcS.getTcLevel - ; mapM_ (promoteTyVar outer_tclvl) (varSetElems (tyVarsOfCts float_eqs)) - -- See Note [Promoting unification variables] + ; mapM_ (promoteTyVarTcS outer_tclvl) + (varSetElems (tyCoVarsOfCts float_eqs)) + -- See Note [Promoting unification variables] + ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols , text "Simples =" <+> ppr simples - , text "Floated eqs =" <+> ppr float_eqs ]) - ; return (float_eqs, wanteds { wc_simple = remaining_simples }) } + , text "Floated eqs =" <+> ppr float_eqs]) + ; return ( float_eqs + , wanteds { wc_simple = remaining_simples } ) } where skol_set = mkVarSet skols (float_eqs, remaining_simples) = partitionBag (usefulToFloat is_useful) simples - is_useful pred = tyVarsOfType pred `disjointVarSet` skol_set + is_useful pred = tyCoVarsOfType pred `disjointVarSet` skol_set usefulToFloat :: (TcPredType -> Bool) -> Ct -> Bool usefulToFloat is_useful_pred ct -- The constraint is un-flattened and de-canonicalised @@ -1699,7 +1685,6 @@ usefulToFloat is_useful_pred ct -- The constraint is un-flattened and de-canon float_tv_eq tv1 ty2 -- See Note [Which equalities to float] = isMetaTyVar tv1 - && typeKind ty2 `isSubKind` tyVarKind tv1 && (not (isSigTyVar tv1) || isTyVarTy ty2) {- Note [Float equalities from under a skolem binding] @@ -1735,13 +1720,6 @@ happen. In particular: * alpha is a meta-tyvar. - * And the equality is kind-compatible - - e.g. Consider (alpha:*) ~ (s:*->*) - From this we already get a Derived insoluble equality. If we - floated it, we'll get *another* Derived insoluble equality one - level out, so the same error will be reported twice. - * And 'alpha' is not a SigTv with 'ty' being a non-tyvar. In that case, floating out won't help either, and it may affect grouping of error messages. @@ -1821,16 +1799,16 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds -- which may look like (Typeable * (a:*)) (Trac #8931) find_unary cc | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) - , Just (kinds, ty) <- snocView tys -- Ignore kind arguments - , all isKind kinds -- for this purpose + , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys + -- Ignore invisible arguments for this purpose , Just tv <- tcGetTyVar_maybe ty , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and -- we definitely don't want to try to assign to those! = Left (cc, cls, tv) find_unary cc = Right cc -- Non unary or non dictionary - bad_tvs :: TcTyVarSet -- TyVars mentioned by non-unaries - bad_tvs = mapUnionVarSet tyVarsOfCt non_unaries + bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries + bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 @@ -1869,8 +1847,8 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) ; fake_ev_binds_var <- TcS.newTcEvBinds ; tclvl <- TcS.getTcLevel - ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) - try_group + ; (success, _) <- nestImplicTcS (Just fake_ev_binds_var) emptyVarSet + (pushTcLevel tclvl) try_group ; if success then -- Success: record the type variable binding, and return @@ -1889,17 +1867,20 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) = do { lcl_env <- TcS.getLclEnv ; let loc = CtLoc { ctl_origin = GivenOrigin UnkSkol , ctl_env = lcl_env + , ctl_t_or_k = Nothing , ctl_depth = initialSubGoalDepth } ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred) wanteds - ; residual_wanted <- solveSimpleWanteds $ listToBag $ - map mkNonCanonical wanted_evs - ; return (isEmptyWC residual_wanted) } + ; fmap isEmptyWC $ + solveSimpleWanteds $ listToBag $ + map mkNonCanonical wanted_evs } + | otherwise = return False - tmpl_tvs = extendVarSet (tyVarsOfType (tyVarKind the_tv)) the_tv - mb_subst = tcMatchTy tmpl_tvs (mkTyVarTy the_tv) default_ty + the_ty = mkTyVarTy the_tv + tmpl_tvs = tyCoVarsOfType the_ty + mb_subst = tcMatchTy tmpl_tvs the_ty default_ty -- Make sure the kinds match too; hence this call to tcMatchTy -- E.g. suppose the only constraint was (Typeable k (a::k)) -- With the addition of polykinded defaulting we also want to reject diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index ad8d06e9a0..df52ba588d 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -65,12 +65,13 @@ import NameSet import TcMType import TcHsType import TcIface -import TypeRep +import TyCoRep import FamInst import FamInstEnv import InstEnv import NameEnv import PrelNames +import TysWiredIn import OccName import Hooks import Var @@ -92,7 +93,7 @@ import Serialized import ErrUtils import Util import Unique -import VarSet ( isEmptyVarSet ) +import VarSet ( isEmptyVarSet, filterVarSet ) import Data.Maybe import BasicTypes hiding( SuccessFlag(..) ) import Maybes( MaybeErr(..) ) @@ -160,7 +161,7 @@ tcTypedBracket brack@(TExpBr expr) res_ty -- NC for no context; tcBracket does that ; meta_ty <- tcTExpTy expr_ty - ; co <- unifyType meta_ty res_ty + ; co <- unifyType (Just expr) meta_ty res_ty ; ps' <- readMutVar ps_ref ; texpco <- tcLookupId unsafeTExpCoerceName ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) @@ -173,7 +174,7 @@ tcUntypedBracket brack ps res_ty = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) ; ps' <- mapM tcPendingSplice ps ; meta_ty <- tcBrackTy brack - ; co <- unifyType meta_ty res_ty + ; co <- unifyType (Just brack) meta_ty res_ty ; traceTc "tc_bracket done untyped" (ppr meta_ty) ; return (mkHsWrapCo co (HsTcBracketOut brack ps')) } @@ -512,10 +513,7 @@ tcTopSpliceExpr isTypedSplice tc_action -- is expected (Trac #7276) setStage (Splice isTypedSplice) $ do { -- Typecheck the expression - (expr', lie) <- captureConstraints tc_action - - -- Solve the constraints - ; const_binds <- simplifyTop lie + (expr', const_binds) <- solveTopConstraints tc_action -- Zonk it and tie the knot of dictionary bindings ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } @@ -869,16 +867,17 @@ reifyInstances th_nm th_tys ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) -- #9262 says to bring vars into scope, like in HsForAllTy case -- of rnHsTyKi - ; let (kvs, tvs) = extractHsTyRdrTyVars rdr_ty - tv_bndrs = userHsTyVarBndrs loc tvs - hs_tvbs = mkHsQTvs tv_bndrs + ; free_vars <- extractHsTyRdrTyVars rdr_ty + ; let tv_rdrs = freeKiTyVarsAllVars free_vars -- Rename to HsType Name - ; ((rn_tvbs, rn_ty), _fvs) - <- bindHsQTyVars doc Nothing kvs hs_tvbs $ \ rn_tvbs -> + ; ((tv_names, rn_ty), _fvs) + <- bindLRdrNames tv_rdrs $ \ tv_names -> do { (rn_ty, fvs) <- rnLHsType doc rdr_ty - ; return ((rn_tvbs, rn_ty), fvs) } - ; (ty, _kind) <- tcHsQTyVars rn_tvbs $ \ _tvs -> - tcLHsType rn_ty + ; return ((tv_names, rn_ty), fvs) } + ; (_tvs, ty) + <- solveEqualities $ + tcImplicitTKBndrsType tv_names $ + fst <$> tcLHsType rn_ty ; ty <- zonkTcTypeToType emptyZonkEnv ty -- Substitute out the meta type variables -- In particular, the type might have kind @@ -1070,10 +1069,10 @@ reifyThing (ATyVar tv tv1) reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) ------------------------------------------- -reifyAxBranch :: CoAxBranch -> TcM TH.TySynEqn -reifyAxBranch (CoAxBranch { cab_lhs = args, cab_rhs = rhs }) +reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn +reifyAxBranch fam_tc (CoAxBranch { cab_lhs = args, cab_rhs = rhs }) -- remove kind patterns (#8884) - = do { args' <- mapM reifyType (filter (not . isKind) args) + = do { args' <- mapM reifyType (filterOutInvisibleTypes fam_tc args) ; rhs' <- reifyType rhs ; return (TH.TySynEqn args' rhs') } @@ -1096,8 +1095,8 @@ reifyTyCon tc -- we need the *result kind* (see #8884) (kvs, mono_kind) = splitForAllTys kind -- tyConArity includes *kind* params - (_, res_kind) = splitKindFunTysN (tyConArity tc - length kvs) - mono_kind + (_, res_kind) = splitFunTysN (tyConArity tc - length kvs) + mono_kind ; kind' <- reifyKind res_kind ; let (resultSig, injectivity) = case resVar of @@ -1114,7 +1113,7 @@ reifyTyCon tc injRHS = map (reifyName . tyVarName) (filterByList ms tvs) in (sig, inj) - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs (Just tc) ; if isOpenTypeFamilyTyCon tc then do { fam_envs <- tcGetFamInstEnvs ; instances <- reifyFamilyInstances tc @@ -1125,7 +1124,7 @@ reifyTyCon tc instances) } else do { eqns <- case isClosedSynFamilyTyConWithAxiom_maybe tc of - Just ax -> mapM reifyAxBranch $ + Just ax -> mapM (reifyAxBranch tc) $ fromBranches $ coAxiomBranches ax Nothing -> return [] ; return (TH.FamilyI @@ -1140,11 +1139,11 @@ reifyTyCon tc -- we need the *result kind* (see #8884) (kvs, mono_kind) = splitForAllTys kind -- tyConArity includes *kind* params - (_, res_kind) = splitKindFunTysN (tyConArity tc - length kvs) - mono_kind + (_, res_kind) = splitFunTysN (tyConArity tc - length kvs) + mono_kind ; kind' <- fmap Just (reifyKind res_kind) - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs (Just tc) ; fam_envs <- tcGetFamInstEnvs ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) ; return (TH.FamilyI @@ -1152,7 +1151,7 @@ reifyTyCon tc | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs (Just tc) ; return (TH.TyConI (TH.TySynD (reifyName tc) tvs' rhs')) } @@ -1161,7 +1160,7 @@ reifyTyCon tc = do { cxt <- reifyCxt (tyConStupidTheta tc) ; let tvs = tyConTyVars tc ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) - ; r_tvs <- reifyTyVars tvs + ; r_tvs <- reifyTyVars tvs (Just tc) ; let name = reifyName tc deriv = [] -- Don't know about deriving decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv @@ -1193,7 +1192,7 @@ reifyDataCon tys dc return main_con else do { cxt <- reifyCxt theta - ; ex_tvs' <- reifyTyVars ex_tvs + ; ex_tvs' <- reifyTyVars ex_tvs Nothing ; return (TH.ForallC ex_tvs' cxt main_con) } } ------------------------------ @@ -1204,7 +1203,7 @@ reifyClass cls ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) ; assocTys <- concatMapM reifyAT ats ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls) ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) ; return (TH.ClassI dec insts) } where @@ -1248,66 +1247,68 @@ reifyClass cls -- This is used to annotate type patterns for poly-kinded tyvars in -- reifying class and type instances. See #8953 and th/T8953. annotThType :: Bool -- True <=> annotate - -> TypeRep.Type -> TH.Type -> TcM TH.Type + -> TyCoRep.Type -> TH.Type -> TcM TH.Type -- tiny optimization: if the type is annotated, don't annotate again. annotThType _ _ th_ty@(TH.SigT {}) = return th_ty annotThType True ty th_ty - | not $ isEmptyVarSet $ tyVarsOfType ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = do { let ki = typeKind ty ; th_ki <- reifyKind ki ; return (TH.SigT th_ty th_ki) } annotThType _ _ th_ty = return th_ty --- | For every *type* variable (not *kind* variable) in the input, +-- | For every type variable in the input, -- report whether or not the tv is poly-kinded. This is used to eventually -- feed into 'annotThType'. mkIsPolyTvs :: [TyVar] -> [Bool] -mkIsPolyTvs tvs = [ is_poly_tv tv | tv <- tvs - , not (isKindVar tv) ] +mkIsPolyTvs = map is_poly_tv where - is_poly_tv tv = not $ isEmptyVarSet $ tyVarsOfType $ tyVarKind tv + is_poly_tv tv = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType $ + tyVarKind tv ------------------------------ reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] reifyClassInstances cls insts = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts where - tvs = classTyVars cls + tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls) reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- this list contains flags only for *type* - -- variables, not *kind* variables + -- includes only *visible* tvs -> ClsInst -> TcM TH.Dec reifyClassInstance is_poly_tvs i = do { cxt <- reifyCxt theta - ; let types_only = filterOut isKind types - ; thtypes <- reifyTypes types_only - ; annot_thtypes <- zipWith3M annotThType is_poly_tvs types_only thtypes + ; let vis_types = filterOutInvisibleTypes cls_tc types + ; thtypes <- reifyTypes vis_types + ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes ; return $ (TH.InstanceD cxt head_ty []) } where (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) - dfun = instanceDFunId i + cls_tc = classTyCon cls + dfun = instanceDFunId i ------------------------------ reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] reifyFamilyInstances fam_tc fam_insts = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts where - fam_tvs = tyConTyVars fam_tc + fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc) reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- this list contains flags only for *type* - -- variables, not *kind* variables + -- includes only *visible* tvs -> FamInst -> TcM TH.Dec -reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor - , fi_fam = fam - , fi_tys = lhs - , fi_rhs = rhs }) +reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor + , fi_fam = fam + , fi_tys = lhs + , fi_rhs = rhs }) = case flavor of SynFamilyInst -> -- remove kind patterns (#8884) - do { let lhs_types_only = filterOut isKind lhs + do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs ; th_lhs <- reifyTypes lhs_types_only ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only th_lhs @@ -1327,35 +1328,39 @@ reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor etad_tyvars = dropList rep_tc_args tvs eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc) - ; let types_only = filterOut isKind eta_expanded_lhs + ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs ; th_tys <- reifyTypes types_only ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys ; return (if isNewTyCon rep_tc then TH.NewtypeInstD [] fam' annot_th_tys (head cons) [] else TH.DataInstD [] fam' annot_th_tys cons []) } + where + fam_tc = famInstTyCon inst ------------------------------ -reifyType :: TypeRep.Type -> TcM TH.Type +reifyType :: TyCoRep.Type -> TcM TH.Type -- Monadic only because of failure -reifyType ty@(ForAllTy _ _) = reify_for_all ty +reifyType ty@(ForAllTy (Named _ _) _) = reify_for_all ty reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } -reifyType ty@(FunTy t1 t2) +reifyType ty@(ForAllTy (Anon t1) t2) | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty) +reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) -reify_for_all :: TypeRep.Type -> TcM TH.Type +reify_for_all :: TyCoRep.Type -> TcM TH.Type reify_for_all ty = do { cxt' <- reifyCxt cxt; ; tau' <- reifyType tau - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs Nothing ; return (TH.ForallT tvs' cxt' tau') } where (tvs, cxt, tau) = tcSplitSigmaTy ty -reifyTyLit :: TypeRep.TyLit -> TcM TH.TyLit +reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) @@ -1364,7 +1369,7 @@ reifyTypes = mapM reifyType reifyKind :: Kind -> TcM TH.Kind reifyKind ki - = do { let (kis, ki') = splitKindFunTys ki + = do { let (kis, ki') = splitFunTys ki ; ki'_rep <- reifyNonArrowKind ki' ; kis_rep <- mapM reifyKind kis ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) } @@ -1380,12 +1385,11 @@ reifyKind ki } reifyNonArrowKind k = noTH (sLit "this kind") (ppr k) -reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind +reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind reify_kc_app kc kis = fmap (mkThAppTs r_kc) (mapM reifyKind kis) where - r_kc | Just tc <- isPromotedTyCon_maybe kc - , isTupleTyCon tc = TH.TupleT (tyConArity kc) + r_kc | isTupleTyCon kc = TH.TupleT (tyConArity kc) | kc `hasKey` listTyConKey = TH.ListT | otherwise = TH.ConT (reifyName kc) @@ -1396,9 +1400,15 @@ reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) reifyTyVars :: [TyVar] + -> Maybe TyCon -- the tycon if the tycovars are from a tycon. + -- Used to detect which tvs are implicit. -> TcM [TH.TyVarBndr] -reifyTyVars tvs = mapM reify_tv $ filter isTypeVar tvs +reifyTyVars tvs m_tc = mapM reify_tv tvs' where + tvs' = case m_tc of + Just tc -> filterOutInvisibleTyVars tc tvs + Nothing -> tvs + -- even if the kind is *, we need to include a kind annotation, -- in case a poly-kind would be inferred without the annotation. -- See #8953 or test th/T8953 @@ -1444,21 +1454,24 @@ in. See #8953 and test th/T8953. -} -reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type +reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type reify_tc_app tc tys - = do { tys' <- reifyTypes (removeKinds tc_kind tys) + = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) ; maybe_sig_t (mkThAppTs r_tc tys') } where arity = tyConArity tc tc_kind = tyConKind tc - r_tc | isTupleTyCon tc = if isPromotedDataCon tc - then TH.PromotedTupleT arity - else TH.TupleT arity - | tc `hasKey` listTyConKey = TH.ListT - | tc `hasKey` nilDataConKey = TH.PromotedNilT - | tc `hasKey` consDataConKey = TH.PromotedConsT - | tc `hasKey` eqTyConKey = TH.EqualityT - | otherwise = TH.ConT (reifyName tc) + + r_tc | isTupleTyCon tc = if isPromotedDataCon tc + then TH.PromotedTupleT arity + else TH.TupleT arity + | tc `hasKey` listTyConKey = TH.ListT + | tc `hasKey` nilDataConKey = TH.PromotedNilT + | tc `hasKey` consDataConKey = TH.PromotedConsT + | tc `hasKey` heqTyConKey = TH.EqualityT + | tc `hasKey` eqPrimTyConKey = TH.EqualityT + | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) + | otherwise = TH.ConT (reifyName tc) -- See Note [Kind annotations on TyConApps] maybe_sig_t th_type @@ -1471,32 +1484,21 @@ reify_tc_app tc tys needs_kind_sig | Just result_ki <- peel_off_n_args tc_kind (length tys) - = not $ isEmptyVarSet $ kiVarsOfKind result_ki + = not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType result_ki | otherwise = True peel_off_n_args :: Kind -> Arity -> Maybe Kind peel_off_n_args k 0 = Just k peel_off_n_args k n - | Just (_, res_k) <- splitForAllTy_maybe k - = peel_off_n_args res_k (n-1) - | Just (_, res_k) <- splitFunTy_maybe k + | Just (_, res_k) <- splitPiTy_maybe k = peel_off_n_args res_k (n-1) | otherwise = Nothing - removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type] - removeKinds (FunTy k1 k2) (h:t) - | isSuperKind k1 = removeKinds k2 t - | otherwise = h : removeKinds k2 t - removeKinds (ForAllTy v k) (h:t) - | isSuperKind (varType v) = removeKinds k t - | otherwise = h : removeKinds k t - removeKinds _ tys = tys - -reifyPred :: TypeRep.PredType -> TcM TH.Pred +reifyPred :: TyCoRep.PredType -> TcM TH.Pred reifyPred ty - -- We could reify the implicit paramter as a class but it seems + -- We could reify the invisible paramter as a class but it seems -- nicer to support them properly... | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty) | otherwise = reifyType ty diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 1cb71d6182..915686b576 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -6,7 +6,7 @@ TcTyClsDecls: Typecheck type and class declarations -} -{-# LANGUAGE CPP, TupleSections #-} +{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} module TcTyClsDecls ( tcTyAndClassDecls, tcAddImplicits, @@ -16,7 +16,7 @@ module TcTyClsDecls ( kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, tcFamTyPats, tcTyFamInstEqn, famTyConShape, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - wrongKindOfFamily, dataConCtxt, badDataConTyCon + wrongKindOfFamily, dataConCtxt ) where #include "HsVersions.h" @@ -30,15 +30,16 @@ import TcValidity import TcHsSyn import TcTyDecls import TcClassDcl +import TcUnify import TcHsType import TcMType import RnTypes( collectAnonWildCards ) import TcType import FamInst import FamInstEnv -import Coercion( ltRole ) +import Coercion import Type -import TypeRep -- for checkValidRoles +import TyCoRep -- for checkValidRoles import Kind import Class import CoAxiom @@ -63,11 +64,14 @@ import ListSetOps import Digraph import DynFlags import FastString +import Unique import BasicTypes import Control.Monad import Data.List +#if __GLASGOW_HASKELL__ < 709 import Data.Monoid ( mempty ) +#endif {- ************************************************************************ @@ -89,7 +93,7 @@ following example: If we were to kind check the two declarations together, we would give Id the kind * -> *, since we apply it to an Int in the definition of X. But we can do better than that, since Id really is kind polymorphic, and should get kind -forall (k::BOX). k -> k. Since it does not depend on anything else, it can be +forall (k::*). k -> k. Since it does not depend on anything else, it can be kind-checked by itself, hence getting the most general kind. We then kind check X, which works fine because we then know the polymorphic kind of Id, and simply instantiate k to *. @@ -254,6 +258,10 @@ kind environment (as constructed by `getInitialKind'). In fact, we ignore instances of families altogether in the following. However, we need to include the kinds of *associated* families into the construction of the initial kind environment. (This is handled by `allDecls'). + + +See also Note [Kind checking recursive type and class declarations] + -} kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)] @@ -271,18 +279,25 @@ kcTyClGroup (TyClGroup { group_tyclds = decls }) -- 4. Generalise the inferred kinds -- See Note [Kind checking for type and class decls] - -- Step 1: Bind kind variables for non-synonyms - ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls - ; initial_kinds <- getInitialKinds non_syn_decls - ; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds) + ; lcl_env <- checkNoErrs $ + solveEqualities $ + do { + -- Step 1: Bind kind variables for non-synonyms + let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls + ; initial_kinds <- getInitialKinds non_syn_decls + ; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds) - -- Step 2: Set initial envt, kind-check the synonyms - ; lcl_env <- tcExtendKindEnv2 initial_kinds $ - kcSynDecls (calcSynCycles syn_decls) + -- Step 2: Set initial envt, kind-check the synonyms + ; lcl_env <- tcExtendKindEnv2 initial_kinds $ + kcSynDecls (calcSynCycles syn_decls) - -- Step 3: Set extended envt, kind-check the non-synonyms - ; setLclEnv lcl_env $ - mapM_ kcLTyClDecl non_syn_decls + -- Step 3: Set extended envt, kind-check the non-synonyms + ; setLclEnv lcl_env $ + tcExtendRecEnv (tcTyConPairs initial_kinds) $ + -- See Note [Kind checking recursive type and class declarations] + mapM_ kcLTyClDecl non_syn_decls + + ; return lcl_env } -- Step 4: generalisation -- Kind checking done for this group @@ -293,19 +308,26 @@ kcTyClGroup (TyClGroup { group_tyclds = decls }) ; return res } where + tcTyConPairs :: [(Name,TcTyThing)] -> [(Name,TyThing)] + tcTyConPairs initial_kinds = [ (name, ATyCon tc) + | (name, AThing kind) <- initial_kinds + , let tc = mkTcTyCon name kind ] + generalise :: TcTypeEnv -> Name -> TcM (Name, Kind) -- For polymorphic things this is a no-op generalise kind_env name = do { let kc_kind = case lookupNameEnv kind_env name of Just (AThing k) -> k _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env) - ; kvs <- kindGeneralize (tyVarsOfType kc_kind) - ; kc_kind' <- zonkTcKind kc_kind -- Make sure kc_kind' has the final, - -- skolemised kind variables + ; kvs <- kindGeneralize kc_kind + ; kc_kind' <- zonkTcTypeToType emptyZonkEnv kc_kind + + -- Make sure kc_kind' has the final, zonked kind variables ; traceTc "Generalise kind" (vcat [ ppr name, ppr kc_kind, ppr kvs, ppr kc_kind' ]) - ; return (name, mkForAllTys kvs kc_kind') } + ; return (name, mkInvForAllTys kvs kc_kind') } - generaliseTCD :: TcTypeEnv -> LTyClDecl Name -> TcM [(Name, Kind)] + generaliseTCD :: TcTypeEnv + -> LTyClDecl Name -> TcM [(Name, Kind)] generaliseTCD kind_env (L _ decl) | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl = do { first <- generalise kind_env name @@ -320,7 +342,8 @@ kcTyClGroup (TyClGroup { group_tyclds = decls }) = do { res <- generalise kind_env (tcdName decl) ; return [res] } - generaliseFamDecl :: TcTypeEnv -> FamilyDecl Name -> TcM (Name, Kind) + generaliseFamDecl :: TcTypeEnv + -> FamilyDecl Name -> TcM (Name, Kind) generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name }) = generalise kind_env name @@ -362,9 +385,10 @@ getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)] getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) = do { (cl_kind, inner_prs) <- - kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ + kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ -> do { inner_prs <- getFamDeclInitialKinds ats ; return (constraintKind, inner_prs) } + ; cl_kind <- zonkTcType cl_kind ; let main_pr = (name, AThing cl_kind) ; return (main_pr : inner_prs) } @@ -375,15 +399,16 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name = let cons = cons' -- AZ list monad coming in do { (decl_kind, _) <- - kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ + kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ -> do { res_k <- case m_sig of Just ksig -> tcLHsKind ksig Nothing -> return liftedTypeKind ; return (res_k, ()) } - ; let main_pr = (name, AThing decl_kind) - inner_prs = [ (unLoc con, APromotionErr RecDataConPE) - | L _ con' <- cons, con <- getConNames con' ] - ; return (main_pr : inner_prs) } + ; decl_kind <- zonkTcType decl_kind + ; let main_pr = (name, AThing decl_kind) + inner_prs = [ (unLoc con, APromotionErr RecDataConPE) + | L _ con' <- cons, con <- getConNames con' ] + ; return (main_pr : inner_prs) } getInitialKind (FamDecl { tcdFam = decl }) = getFamDeclInitialKind decl @@ -404,7 +429,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name , fdTyVars = ktvs , fdResultSig = L _ resultSig }) = do { (fam_kind, _) <- - kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ + kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ \_ _ -> do { res_k <- case resultSig of KindSig ki -> tcLHsKind ki TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki @@ -414,6 +439,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name -- by default | otherwise -> newMetaKindVar ; return (res_k, ()) } + ; fam_kind <- zonkTcType fam_kind ; return [ (name, AThing fam_kind) ] } ---------------- @@ -438,7 +464,7 @@ kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ do { (syn_kind, _) <- - kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $ + kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $ \_ _ -> do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs)) ; (_, rhs_kind) <- tcLHsType rhs ; traceTc "kcd2" (ppr name) @@ -479,20 +505,24 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs , tcdCtxt = ctxt, tcdSigs = sigs }) = kcTyClTyVars name hs_tvs $ do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM kc_sig) sigs } + ; mapM_ (wrapLocM kc_sig) sigs } where kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty kc_sig _ = return () --- closed type families look at their equations, but other families don't --- do anything here kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name , fdTyVars = hs_tvs - , fdInfo = ClosedTypeFamily (Just eqns) })) - = do { tc_kind <- kcLookupKind fam_tc_name - ; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind) - ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } -kcTyClDecl (FamDecl {}) = return () + , fdInfo = fd_info })) +-- closed type families look at their equations, but other families don't +-- do anything here + = case fd_info of + ClosedTypeFamily (Just eqns) -> + do { tc_kind <- kcLookupKind fam_tc_name + ; let fam_tc_shape = ( fam_tc_name + , length $ hsQTvExplicit hs_tvs + , tc_kind ) + ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } + _ -> return () ------------------- kcConDecl :: ConDecl Name -> TcM () @@ -501,11 +531,14 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs = addErrCtxt (dataConCtxtName [name]) $ -- the 'False' says that the existentials don't have a CUSK, as the -- concept doesn't really apply here. We just need to bring the variables - -- into scope! + -- into scope. do { _ <- kcHsTyVarBndrs False ((fromMaybe (HsQTvs mempty []) ex_tvs)) $ + \ _ _ -> do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt) ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) ; return (panic "kcConDecl", ()) } + -- We don't need to check the telescope here, because that's + -- done in tcConDecl ; return () } kcConDecl (ConDeclGADT { con_names = names @@ -583,6 +616,29 @@ This fancy footwork (with two bindings for T) is only necessary for the TyCons or Classes of this recursive group. Earlier, finished groups, live in the global env only. +See also Note [Kind checking recursive type and class declarations] + +Note [Kind checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before we can type-check the decls, we must kind check them. This +is done by establishing an "initial kind", which is a rather uninformed +guess at a tycon's kind (by counting arguments, mainly) and then +using this initial kind for recursive occurrences. + +The initial kind is stored in exactly the same way during kind-checking +as it is during type-checking (Note [Type checking recursive type and class +declarations]): in the *local* environment, with AThing. But we still +must store *something* in the *global* environment. Even though we +discard the result of kind-checking, we sometimes need to produce error +messages. These error messages will want to refer to the tycons being +checked, except that they don't exist yet, and it would be Terribly +Annoying to get the error messages to refer back to HsSyn. So we +create a TcTyCon and put it in the global env. This tycon can +print out its name and knows its kind, +but any other action taken on it will panic. Note +that TcTyCons are *not* knot-tied, unlike the rather valid but +knot-tied ones that occur during type-checking. + Note [Declarations for wired-in things] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For wired-in things we simply ignore the declaration @@ -612,15 +668,15 @@ tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd }) tcTyClDecl1 _parent rec_info (SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name tvs $ \ tvs' kind -> - tcTySynRhs rec_info tc_name tvs' kind rhs + tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind res_kind -> + tcTySynRhs rec_info tc_name (kvs' ++ tvs') full_kind res_kind rhs -- "data/newtype" declaration tcTyClDecl1 _parent rec_info (DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name tvs $ \ tvs' kind -> - tcDataDefn rec_info tc_name tvs' kind defn + tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind -> + tcDataDefn rec_info tc_name (kvs' ++ tvs') tycon_kind res_kind defn tcTyClDecl1 _parent rec_info (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs @@ -629,17 +685,18 @@ tcTyClDecl1 _parent rec_info , tcdATs = ats, tcdATDefs = at_defs }) = ASSERT( isNothing _parent ) do { clas <- fixM $ \ clas -> - tcTyClTyVars class_name tvs $ \ tvs' kind -> - do { MASSERT( isConstraintKind kind ) + tcTyClTyVars class_name tvs $ \ kvs' tvs' full_kind res_kind -> + do { MASSERT( isConstraintKind res_kind ) -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness - ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tvs' $$ ppr kind) + ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr kvs' $$ + ppr tvs' $$ ppr full_kind) ; let tycon_name = tyConName (classTyCon clas) tc_isrec = rti_is_rec rec_info tycon_name roles = rti_roles rec_info tycon_name - ; ctxt' <- tcHsContext ctxt + ; ctxt' <- solveEqualities $ tcHsContext ctxt ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt' -- Squeeze out any kind unification variables ; fds' <- mapM (addLocM tc_fundep) fundeps @@ -647,41 +704,31 @@ tcTyClDecl1 _parent rec_info ; at_stuff <- tcClassATs class_name clas ats at_defs ; mindef <- tcClassMinimalDef class_name sigs sig_stuff ; clas <- buildClass - class_name tvs' roles ctxt' fds' at_stuff + class_name (kvs' ++ tvs') roles ctxt' full_kind + fds' at_stuff sig_stuff mindef tc_isrec - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds') + ; traceTc "tcClassDecl" (ppr fundeps $$ ppr (kvs' ++ tvs') $$ + ppr fds') ; return clas } ; return (classTyCon clas) } where - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcFdTyVar tvs1 - ; tvs2' <- mapM tcFdTyVar tvs2 + tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; + ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; ; return (tvs1', tvs2') } -tcFdTyVar :: Located Name -> TcM TcTyVar --- Look up a type/kind variable in a functional dependency --- or injectivity annotation. In the case of kind variables, --- the environment contains a binding of the kind var to a --- a SigTv unification variables, which has now fixed. --- So we must zonk to get the real thing. Ugh! -tcFdTyVar (L _ name) - = do { tv <- tcLookupTyVar name - ; ty <- zonkTyVarOcc emptyZonkEnv tv - ; case getTyVar_maybe ty of - Just tv' -> return tv' - Nothing -> pprPanic "tcFdTyVar" (ppr name $$ ppr tv $$ ppr ty) } - tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM TyCon -tcFamDecl1 parent - (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name - , fdTyVars = tvs, fdResultSig = L _ sig - , fdInjectivityAnn = inj }) - = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do +tcFamDecl1 parent (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name + , fdTyVars = tvs, fdResultSig = L _ sig + , fdInjectivityAnn = inj }) + = tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind _res_kind -> do { traceTc "open type family:" (ppr tc_name) ; checkFamFlag tc_name - ; inj' <- tcInjectivity tvs' inj - ; let tycon = buildFamilyTyCon tc_name tvs' (resultVariableName sig) - OpenSynFamilyTyCon kind parent inj' + ; let all_tvs = kvs' ++ tvs' + ; inj' <- tcInjectivity all_tvs inj + ; let tycon = mkFamilyTyCon tc_name full_kind all_tvs + (resultVariableName sig) OpenSynFamilyTyCon + parent inj' ; return tycon } tcFamDecl1 parent @@ -693,23 +740,26 @@ tcFamDecl1 parent = do { traceTc "Closed type family:" (ppr tc_name) -- the variables in the header scope only over the injectivity -- declaration but this is not involved here - ; (tvs', inj', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind -> - do { inj' <- tcInjectivity tvs' inj - ; return (tvs', inj', kind) } + ; (tvs', inj', kind) <- tcTyClTyVars tc_name tvs + $ \ kvs' tvs' full_kind _res_kind -> + do { let all_tvs = kvs' ++ tvs' + ; inj' <- tcInjectivity all_tvs inj + ; return (all_tvs, inj', full_kind) } ; checkFamFlag tc_name -- make sure we have -XTypeFamilies -- If Nothing, this is an abstract family in a hs-boot file; -- but eqns might be empty in the Just case as well ; case mb_eqns of - Nothing -> return $ - buildFamilyTyCon tc_name tvs' (resultVariableName sig) - AbstractClosedSynFamilyTyCon kind parent inj' + Nothing -> + return $ mkFamilyTyCon tc_name kind tvs' + (resultVariableName sig) + AbstractClosedSynFamilyTyCon parent + inj' Just eqns -> do { -- Process the equations, creating CoAxBranches - ; tc_kind <- kcLookupKind tc_name - ; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind) + ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, kind) ; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns -- Do not attempt to drop equations dominated by earlier @@ -732,8 +782,8 @@ tcFamDecl1 parent | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - fam_tc = buildFamilyTyCon tc_name tvs' (resultVariableName sig) - (ClosedSynFamilyTyCon mb_co_ax) kind parent inj' + fam_tc = mkFamilyTyCon tc_name kind tvs' (resultVariableName sig) + (ClosedSynFamilyTyCon mb_co_ax) parent inj' ; return fam_tc } } @@ -741,26 +791,25 @@ tcFamDecl1 parent -- the tycon. Exception: checking equations overlap done by dropDominatedAxioms tcFamDecl1 parent - (FamilyDecl { fdInfo = DataFamily - , fdLName = L _ tc_name, fdTyVars = tvs - , fdResultSig = L _ sig }) - = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do + (FamilyDecl { fdInfo = DataFamily, fdLName = L _ tc_name + , fdTyVars = tvs, fdResultSig = L _ sig }) + = tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind -> do { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name - ; extra_tvs <- tcDataKindSig kind + ; extra_tvs <- tcDataKindSig res_kind ; tc_rep_name <- newTyConRepName tc_name - ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - tycon = buildFamilyTyCon tc_name final_tvs - (resultVariableName sig) - (DataFamilyTyCon tc_rep_name) - liftedTypeKind -- RHS kind - parent - NotInjective + ; let final_tvs = (kvs' ++ tvs') `chkAppend` extra_tvs -- we may not need these + tycon = mkFamilyTyCon tc_name tycon_kind final_tvs + (resultVariableName sig) + (DataFamilyTyCon tc_rep_name) + parent NotInjective + ; return tycon } -- | Maybe return a list of Bools that say whether a type family was declared -- injective in the corresponding type arguments. Length of the list is equal to --- the number of arguments (including implicit kind arguments). True on position +-- the number of arguments (including implicit kind/coercion arguments). +-- True on position -- N means that a function is injective in its Nth argument. False means it is -- not. tcInjectivity :: [TyVar] -> Maybe (LInjectivityAnn Name) @@ -788,8 +837,9 @@ tcInjectivity _ Nothing -- reason is that the implementation would not be straightforward.) tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ - do { inj_tvs <- mapM tcFdTyVar lInjNames - ; let inj_ktvs = closeOverKinds (mkVarSet inj_tvs) + do { inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames + ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars + closeOverKinds (mkVarSet inj_tvs) ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs , ppr inj_ktvs, ppr inj_bools ]) @@ -797,57 +847,54 @@ tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames))) tcTySynRhs :: RecTyInfo -> Name - -> [TyVar] -> Kind + -> [TyVar] -> Kind -> Kind -> LHsType Name -> TcM TyCon -tcTySynRhs rec_info tc_name tvs kind hs_ty +tcTySynRhs rec_info tc_name tvs full_kind res_kind hs_ty = do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- tcCheckLHsType hs_ty kind + ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; let roles = rti_roles rec_info tc_name - tycon = buildSynonymTyCon tc_name tvs roles rhs_ty kind + tycon = mkSynonymTyCon tc_name full_kind tvs roles rhs_ty ; return tycon } tcDataDefn :: RecTyInfo -> Name - -> [TyVar] -> Kind + -> [TyVar] -> Kind -> Kind -> HsDataDefn Name -> TcM TyCon -- NB: not used for newtype/data instances (whether associated or not) -tcDataDefn rec_info -- Knot-tied; don't look at this eagerly - tc_name tvs kind - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt, dd_kindSig = mb_ksig - , dd_cons = cons' }) +tcDataDefn rec_info -- Knot-tied; don't look at this eagerly + tc_name tvs tycon_kind res_kind + (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = ctxt, dd_kindSig = mb_ksig + , dd_cons = cons' }) = let cons = cons' -- AZ List monad coming - in do { extra_tvs <- tcDataKindSig kind - ; let final_tvs = tvs ++ extra_tvs + in do { extra_tvs <- tcDataKindSig res_kind + ; let final_tvs = tvs `chkAppend` extra_tvs roles = rti_roles rec_info tc_name - is_prom = rti_promotable rec_info -- Knot-tied - ; stupid_tc_theta <- tcHsContext ctxt - ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_tc_theta + + ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt + ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv + stupid_tc_theta ; kind_signatures <- xoptM Opt_KindSignatures ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? -- Check that we don't use kind signatures without Glasgow extensions - ; case mb_ksig of - Nothing -> return () - Just hs_k -> do { checkTc (kind_signatures) (badSigTyDecl tc_name) - ; tc_kind <- tcLHsKind hs_k - ; checkKind kind tc_kind - ; return () } + ; when (isJust mb_ksig) $ + checkTc (kind_signatures) (badSigTyDecl tc_name) ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons ; tycon <- fixM $ \ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls new_or_data is_prom tycon (final_tvs, res_ty) cons + ; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons ; tc_rhs <- mk_tc_rhs is_boot tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name - ; return (buildAlgTyCon tc_name final_tvs roles (fmap unLoc cType) - stupid_theta tc_rhs - (rti_is_rec rec_info tc_name) - is_prom - gadt_syntax - (VanillaAlgTyCon tc_rep_nm)) } + ; return (mkAlgTyCon tc_name tycon_kind final_tvs roles + (fmap unLoc cType) + stupid_theta tc_rhs + (VanillaAlgTyCon tc_rep_nm) + (rti_is_rec rec_info tc_name) + gadt_syntax) } ; return tycon } where mk_tc_rhs is_boot tycon data_cons @@ -914,7 +961,7 @@ tcClassATs class_name cls ats at_defs ; return (ATI fam_tc atd) } ------------------------- -tcDefaultAssocDecl :: TyCon -- ^ Family TyCon +tcDefaultAssocDecl :: TyCon -- ^ Family TyCon (not knot-tied) -> [LTyFamDefltEqn Name] -- ^ Defaults -> TcM (Maybe (Type, SrcSpan)) -- ^ Type checked RHS tcDefaultAssocDecl _ [] @@ -930,26 +977,37 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name = setSrcSpan loc $ tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ do { traceTc "tcDefaultAssocDecl" (ppr tc_name) - ; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc - fam_tc_tvs = tyConTyVars fam_tc + ; let shape@(fam_name, fam_pat_arity, _) = famTyConShape fam_tc + fam_tc_tvs = tyConTyVars fam_tc -- Kind of family check ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Arity check ; ASSERT( fam_name == tc_name ) - checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity) + checkTc (length (hsQTvExplicit hs_tvs) == fam_pat_arity) (wrongNumberOfParmsErr fam_pat_arity) -- Typecheck RHS - -- NB: the tcTyClTYVars call is here, /after/ the arity check - -- If the arity isn't right, tcTyClTyVars crashes (Trac #11136) - ; (tvs, rhs_ty) <- tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind -> - do { rhs_ty <- tcCheckLHsType rhs rhs_kind - ; return (tvs, rhs_ty) } + -- Oddly, we don't pass in any enclosing class info, and we treat + -- this as a top-level type instance. Type family defaults are renamed + -- outside the scope of their enclosing class and so the ClsInfo would + -- be of no use. + ; let HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } = hs_tvs + pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars + , hsib_body = map hsLTyVarBndrToType exp_vars } + -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get + -- the LHsQTyVars used for declaring a tycon, but the names here + -- are different. + ; (ktvs, rhs_ty) + <- tcFamTyPats shape Nothing pats + (discardResult . tcCheckLHsType rhs) $ \ktvs _ rhs_kind -> + do { rhs_ty <- solveEqualities $ + tcCheckLHsType rhs rhs_kind + ; return (ktvs, rhs_ty) } + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty - ; let subst = ASSERT( equalLength tvs fam_tc_tvs ) - zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs) + ; let subst = zipTopTCvSubst ktvs (mkTyVarTys fam_tc_tvs) ; return ( Just (substTy subst rhs_ty, loc) ) } -- We check for well-formedness and validity later, in checkValidClass @@ -967,37 +1025,38 @@ tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM Co -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) mb_clsinfo (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name - , tfe_pats = pats - , tfe_rhs = hs_ty })) + , tfe_pats = pats + , tfe_rhs = hs_ty })) = setSrcSpan loc $ tcFamTyPats fam_tc_shape mb_clsinfo pats (discardResult . (tcCheckLHsType hs_ty)) $ \tvs' pats' res_kind -> do { checkTc (fam_tc_name == eqn_tc_name) (wrongTyFamName fam_tc_name eqn_tc_name) - ; rhs_ty <- tcCheckLHsType hs_ty res_kind + ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty - ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> ppr tvs') + ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs') -- don't print out the pats here, as they might be zonked inside the knot - ; return (mkCoAxBranch tvs' pats' rhs_ty loc) } + ; return (mkCoAxBranch tvs' [] pats' rhs_ty loc) } -kcDataDefn :: HsDataDefn Name -> TcKind -> TcM () +kcDataDefn :: Name -- ^ the family name, for error msgs only + -> HsTyPats Name -- ^ the patterns, for error msgs only + -> HsDataDefn Name -- ^ the RHS + -> TcKind -- ^ the expected kind + -> TcM () -- Used for 'data instance' only -- Ordinary 'data' is handled by kcTyClDec -kcDataDefn (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k +kcDataDefn fam_name (HsIB { hsib_body = pats }) + (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k = do { _ <- tcHsContext ctxt ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons -- See Note [Failing early in kcDataDefn] - ; kcResultKind mb_kind res_k } - ------------------- -kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () -kcResultKind Nothing res_k - = checkKind res_k liftedTypeKind - -- type family F a - -- defaults to type family F a :: * -kcResultKind (Just k) res_k - = do { k' <- tcLHsKind k - ; checkKind k' res_k } + ; discardResult $ + case mb_kind of + Nothing -> unifyKind (Just hs_ty_pats) res_k liftedTypeKind + Just k -> do { k' <- tcLHsKind k + ; unifyKind (Just hs_ty_pats) res_k k' } } + where + hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar (noLoc fam_name)) pats {- Kind check type patterns and kind annotate the embedded type variables. @@ -1023,10 +1082,6 @@ rely on using the family TyCon, because this is sometimes called from within a type-checking knot. (Specifically for closed type families.) The type FamTyConShape gives just enough information to do the job. -The "arity" field of FamTyConShape is the *visible* arity of the family -type constructor, i.e. what the users sees and writes, not including kind -arguments. - See also Note [tc_fam_ty_pats vs tcFamTyPats] Note [Failing early in kcDataDefn] @@ -1048,7 +1103,7 @@ type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type pattern famTyConShape :: TyCon -> FamTyConShape famTyConShape fam_tc = ( tyConName fam_tc - , length (filterOut isKindVar (tyConTyVars fam_tc)) + , length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc) , tyConKind fam_tc ) tc_fam_ty_pats :: FamTyConShape @@ -1056,7 +1111,7 @@ tc_fam_ty_pats :: FamTyConShape -> HsTyPats Name -- Patterns -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored - -> TcM ([Kind], [Type], Kind) + -> TcM ([Type], Kind) -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> -- The 'tyvars' are the free type variables of pats @@ -1068,80 +1123,131 @@ tc_fam_ty_pats :: FamTyConShape -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tc_fam_ty_pats (name, arity, kind) mb_clsinfo - (HsIB { hsib_body = arg_pats, hsib_kvs = kvars - , hsib_tvs = tvars }) +tc_fam_ty_pats (name, _, kind) mb_clsinfo + (HsIB { hsib_body = arg_pats, hsib_vars = vars }) kind_checker - = do { let (fam_kvs, fam_body) = splitForAllTys kind - - -- The splitKindFunTysN below will panic - -- if there are too many patterns. So, we do a validity check here. - ; checkTc (length arg_pats == arity) $ - wrongNumberOfParmsErr arity - - -- Instantiate with meta kind vars (or instance kinds) - ; fam_arg_kinds <- case mb_clsinfo of - Nothing -> mapM (const newMetaKindVar) fam_kvs - Just (_, mini_env) -> mapM mk_arg_kind fam_kvs - where - mk_arg_kind kv - | Just kind <- lookupVarEnv mini_env kv - = return kind - | otherwise - = newMetaKindVar - - ; loc <- getSrcSpanM - ; let (arg_kinds, res_kind) - = splitKindFunTysN (length arg_pats) $ - substKiWith fam_kvs fam_arg_kinds fam_body - -- Treat (anonymous) wild cards as type variables without a name. - -- See Note [Wild cards in family instances] - wcs = concatMap collectAnonWildCards arg_pats - anon_tvs = [L loc (UserTyVar (L loc wc)) - | wc <- wcs - , let loc = nameSrcSpan wc ] - hs_tvs = HsQTvs { hsq_kvs = kvars - , hsq_tvs = anon_tvs ++ userHsTyVarBndrs loc tvars } + = do { -- See Note [Wild cards in family instances] + ; let wcs = concatMap collectAnonWildCards arg_pats + tv_names = vars ++ wcs -- Kind-check and quantify -- See Note [Quantifying over family patterns] - ; typats <- tcHsQTyVars hs_tvs $ \ _ -> - do { kind_checker res_kind - ; tcHsArgTys (quotes (ppr name)) arg_pats arg_kinds } - - ; return (fam_arg_kinds, typats, res_kind) } + ; (_, (res_kind, typats)) <- tcImplicitTKBndrs tv_names $ + do { (res_kind, args, leftovers, n) + <- tcInferArgs name kind (snd <$> mb_clsinfo) arg_pats + ; case leftovers of + hs_ty:_ -> addErrTc $ too_many_args hs_ty n + _ -> return () + ; kind_checker res_kind + ; return ((res_kind, args), emptyVarSet) } + + ; return (typats, res_kind) } + where + too_many_args hs_ty n + = hang (text "Too many parameters to" <+> ppr name <> colon) + 2 (vcat [ ppr hs_ty <+> text "is unexpected;" + , text "expected only" <+> + speakNOf (n-1) (text "parameter") ]) -- See Note [tc_fam_ty_pats vs tcFamTyPats] tcFamTyPats :: FamTyConShape -> Maybe ClsInfo - -> HsTyPats Name -- patterns + -> HsTyPats Name -- patterns -> (TcKind -> TcM ()) -- kind-checker for RHS - -> ([TKVar] -- Kind and type variables + -> ( [TyVar] -- Kind and type variables -> [TcType] -- Kind and type arguments - -> Kind -> TcM a) + -> Kind -> TcM a) -- NB: You can use solveEqualities here. -> TcM a tcFamTyPats fam_shape@(name,_,_) mb_clsinfo pats kind_checker thing_inside - = do { (fam_arg_kinds, typats, res_kind) - <- tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker - ; let all_args = fam_arg_kinds ++ typats + = do { (typats, res_kind) + <- checkNoErrs $ -- we'll get duplicate errors if we continue. + solveEqualities $ -- See Note [Constraints in patterns] + tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker + + {- TODO (RAE): This should be cleverer. Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + + This should probably be accepted. Yet the solveEqualities + will fail, unable to solve (F a ~ Bool) + We want to quantify over that proof. + But see Note [Constraints in patterns] + below, which is missing this piece. -} + -- Find free variables (after zonking) and turn -- them into skolems, so that we don't subsequently - -- replace a meta kind var with AnyK + -- replace a meta kind var with (Any *) -- Very like kindGeneralize - ; qtkvs <- quantifyTyVars emptyVarSet (tyVarsOfTypes all_args) + ; qtkvs <- quantifyTyVars emptyVarSet $ + splitDepVarsOfTypes typats + + ; MASSERT( isEmptyVarSet $ coVarsOfTypes typats ) + -- This should be the case, because otherwise the solveEqualities + -- above would fail. TODO (RAE): Update once the solveEqualities + -- bit is cleverer. -- Zonk the patterns etc into the Type world ; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs - ; all_args' <- zonkTcTypeToTypes ze all_args + ; typats' <- zonkTcTypeToTypes ze typats ; res_kind' <- zonkTcTypeToType ze res_kind - ; traceTc "tcFamTyPats" (ppr name) + ; traceTc "tcFamTyPats" (ppr name $$ ppr typats) -- don't print out too much, as we might be in the knot ; tcExtendTyVarEnv qtkvs' $ - thing_inside qtkvs' all_args' res_kind' } + thing_inside qtkvs' typats' res_kind' } {- +Note [Constraints in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This isn't the whole story. See comment in tcFamTyPats. + +At first glance, it seems there is a complicated story to tell in tcFamTyPats +around constraint solving. After all, type family patterns can now do +GADT pattern-matching, which is jolly complicated. But, there's a key fact +which makes this all simple: everything is at top level! There cannot +be untouchable type variables. There can't be weird interaction between +case branches. There can't be global skolems. + +This means that the semantics of type-level GADT matching is a little +different than term level. If we have + + data G a where + MkGBool :: G Bool + +And then + + type family F (a :: G k) :: k + type instance F MkGBool = True + +we get + + axF : F Bool (MkGBool <Bool>) ~ True + +Simple! No casting on the RHS, because we can affect the kind parameter +to F. + +If we ever introduce local type families, this all gets a lot more +complicated, and will end up looking awfully like term-level GADT +pattern-matching. + + +** The new story ** + +Here is really what we want: + +The matcher really can't deal with covars in arbitrary spots in coercions. +But it can deal with covars that are arguments to GADT data constructors. +So we somehow want to allow covars only in precisely those spots, then use +them as givens when checking the RHS. TODO (RAE): Implement plan. + + Note [Quantifying over family patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to quantify over two different lots of kind variables: @@ -1157,7 +1263,7 @@ tcTyVarBndrsKindGen, as usual -- The 'k' comes from the tcTyVarBndrsKindGen (a::k) Second, the ones that come from the kind argument of the type family -which we pick up using the (tyVarsOfTypes typats) in the result of +which we pick up using the (tyCoVarsOfTypes typats) in the result of the thing_inside of tcHsTyvarBndrsGen. -- Any :: forall k. k data instance Dist Any = DA @@ -1173,7 +1279,7 @@ Consider type family KindFam (p :: k1) (q :: k1) The HsBSig for the family patterns will be ([k], [a]) Then in the family instance we want to - * Bring into scope [ "k" -> k:BOX, "a" -> a:k ] + * Bring into scope [ "k" -> k:*, "a" -> a:k ] * Kind-check the RHS * Quantify the type instance over k and k', as well as a,b, thus type instance [k, k', a:Maybe k, b:k'] @@ -1252,50 +1358,48 @@ consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- -tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type) +tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] -tcConDecls new_or_data is_prom rep_tycon (tmpl_tvs, res_tmpl) +tcConDecls new_or_data rep_tycon (tmpl_tvs, res_tmpl) = concatMapM $ addLocM $ - tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl + tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl tcConDecl :: NewOrData - -> Bool -- TyCon is promotable? Knot-tied! -> TyCon -- Representation tycon. Knot-tied! -> [TyVar] -> Type -- Return type template (with its template tyvars) -- (tvs, T tys), where T is the family TyCon -> ConDecl Name -> TcM [DataCon] -tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl +tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl (ConDeclH98 { con_name = name - , con_qvars = hs_tvs, con_cxt = hs_ctxt + , con_qvars = hs_qvars, con_cxt = hs_ctxt , con_details = hs_details }) = addErrCtxt (dataConCtxtName [name]) $ do { traceTc "tcConDecl 1" (ppr name) - ; (ctxt, arg_tys, field_lbls, stricts) - <- tcHsQTyVars (fromMaybe (HsQTvs [] []) hs_tvs) $ \ _ -> + ; let (hs_kvs, hs_tvs) = case hs_qvars of + Nothing -> ([], []) + Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) + -> (kvs, tvs) + ; (kvs, (ctxt, arg_tys, field_lbls, stricts, tvs)) + <- solveEqualities $ + tcImplicitTKBndrs hs_kvs $ + tcHsTyVarBndrs hs_tvs $ \tvs -> do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs) ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt) ; btys <- tcConArgs new_or_data hs_details ; field_lbls <- lookupConstructorFields (unLoc name) ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, field_lbls, stricts) + bound_vars = allBoundVariabless ctxt `unionVarSet` + allBoundVariabless arg_tys + ; return ((ctxt, arg_tys, field_lbls, stricts, tvs), bound_vars) } - ; tkvs <- quantifyTyVars (mkVarSet tmpl_tvs) - (tyVarsOfTypes (ctxt++arg_tys)) - -- Zonk to Types - ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs + ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (kvs ++ tvs) ; arg_tys <- zonkTcTypeToTypes ze arg_tys ; ctxt <- zonkTcTypeToTypes ze ctxt - ; let (univ_tvs, ex_tvs, eq_preds) = (tmpl_tvs, qtkvs, []) - -- AZ:TODO: Is this comment needed here for ConDeclH98? - -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon - -- without yet forcing the guards in rejigConRes - -- See Note [Checking GADT return types] - ; fam_envs <- tcGetFamInstEnvs -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here @@ -1305,11 +1409,9 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl { is_infix <- tcConIsInfixH98 name hs_details ; rep_nm <- newTyConRepName name - ; buildDataCon fam_envs name is_infix - (if is_prom then Promoted rep_nm else NotPromoted) - -- Must be lazy in is_prom because it is knot-tied + ; buildDataCon fam_envs name is_infix rep_nm stricts Nothing field_lbls - univ_tvs ex_tvs eq_preds ctxt arg_tys + tmpl_tvs qtkvs [{- no eq_preds -}] ctxt arg_tys res_tmpl rep_tycon -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; @@ -1319,14 +1421,14 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl ; mapM buildOneDataCon [name] } -tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl +tcConDecl _new_or_data rep_tycon tmpl_tvs res_tmpl (ConDeclGADT { con_names = names, con_type = ty }) = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) ; (ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details) <- tcGadtSigType (ppr names) (unLoc $ head names) ty ; tkvs <- quantifyTyVars emptyVarSet - (tyVarsOfTypes (res_ty:ctxt++arg_tys)) + (splitDepVarsOfTypes (res_ty:ctxt++arg_tys)) -- Zonk to Types ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs @@ -1334,8 +1436,9 @@ tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl ; ctxt <- zonkTcTypeToTypes ze ctxt ; res_ty <- zonkTcTypeToType ze res_ty - ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty - -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon + ; let (univ_tvs, ex_tvs, eq_preds, res_ty', arg_subst) + = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty + -- NB: this is a /lazy/ binding, so we pass five thunks to buildDataCon -- without yet forcing the guards in rejigConRes -- See Note [Checking GADT return types] @@ -1349,11 +1452,13 @@ tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl ; rep_nm <- newTyConRepName name ; buildDataCon fam_envs name is_infix - (if is_prom then Promoted rep_nm else NotPromoted) - -- Must be lazy in is_prom because it is knot-tied + rep_nm stricts Nothing field_lbls - univ_tvs ex_tvs eq_preds ctxt arg_tys - res_ty' rep_tycon + univ_tvs ex_tvs eq_preds + (substTys arg_subst ctxt) + (substTys arg_subst arg_tys) + (substTy arg_subst res_ty') + rep_tycon -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. @@ -1364,22 +1469,25 @@ tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl tcGadtSigType :: SDoc -> Name -> LHsSigType Name - -> TcM ([PredType],[HsSrcBang], [FieldLabel], [Type], Type - ,HsConDetails (LHsType Name) (Located [LConDeclField Name])) -tcGadtSigType doc name ty@(HsIB { hsib_kvs = kvs, hsib_tvs = tvs}) - = do { let (hs_details',res_ty',cxt,gtvs) = gadtDeclDetails ty - ; (hs_details,res_ty) <- tcUpdateConResult doc hs_details' res_ty' - ; let hs_tvs = HsQTvs { hsq_kvs = kvs - , hsq_tvs = gtvs ++ - map (noLoc . UserTyVar . noLoc) tvs } - ; (ctxt, arg_tys, res_ty, field_lbls, stricts) - <- tcHsQTyVars hs_tvs $ \ _ -> + -> TcM ( [PredType],[HsSrcBang], [FieldLabel], [Type], Type + , HsConDetails (LHsType Name) + (Located [LConDeclField Name]) ) +tcGadtSigType doc name ty@(HsIB { hsib_vars = vars }) + = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty + ; (hs_details, res_ty) <- tcUpdateConResult doc hs_details' res_ty' + ; (_, (ctxt, arg_tys, res_ty, field_lbls, stricts)) + <- solveEqualities $ + tcImplicitTKBndrs vars $ + tcHsTyVarBndrs gtvs $ \ _ -> do { ctxt <- tcHsContext cxt ; btys <- tcConArgs DataType hs_details ; ty' <- tcHsLiftedType res_ty ; field_lbls <- lookupConstructorFields name ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, ty', field_lbls, stricts) + bound_vars = allBoundVariabless ctxt `unionVarSet` + allBoundVariabless arg_tys + + ; return ((ctxt, arg_tys, ty', field_lbls, stricts), bound_vars) } ; return (ctxt,stricts,field_lbls,arg_tys,res_ty,hs_details) } @@ -1496,8 +1604,8 @@ defined yet. So, we want to make rejigConRes lazy and then check the validity of the return type in checkValidDataCon. To do this we /always/ return a -4-tuple from rejigConRes (so that we can extract ret_ty from it, which -checkValidDataCon needs), but the first three fields may be bogus if +5-tuple from rejigConRes (so that we can extract ret_ty from it, which +checkValidDataCon needs), but the first four fields may be bogus if the return type isn't valid (the last equation for rejigConRes). This is better than an earlier solution which reduced the number of @@ -1513,15 +1621,17 @@ errors reported in one pass. See Trac #7175, and #10836. -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 -- In this case orig_res_ty = T (e,e) -rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. - -- data instance T [a] b c = ... - -- gives template ([a,b,c], T [a] b c) - -> [TyVar] -- where MkT :: forall x y z. ... - -> Type -- res_ty - -> ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [(TyVar,Type)], -- Equality predicates - Type) -- Typechecked return type +rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. + -- data instance T [a] b c = ... + -- gives template ([a,b,c], T [a] b c) + -- Type must be of kind *! + -> [TyVar] -- where MkT :: forall x y z. ... + -> Type -- res_ty type must be of kind * + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [EqSpec], -- Equality predicates + Type, -- Typechecked return type + TCvSubst) -- Substitution to apply to argument types -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because checkValidDataCon will do it @@ -1537,10 +1647,19 @@ rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty -- z -- Existentials are the leftover type vars: [x,y] -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) - | Just subst <- tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty - , (univ_tvs, eq_spec) <- foldr (choose subst) ([], []) tmpl_tvs - , let ex_tvs = dc_tvs `minusList` univ_tvs - = (univ_tvs, ex_tvs, eq_spec, res_ty) + | Just subst <- ASSERT( isLiftedTypeKind (typeKind res_ty) ) + ASSERT( isLiftedTypeKind (typeKind res_tmpl) ) + tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty + = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst + raw_ex_tvs = dc_tvs `minusList` univ_tvs + (arg_subst, substed_ex_tvs) + = mapAccumL substTyVarBndr kind_subst raw_ex_tvs + + -- don't use substCoVarBndr because we don't want fresh uniques! + -- substed_ex_tvs and raw_eq_cvs may dependent on one another + substed_eqs = map (substEqSpec arg_subst) raw_eqs + in + (univ_tvs, substed_ex_tvs, substed_eqs, res_ty, arg_subst) | otherwise -- If the return type of the data constructor doesn't match the parent @@ -1553,54 +1672,250 @@ rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty -- albeit bogus, relying on checkValidDataCon to check the -- bad-result-type error before seeing that the other fields look odd -- See Note [Checking GADT return types] - = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, [], res_ty) + = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, [], res_ty, emptyTCvSubst) + where - -- Figure out the univ_tvs etc - -- Each univ_tv is either a dc_tv or a tmpl_tv - choose subst tmpl (univs, eqs) - | Just ty <- lookupTyVar subst tmpl - = case tcGetTyVar_maybe ty of - Just tv | not (tv `elem` univs) - -> (tv:univs, eqs) - _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) - where -- see Note [Substitution in template variables kinds] - new_tmpl = updateTyVarKind (substTy subst) tmpl - | otherwise = pprPanic "tcResultType" (ppr res_ty) +{- +Note [mkGADTVars] +~~~~~~~~~~~~~~~~~ + +Running example: + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: T x1 * (Proxy (y :: x1), z) z + +We need the rejigged type to be + + MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). + forall (y :: x1) (z :: *). + (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) + => T x1 k2 a b + +You might naively expect that z should become a universal tyvar, +not an existential. (After all, x1 becomes a universal tyvar.) +The problem is that the universal tyvars must have exactly the +same kinds as the tyConTyVars. z has kind * while b has kind k2. +So we need an existential tyvar and a heterogeneous equality +constraint. (The b ~ z is a bit redundant with the k2 ~ * that +comes before in that b ~ z implies k2 ~ *. I'm sure we could do +some analysis that could eliminate k2 ~ *. But we don't do this +yet.) + +The HsTypes have already been desugared to proper Types: + + T x1 * (Proxy (y :: x1), z) z +becomes + [x1 :: *, y :: x1, z :: *]. T x1 * (Proxy x1 y, z) z + +We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We +know this match will succeed because of the validity check (actually done +later, but laziness saves us -- see Note [Checking GADT return types]). +Thus, we get + + subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } + +Now, we need to figure out what the GADT equalities should be. In this case, +we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a +renaming. The others should be GADT equalities. We also need to make +sure that the universally-quantified variables of the datacon match up +with the tyvars of the tycon, as required for Core context well-formedness. +(This last bit is why we have to rejig at all!) + +`choose` walks down the tycon tyvars, figuring out what to do with each one. +It carries two substitutions: + - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables + mentioned in the datacon signature. + - r_sub's domain is *result* tyvars, names written by the programmer in + the datacon signature. The final rejigged type will use these names, but + the subst is still needed because sometimes the printed name of these variables + is different. (See choose_tv_name, below.) + +Before explaining the details of `choose`, let's just look at its operation +on our example: + + choose [] [] {} {} [k1, k2, a, b] + --> -- first branch of `case` statement + choose + univs: [x1 :: *] + eq_spec: [] + t_sub: {k1 |-> x1} + r_sub: {x1 |-> x1} + t_tvs: [k2, a, b] + --> -- second branch of `case` statement + choose + univs: [k2 :: *, x1 :: *] + eq_spec: [k2 ~ *] + t_sub: {k1 |-> x1, k2 |-> k2} + r_sub: {x1 |-> x1} + t_tvs: [a, b] + --> -- second branch of `case` statement + choose + univs: [a :: k2, k2 :: *, x1 :: *] + eq_spec: [ a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} + r_sub: {x1 |-> x1} + t_tvs: [b] + --> -- second branch of `case` statement + choose + univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] + eq_spec: [ b ~ z + , a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} + r_sub: {x1 |-> x1} + t_tvs: [] + --> -- end of recursion + ( [x1 :: *, k2 :: *, a :: k2, b :: k2] + , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] + , {x1 |-> x1} ) + +`choose` looks up each tycon tyvar in the matching (it *must* be matched!). If +it finds a bare result tyvar (the first branch of the `case` statement), it +checks to make sure that the result tyvar isn't yet in the list of univ_tvs. +If it is in that list, then we have a repeated variable in the return type, +and we in fact need a GADT equality. We then check to make sure that the +kind of the result tyvar matches the kind of the template tyvar. This +check is what forces `z` to be existential, as it should be, explained above. +Assuming no repeated variables or kind-changing, we wish +to use the variable name given in the datacon signature (that is, `x1` not +`k1`), not the tycon signature (which may have been made up by +GHC). So, we add a mapping from the tycon tyvar to the result tyvar to t_sub. + +If we discover that a mapping in `subst` gives us a non-tyvar (the second +branch of the `case` statement), then we have a GADT equality to create. +We create a fresh equality, but we don't extend any substitutions. The +template variable substitution is meant for use in universal tyvar kinds, +and these shouldn't be affected by any GADT equalities. + +This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways +of simplifying it: + +1) The first branch of the `case` statement is really an optimization, used +in order to get fewer GADT equalities. It might be possible to make a GADT +equality for *every* univ. tyvar, even if the equality is trivial, and then +either deal with the bigger type or somehow reduce it later. + +2) This algorithm strives to use the names for type variables as specified +by the user in the datacon signature. If we always used the tycon tyvar +names, for example, this would be simplified. This change would almost +certainly degrade error messages a bit, though. +-} + +-- ^ From information about a source datacon definition, extract out +-- what the universal variables and the GADT equalities should be. +-- See Note [mkGADTVars]. +mkGADTVars :: [TyVar] -- ^ The tycon vars + -> [TyVar] -- ^ The datacon vars + -> TCvSubst -- ^ The matching between the template result type + -- and the actual result type + -> ( [TyVar] + , [EqSpec] + , TCvSubst ) -- ^ The univ. variables, the GADT equalities, + -- and a subst to apply to the GADT equalities + -- and existentials. +mkGADTVars tmpl_tvs dc_tvs subst + = choose [] [] empty_subst empty_subst tmpl_tvs + where + in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) + empty_subst = mkEmptyTCvSubst in_scope + + choose :: [TyVar] -- accumulator of univ tvs, reversed + -> [EqSpec] -- accumulator of GADT equalities, reversed + -> TCvSubst -- template substutition + -> TCvSubst -- res. substitution + -> [TyVar] -- template tvs (the univ tvs passed in) + -> ( [TyVar] -- the univ_tvs + , [EqSpec] -- GADT equalities + , TCvSubst ) -- a substitution to fix kinds in ex_tvs + + choose univs eqs _t_sub r_sub [] + = (reverse univs, reverse eqs, r_sub) + choose univs eqs t_sub r_sub (t_tv:t_tvs) + | Just r_ty <- lookupTyVar subst t_tv + = case getTyVar_maybe r_ty of + Just r_tv + | not (r_tv `elem` univs) + , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) + -> -- simple, well-kinded variable substitution. + choose (r_tv:univs) eqs + (extendTCvSubst t_sub t_tv r_ty) + (extendTCvSubst r_sub r_tv r_ty) + t_tvs + where + r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) + r_ty = mkTyVarTy r_tv1 + + -- not a simple substitution. make an equality predicate + _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) + t_sub r_sub t_tvs + where t_tv' = updateTyVarKind (substTy t_sub) t_tv + + | otherwise + = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) + + -- choose an appropriate name for a univ tyvar. + -- This *must* preserve the Unique of the result tv, so that we + -- can detect repeated variables. It prefers user-specified names + -- over system names. A result variable with a system name can + -- happen with GHC-generated implicit kind variables. + choose_tv_name :: TyVar -> TyVar -> Name + choose_tv_name r_tv t_tv + | isSystemName r_tv_name + = setNameUnique t_tv_name (getUnique r_tv_name) + + | otherwise + = r_tv_name + + where + r_tv_name = getName r_tv + t_tv_name = getName t_tv {- Note [Substitution in template variables kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -data List a = Nil | Cons a (List a) -data SList s as where - SNil :: SList s Nil +data G (a :: Maybe k) where + MkG :: G Nothing -We call tcResultType with - tmpl_tvs = [(k :: BOX), (s :: k -> *), (as :: List k)] - res_tmpl = SList k s as - res_ty = (SList k1 (s1 :: k1 -> *) (Nil k1)) +With explicit kind variables -We get subst: - k -> k1 - s -> s1 - as -> Nil k1 +data G k (a :: Maybe k) where + MkG :: G k1 (Nothing k1) -Now we want to find out the universal variables and the equivalences -between some of them and types (GADT). +Note how k1 is distinct from k. So, when we match the template +`G k a` against `G k1 (Nothing k1)`, we get a subst +[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two +mappings, we surely don't want to add (k, k1) to the list of +GADT equalities -- that would be overly complex and would create +more untouchable variables than we need. So, when figuring out +which tyvars are GADT-like and which aren't (the fundamental +job of `choose`), we want to treat `k` as *not* GADT-like. +Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) +instead of (a :: Maybe k). This is the reason for dealing +with a substitution in here. -In this example, k and s are mapped to exactly variables which are not -already present in the universal set, so we just add them without any -coercion. +However, we do not *always* want to substitute. Consider -But 'as' is mapped to 'Nil k1', so we add 'as' to the universal set, -and add the equivalence with 'Nil k1' in 'eqs'. +data H (a :: k) where + MkH :: H Int -The problem is that with kind polymorphism, as's kind may now contain -kind variables, and we have to apply the template substitution to it, -which is why we create new_tmpl. +With explicit kind variables: -The template substitution only maps kind variables to kind variables, -since GADTs are not kind indexed. +data H k (a :: k) where + MkH :: H * Int + +Here, we have a kind-indexed GADT. The subst in question is +[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s +kind, because that would give a constructor with the type + +MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a + +The problem here is that a's kind is wrong -- it needs to be k, not *! +So, if the matching for a variable is anything but another bare variable, +we drop the mapping from the substitution before proceeding. This +was not an issue before kind-indexed GADTs because this case could +never happen. ************************************************************************ * * @@ -1655,42 +1970,45 @@ checkValidTyCon tc | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim = return () - | Just cl <- tyConClass_maybe tc - = checkValidClass cl - - | Just syn_rhs <- synTyConRhs_maybe tc - = checkValidType syn_ctxt syn_rhs - - | Just fam_flav <- famTyConFlav_maybe tc - = case fam_flav of - { ClosedSynFamilyTyCon (Just ax) -> tcAddClosedTypeFamilyDeclCtxt tc $ - checkValidCoAxiom ax - ; ClosedSynFamilyTyCon Nothing -> return () - ; AbstractClosedSynFamilyTyCon -> - do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ - ptext (sLit "You may define an abstract closed type family") $$ - ptext (sLit "only in a .hs-boot file") } - ; DataFamilyTyCon {} -> return () - ; OpenSynFamilyTyCon -> return () - ; BuiltInSynFamTyCon _ -> return () } - | otherwise - = do { -- Check the context on the data decl - traceTc "cvtc1" (ppr tc) - ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) - - ; traceTc "cvtc2" (ppr tc) - - ; dflags <- getDynFlags - ; existential_ok <- xoptM Opt_ExistentialQuantification - ; gadt_ok <- xoptM Opt_GADTs - ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context - ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons - - -- Check that fields with the same name share a type - ; mapM_ check_fields groups } - + = do { checkValidTyConTyVars tc + ; if | Just cl <- tyConClass_maybe tc + -> checkValidClass cl + + | Just syn_rhs <- synTyConRhs_maybe tc + -> checkValidType syn_ctxt syn_rhs + + | Just fam_flav <- famTyConFlav_maybe tc + -> case fam_flav of + { ClosedSynFamilyTyCon (Just ax) + -> tcAddClosedTypeFamilyDeclCtxt tc $ + checkValidCoAxiom ax + ; ClosedSynFamilyTyCon Nothing -> return () + ; AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBootOrSig + ; checkTc hsBoot $ + text "You may define an abstract closed type family" $$ + text "only in a .hs-boot file" } + ; DataFamilyTyCon {} -> return () + ; OpenSynFamilyTyCon -> return () + ; BuiltInSynFamTyCon _ -> return () } + + | otherwise -> do + { -- Check the context on the data decl + traceTc "cvtc1" (ppr tc) + ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) + + ; traceTc "cvtc2" (ppr tc) + + ; dflags <- getDynFlags + ; existential_ok <- xoptM Opt_ExistentialQuantification + ; gadt_ok <- xoptM Opt_GADTs + ; let ex_ok = existential_ok || gadt_ok + -- Data cons can have existential context + ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons + + -- Check that fields with the same name share a type + ; mapM_ check_fields groups }} where syn_ctxt = TySynCtxt name name = tyConName tc @@ -1701,7 +2019,7 @@ checkValidTyCon tc get_fields con = dataConFieldLabels con `zip` repeat con -- dataConFieldLabels may return the empty list, which is fine - -- See Note [GADT record selectors] in MkId.hs + -- See Note [GADT record selectors] in TcTyDecls -- We must check (a) that the named field has the same -- type in each constructor -- (b) that those constructors have the same result type @@ -1747,6 +2065,35 @@ checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 ------------------------------- +-- | Check for ill-scoped telescopes in a tycon. +-- For example: +-- +-- > data SameKind :: k -> k -> * -- this is OK +-- > data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) +-- +-- The problem is that @b@ should be bound (implicitly) at the beginning, +-- but its kind mentions @a@, which is not yet in scope. Kind generalization +-- makes a mess of this, and ends up including @a@ twice in the final +-- tyvars. So this function checks for duplicates and, if there are any, +-- produces the appropriate error message. +checkValidTyConTyVars :: TyCon -> TcM () +checkValidTyConTyVars tc + = when duplicate_vars $ + do { -- strip off the duplicates and look for ill-scoped things + -- but keep the *last* occurrence of each variable, as it's + -- most likely the one the user wrote + let stripped_tvs = reverse $ nub $ reverse tvs + vis_tvs = filterOutInvisibleTyVars tc tvs + extra | not (vis_tvs `equalLength` stripped_tvs) + = text "NB: Implicitly declared kind variables are put first." + | otherwise + = empty + ; checkValidTelescope (pprTvBndrs vis_tvs) stripped_tvs extra } + where + tvs = tyConTyVars tc + duplicate_vars = sizeVarSet (mkVarSet tvs) < length tvs + +------------------------------- checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ @@ -1765,10 +2112,20 @@ checkValidDataCon dflags existential_ok tc con , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) + ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) res_ty_tmpl orig_res_ty)) (badDataConTyCon con res_ty_tmpl orig_res_ty) + -- Note that checkTc aborts if it finds an error. This is + -- critical to avoid panicking when we call dataConUserType + -- on an un-rejiggable datacon! + + ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) + + -- Check that existentials are allowed if they are used + ; checkTc (existential_ok || isVanillaDataCon con) + (badExistential con) -- Check that the result type is a *monotype* -- e.g. reject this: MkT :: T (forall a. a->a) @@ -1786,17 +2143,6 @@ checkValidDataCon dflags existential_ok tc con -- data T = MkT {-# UNPACK #-} !a -- Can't unpack ; mapM_ check_bang (zip3 (dataConSrcBangs con) (dataConImplBangs con) [1..]) - -- Check that existentials are allowed if they are used - ; checkTc (existential_ok || isVanillaDataCon con) - (badExistential con) - - -- Check that we aren't doing GADT type refinement on kind variables - -- e.g reject data T (a::k) where - -- T1 :: T Int - -- T2 :: T Maybe - ; checkTc (not (any (isKindVar . fst) (dataConEqSpec con))) - (badGadtKindCon con) - ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con)) } where @@ -1849,8 +2195,8 @@ checkNewDataCon con -- No strictness annotations } where - (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con - + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig con check_con what msg = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) @@ -1891,7 +2237,8 @@ checkValidClass cls ; mapM_ check_at at_stuff } where (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - cls_arity = count isTypeVar tyvars -- Ignore kind variables + cls_arity = length $ filterOutInvisibleTyVars (classTyCon cls) tyvars + -- Ignore invisible variables cls_tv_set = mkVarSet tyvars check_op constrained_class_methods (sel_id, dm) @@ -1921,7 +2268,7 @@ checkValidClass cls check_constraint :: TcPredType -> TcM () check_constraint pred - = when (tyVarsOfType pred `subVarSet` cls_tv_set) + = when (tyCoVarsOfType pred `subVarSet` cls_tv_set) (addErrTc (badMethPred sel_id pred)) check_at (ATI fam_tc m_dflt_rhs) @@ -1933,7 +2280,7 @@ checkValidClass cls -- since there is no possible ambiguity (Trac #10020) ; whenIsJust m_dflt_rhs $ \ (rhs, loc) -> checkValidTyFamEqn (Just (cls, mini_env)) fam_tc - fam_tvs (mkTyVarTys fam_tvs) rhs loc } + fam_tvs [] (mkTyVarTys fam_tvs) rhs loc } where fam_tvs = tyConTyVars fam_tc mini_env = zipVarEnv tyvars (mkTyVarTys tyvars) @@ -1978,14 +2325,15 @@ checkValidRoleAnnots role_annots tc | isAlgTyCon tc = check_roles | otherwise = return () where - -- Role annotations are given only on *type* variables, but a tycon stores - -- roles for all variables. So, we drop the kind roles (which are all - -- Nominal, anyway). + -- Role annotations are given only on *explicit* variables, + -- but a tycon stores roles for all variables. + -- So, we drop the implicit roles (which are all Nominal, anyway). name = tyConName tc tyvars = tyConTyVars tc roles = tyConRoles tc - (kind_vars, type_vars) = span isKindVar tyvars - type_roles = dropList kind_vars roles + (vis_roles, vis_vars) = unzip $ snd $ + partitionInvisibles tc (mkTyVarTy . snd) $ + zip roles tyvars role_annot_decl_maybe = lookupRoleAnnots role_annots name check_roles @@ -1995,16 +2343,16 @@ checkValidRoleAnnots role_annots tc setSrcSpan loc $ do { role_annots_ok <- xoptM Opt_RoleAnnotations ; checkTc role_annots_ok $ needXRoleAnnotations tc - ; checkTc (type_vars `equalLength` the_role_annots) - (wrongNumberOfRoles type_vars decl) - ; _ <- zipWith3M checkRoleAnnot type_vars the_role_annots type_roles + ; checkTc (vis_vars `equalLength` the_role_annots) + (wrongNumberOfRoles vis_vars decl) + ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles -- Representational or phantom roles for class parameters -- quickly lead to incoherence. So, we require -- IncoherentInstances to have them. See #8773. ; incoherent_roles_ok <- xoptM Opt_IncoherentInstances ; checkTc ( incoherent_roles_ok || (not $ isClassTyCon tc) - || (all (== Nominal) type_roles)) + || (all (== Nominal) vis_roles)) incoherentRoles ; lint <- goptM Opt_DoCoreLinting @@ -2039,10 +2387,11 @@ checkValidRoles tc eqSpecPreds eq_spec ++ theta ++ arg_tys } -- See Note [Role-checking data constructor arguments] in TcTyDecls where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon univ_roles = zipVarEnv univ_tvs (tyConRoles tc) -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs - ex_roles = mkVarEnv (zip ex_tvs (repeat Nominal)) + ex_roles = mkVarEnv (map (, Nominal) ex_tvs) role_env = univ_roles `plusVarEnv` ex_roles check_ty_roles env role (TyVarTy tv) @@ -2068,15 +2417,23 @@ checkValidRoles tc = check_ty_roles env role ty1 >> check_ty_roles env Nominal ty2 - check_ty_roles env role (FunTy ty1 ty2) + check_ty_roles env role (ForAllTy (Anon ty1) ty2) = check_ty_roles env role ty1 >> check_ty_roles env role ty2 - check_ty_roles env role (ForAllTy tv ty) - = check_ty_roles (extendVarEnv env tv Nominal) role ty + check_ty_roles env role (ForAllTy (Named tv _) ty) + = check_ty_roles env Nominal (tyVarKind tv) + >> check_ty_roles (extendVarEnv env tv Nominal) role ty check_ty_roles _ _ (LitTy {}) = return () + check_ty_roles env role (CastTy t _) + = check_ty_roles env role t + + check_ty_roles _ role (CoercionTy co) + = unless (role == Phantom) $ + report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role + maybe_check_ty_roles env role ty = when (role == Nominal || role == Representational) $ check_ty_roles env role ty @@ -2195,12 +2552,6 @@ badDataConTyCon data_con res_ty_tmpl actual_res_ty ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) -badGadtKindCon :: DataCon -> SDoc -badGadtKindCon data_con - = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) - <+> ptext (sLit "cannot be GADT-like in its *kind* arguments")) - 2 (ppr data_con <+> dcolon <+> ppr (dataConUserType data_con)) - badGadtDecl :: Name -> SDoc badGadtDecl tc_name = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index ab63e8c070..4798463298 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -31,7 +31,7 @@ import TcRnMonad import TcEnv import TcTypeable( mkTypeableBinds ) import TcBinds( tcRecSelBinds ) -import TypeRep( Type(..) ) +import TyCoRep( Type(..), TyBinder(..), delBinderVar ) import TcType import TysWiredIn( unitTy ) import MkCore( rEC_SEL_ERROR_ID ) @@ -228,7 +228,7 @@ calcClassCycles cls then (reverse (classTyCon cls:path):) . flip (foldr (expandType seen path)) tys else expandTheta (addOneToUniqSet seen cls) (tc:path) - (substTys (mkTopTvSubst env) (classSCTheta cls)) + (substTys (mkTopTCvSubst env) (classSCTheta cls)) . flip (foldr (expandType seen path)) rest_tys -- For synonyms, try to expand them: some arguments might be @@ -237,7 +237,7 @@ calcClassCycles cls | Just (tvs, rhs) <- synTyConDefn_maybe tc , let (env, remainder) = papp tvs tys rest_tys = either (const []) id remainder - = expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs) + = expandType seen (tc:path) (substTy (mkTopTCvSubst env) rhs) . flip (foldr (expandType seen path)) rest_tys -- For non-class, non-synonyms, just check the arguments @@ -247,8 +247,9 @@ calcClassCycles cls expandType _ _ (TyVarTy {}) = id expandType _ _ (LitTy {}) = id expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2 - expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2 - expandType seen path (ForAllTy _tv t) = expandType seen path t + expandType seen path (ForAllTy b t) = expandType seen path (binderType b) . expandType seen path t + expandType seen path (CastTy ty _co) = expandType seen path ty + expandType _ _ (CoercionTy {}) = id papp :: [TyVar] -> [Type] -> ([(TyVar, Type)], Either [TyVar] [Type]) papp [] tys = ([], Right tys) @@ -370,8 +371,7 @@ recursiveness, because we need only look at the type decls in the module being compiled, plus the outer structure of directly-mentioned types. -} -data RecTyInfo = RTI { rti_promotable :: Bool - , rti_roles :: Name -> [Role] +data RecTyInfo = RTI { rti_roles :: Name -> [Role] , rti_is_rec :: Name -> RecFlag } calcRecFlags :: SelfBootInfo -> Bool -- hs-boot file? @@ -381,14 +381,9 @@ calcRecFlags :: SelfBootInfo -> Bool -- hs-boot file? -- Recursion of newtypes/data types can happen via -- the class TyCon, so all_tycons includes the class tycons calcRecFlags boot_details is_boot mrole_env all_tycons - = RTI { rti_promotable = is_promotable - , rti_roles = roles + = RTI { rti_roles = roles , rti_is_rec = is_rec } where - rec_tycon_names = mkNameSet (map tyConName all_tycons) - - is_promotable = all (computeTyConPromotability rec_tycon_names) all_tycons - roles = inferRoles is_boot mrole_env all_tycons ----------------- Recursion calculation ---------------- @@ -595,6 +590,14 @@ so we need to take into account * the arguments: (F a) and (a->a) * the context: C a b * the result type: (G a) -- this is in the eq_spec + + +Note [Coercions in role inference] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing +the kind of a type is totally irrelevant to the representation of that type. So, +we want to totally ignore coercions when doing role inference. This includes omitting +any type variables that appear in nominal positions but only within coercions. -} type RoleEnv = NameEnv [Role] -- from tycon names to roles @@ -616,23 +619,31 @@ initialRoleEnv is_boot annots = extendNameEnvList emptyNameEnv . initialRoleEnv1 :: Bool -> RoleAnnots -> TyCon -> (Name, [Role]) initialRoleEnv1 is_boot annots_env tc - | isFamilyTyCon tc = (name, map (const Nominal) tyvars) + | isFamilyTyCon tc = (name, map (const Nominal) bndrs) | isAlgTyCon tc = (name, default_roles) | isTypeSynonymTyCon tc = (name, default_roles) | otherwise = pprPanic "initialRoleEnv1" (ppr tc) where name = tyConName tc - tyvars = tyConTyVars tc - (kvs, tvs) = span isKindVar tyvars + bndrs = tyConBinders tc + visflags = map binderVisibility $ take (tyConArity tc) bndrs + num_exps = count (== Visible) visflags -- if the number of annotations in the role annotation decl -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupNameEnv annots_env name of Just (L _ (RoleAnnotDecl _ annots)) - | annots `equalLength` tvs -> map unLoc annots - _ -> map (const Nothing) tvs - default_roles = map (const Nominal) kvs ++ - zipWith orElse role_annots (repeat default_role) + | annots `lengthIs` num_exps -> map unLoc annots + _ -> replicate num_exps Nothing + default_roles = build_default_roles visflags role_annots + + build_default_roles (Invisible : viss) ras + = Nominal : build_default_roles viss ras + build_default_roles (Visible : viss) (m_annot : ras) + = (m_annot `orElse` default_role) : build_default_roles viss ras + build_default_roles [] [] = [] + build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)" + (vcat [ppr tc, ppr role_annots]) default_role | isClassTyCon tc = Nominal @@ -652,26 +663,22 @@ irTyCon tc = do { old_roles <- lookupRoles tc ; unless (all (== Nominal) old_roles) $ -- also catches data families, -- which don't want or need role inference - do { whenIsJust (tyConClass_maybe tc) (irClass tc_name) - ; addRoleInferenceInfo tc_name (tyConTyVars tc) $ - mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 - ; mapM_ (irDataCon tc_name) (visibleDataCons $ algTyConRhs tc) }} + irTcTyVars tc $ + do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 + ; whenIsJust (tyConClass_maybe tc) irClass + ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }} | Just ty <- synTyConRhs_maybe tc - = addRoleInferenceInfo tc_name (tyConTyVars tc) $ + = irTcTyVars tc $ irType emptyVarSet ty | otherwise = return () - where - tc_name = tyConName tc - -- any type variable used in an associated type must be Nominal -irClass :: Name -> Class -> RoleM () -irClass tc_name cls - = addRoleInferenceInfo tc_name cls_tvs $ - mapM_ ir_at (classATs cls) +irClass :: Class -> RoleM () +irClass cls + = mapM_ ir_at (classATs cls) where cls_tvs = classTyVars cls cls_tv_set = mkVarSet cls_tvs @@ -681,34 +688,71 @@ irClass tc_name cls where nvars = (mkVarSet $ tyConTyVars at_tc) `intersectVarSet` cls_tv_set -- See Note [Role inference] -irDataCon :: Name -> DataCon -> RoleM () -irDataCon tc_name datacon - = addRoleInferenceInfo tc_name univ_tvs $ - mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ arg_tys) +irDataCon :: DataCon -> RoleM () +irDataCon datacon + = setRoleInferenceVars univ_tvs $ + irExTyVars ex_tvs $ \ ex_var_set -> + mapM_ (irType ex_var_set) + (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys) -- See Note [Role-checking data constructor arguments] where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon - ex_var_set = mkVarSet ex_tvs + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon irType :: VarSet -> Type -> RoleM () irType = go where - go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ - updateRole Representational tv - go lcls (AppTy t1 t2) = go lcls t1 >> mark_nominal lcls t2 - go lcls (TyConApp tc tys) - = do { roles <- lookupRolesX tc - ; zipWithM_ (go_app lcls) roles tys } - go lcls (FunTy t1 t2) = go lcls t1 >> go lcls t2 - go lcls (ForAllTy tv ty) = go (extendVarSet lcls tv) ty - go _ (LitTy {}) = return () + go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ + updateRole Representational tv + go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 + go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc + ; zipWithM_ (go_app lcls) roles tys } + go lcls (ForAllTy (Named tv _) ty) + = let lcls' = extendVarSet lcls tv in + markNominal lcls (tyVarKind tv) >> go lcls' ty + go lcls (ForAllTy (Anon arg) res) + = go lcls arg >> go lcls res + go _ (LitTy {}) = return () + -- See Note [Coercions in role inference] + go lcls (CastTy ty _) = go lcls ty + go _ (CoercionTy _) = return () go_app _ Phantom _ = return () -- nothing to do here - go_app lcls Nominal ty = mark_nominal lcls ty -- all vars below here are N + go_app lcls Nominal ty = markNominal lcls ty -- all vars below here are N go_app lcls Representational ty = go lcls ty - mark_nominal lcls ty = let nvars = tyVarsOfType ty `minusVarSet` lcls in - mapM_ (updateRole Nominal) (varSetElems nvars) +irTcTyVars :: TyCon -> RoleM a -> RoleM a +irTcTyVars tc thing + = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc) + where + go [] = thing + go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv) + ; addRoleInferenceVar tv $ go tvs } + +irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a +irExTyVars orig_tvs thing = go emptyVarSet orig_tvs + where + go lcls [] = thing lcls + go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv) + ; go (extendVarSet lcls tv) tvs } + +markNominal :: TyVarSet -- local variables + -> Type -> RoleM () +markNominal lcls ty = let nvars = get_ty_vars ty `minusVarSet` lcls in + mapM_ (updateRole Nominal) (varSetElems nvars) + where + -- get_ty_vars gets all the tyvars (no covars!) from a type *without* + -- recurring into coercions. Recall: coercions are totally ignored during + -- role inference. See [Coercions in role inference] + get_ty_vars (TyVarTy tv) = unitVarSet tv + get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionVarSet` get_ty_vars t2 + get_ty_vars (TyConApp _ tys) = foldr (unionVarSet . get_ty_vars) emptyVarSet tys + get_ty_vars (ForAllTy bndr ty) + = get_ty_vars ty `delBinderVar` bndr + `unionVarSet` (tyCoVarsOfType $ binderType bndr) + get_ty_vars (LitTy {}) = emptyVarSet + get_ty_vars (CastTy ty _) = get_ty_vars ty + get_ty_vars (CoercionTy _) = emptyVarSet -- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps lookupRolesX :: TyCon -> RoleM [Role] @@ -728,11 +772,10 @@ lookupRoles tc updateRole :: Role -> TyVar -> RoleM () updateRole role tv = do { var_ns <- getVarNs + ; name <- getTyConName ; case lookupVarEnv var_ns tv of - { Nothing -> pprPanic "updateRole" (ppr tv) - ; Just n -> do - { name <- getTyConName - ; updateRoleEnv name n role }}} + Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns) + Just n -> updateRoleEnv name n role } -- the state in the RoleM monad data RoleInferenceState = RIS { role_env :: RoleEnv @@ -740,11 +783,11 @@ data RoleInferenceState = RIS { role_env :: RoleEnv -- the environment in the RoleM monad type VarPositions = VarEnv Int -data RoleInferenceInfo = RII { var_ns :: VarPositions - , name :: Name } -- See [Role inference] -newtype RoleM a = RM { unRM :: Maybe RoleInferenceInfo +newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon + -> VarPositions + -> Int -- size of VarPositions -> RoleInferenceState -> (a, RoleInferenceState) } @@ -752,44 +795,57 @@ instance Functor RoleM where fmap = liftM instance Applicative RoleM where - pure x = RM $ \_ state -> (x, state) + pure x = RM $ \_ _ _ state -> (x, state) (<*>) = ap instance Monad RoleM where - return = pure - a >>= f = RM $ \m_info state -> let (a', state') = unRM a m_info state in - unRM (f a') m_info state' + return = pure + a >>= f = RM $ \m_info vps nvps state -> + let (a', state') = unRM a m_info vps nvps state in + unRM (f a') m_info vps nvps state' runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) runRoleM env thing = (env', update) - where RIS { role_env = env', update = update } = snd $ unRM thing Nothing state - state = RIS { role_env = env, update = False } - -addRoleInferenceInfo :: Name -> [TyVar] -> RoleM a -> RoleM a -addRoleInferenceInfo name tvs thing - = RM $ \_nothing state -> ASSERT( isNothing _nothing ) - unRM thing (Just info) state - where info = RII { var_ns = mkVarEnv (zip tvs [0..]), name = name } + where RIS { role_env = env', update = update } + = snd $ unRM thing Nothing emptyVarEnv 0 state + state = RIS { role_env = env + , update = False } + +setRoleInferenceTc :: Name -> RoleM a -> RoleM a +setRoleInferenceTc name thing = RM $ \m_name vps nvps state -> + ASSERT( isNothing m_name ) + ASSERT( isEmptyVarEnv vps ) + ASSERT( nvps == 0 ) + unRM thing (Just name) vps nvps state + +addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a +addRoleInferenceVar tv thing + = RM $ \m_name vps nvps state -> + ASSERT( isJust m_name ) + unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state + +setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a +setRoleInferenceVars tvs thing + = RM $ \m_name _vps _nvps state -> + ASSERT( isJust m_name ) + unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars") + state getRoleEnv :: RoleM RoleEnv -getRoleEnv = RM $ \_ state@(RIS { role_env = env }) -> (env, state) +getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state) getVarNs :: RoleM VarPositions -getVarNs = RM $ \m_info state -> - case m_info of - Nothing -> panic "getVarNs" - Just (RII { var_ns = var_ns }) -> (var_ns, state) +getVarNs = RM $ \_ vps _ state -> (vps, state) getTyConName :: RoleM Name -getTyConName = RM $ \m_info state -> - case m_info of - Nothing -> panic "getTyConName" - Just (RII { name = name }) -> (name, state) - +getTyConName = RM $ \m_name _ _ state -> + case m_name of + Nothing -> panic "getTyConName" + Just name -> (name, state) updateRoleEnv :: Name -> Int -> Role -> RoleM () updateRoleEnv name n role - = RM $ \_ state@(RIS { role_env = role_env }) -> ((), + = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), case lookupNameEnv role_env name of Nothing -> pprPanic "updateRoleEnv" (ppr name) Just roles -> let (before, old_role : after) = splitAt n roles in @@ -840,7 +896,7 @@ mkDefaultMethodIds tycons where mk_dm_ty :: Class -> Id -> DefMethSpec Type -> Type mk_dm_ty _ sel_id VanillaDM = idType sel_id - mk_dm_ty cls _ (GenericDM dm_ty) = mkSigmaTy cls_tvs [pred] dm_ty + mk_dm_ty cls _ (GenericDM dm_ty) = mkInvSigmaTy cls_tvs [pred] dm_ty where cls_tvs = classTyVars cls pred = mkClassPred cls (mkTyVarTys cls_tvs) @@ -915,12 +971,13 @@ mkOneRecordSelector all_cons idDetails fl -- Selector type; Note [Polymorphic selectors] field_ty = conLikeFieldType con1 lbl - data_tvs = tyVarsOfType data_ty - is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) + data_tvs = tyCoVarsOfType data_ty + is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tvs) (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty + all_tvs = varSetElemsWellScoped $ data_tvs `extendVarSetList` field_tvs sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkForAllTys (varSetElemsKvsFirst $ - data_tvs `extendVarSetList` field_tvs) $ + | otherwise = ASSERT( all isTyVar all_tvs ) + mkInvForAllTys all_tvs $ mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! mkPhiTy field_theta $ -- Urgh! -- req_theta is empty for normal DataCon @@ -971,7 +1028,7 @@ mkOneRecordSelector all_cons idDetails fl (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 - inst_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs + inst_tys = substTyVars (mkTopTCvSubst (map eqSpecPair eq_spec)) univ_tvs unit_rhs = mkLHsTupleExpr [] msg_lit = HsStringPrim "" (fastStringToByteString lbl) diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 701f27c18f..69ac6b79f4 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -15,16 +15,17 @@ The "tc" prefix is for "TypeChecker", because the type checker is the principal client. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MultiWayIf #-} module TcType ( -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, - TcTyVar, TcTyVarSet, TcDTyVarSet, TcKind, TcCoVar, + TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, + TcKind, TcCoVar, TcTyCoVar, TcTyBinder, -- TcLevel - TcLevel(..), topTcLevel, pushTcLevel, + TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, sameDepthAs, fmvTcLevel, -------------------------------- @@ -32,12 +33,12 @@ module TcType ( UserTypeCtxt(..), pprUserTypeCtxt, pprSigCtxt, isSigMaybe, TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), - isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, + isImmutableTyVar, isSkolemTyVar, + isMetaTyVar, isMetaTyVarTy, isTyVarTy, isSigTyVar, isOverlappableTyVar, isTyConableTyVar, isFskTyVar, isFmvTyVar, isFlattenTyVar, isReturnTyVar, isAmbiguousTyVar, metaTvRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, - isTypeVar, isKindVar, metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, isTouchableMetaTyVar, isTouchableOrFmv, isFloatedTouchableMetaTyVar, @@ -45,24 +46,30 @@ module TcType ( -------------------------------- -- Builders - mkPhiTy, mkSigmaTy, mkTcEqPred, mkTcReprEqPred, mkTcEqPredRole, + mkPhiTy, mkInvSigmaTy, mkSigmaTy, + mkNakedTyConApp, mkNakedAppTys, mkNakedAppTy, mkNakedFunTy, + mkNakedInvSigmaTy, mkNakedCastTy, mkNakedPhiTy, -------------------------------- -- Splitters -- These are important because they do not look through newtypes - tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe, + getTyVar, + tcSplitForAllTys, tcSplitPiTys, tcSplitNamedPiTys, + tcSplitPhiTy, tcSplitPredFunTy_maybe, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, - tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, + tcSplitTyConApp, tcSplitTyConApp_maybe, tcRepSplitTyConApp_maybe, + tcTyConAppTyCon, tcTyConAppArgs, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars, tcGetTyVar_maybe, tcGetTyVar, nextRole, tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe, + tcSplitCastTy_maybe, --------------------------------- -- Predicates. -- Again, newtypes are opaque - eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, - tcEqType, tcEqKind, + eqType, eqTypes, cmpType, cmpTypes, eqTypeX, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, isSigmaTy, isRhoTy, isOverloadedTy, isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, @@ -82,6 +89,7 @@ module TcType ( --------------------------------- -- Predicate types mkMinimalBySCs, transSuperClasses, transSuperClassesPred, + pickQuantifiablePreds, immSuperClasses, isImprovementPred, @@ -89,7 +97,10 @@ module TcType ( tcTyFamInsts, -- * Finding "exact" (non-dead) type variables - exactTyVarsOfType, exactTyVarsOfTypes, + exactTyCoVarsOfType, exactTyCoVarsOfTypes, + + -- * Extracting bound variables + allBoundVariables, allBoundVariabless, --------------------------------- -- Foreign import and export @@ -109,55 +120,59 @@ module TcType ( -- Rexported from Kind Kind, typeKind, unliftedTypeKind, liftedTypeKind, - openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, - isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - tcIsSubKind, splitKindFunTys, defaultKind, + constraintKind, + isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, -------------------------------- -- Rexported from Type - Type, PredType, ThetaType, - mkForAllTy, mkForAllTys, - mkFunTy, mkFunTys, zipFunTys, - mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys, - mkTyVarTy, mkTyVarTys, mkTyConTy, + Type, PredType, ThetaType, TyBinder, VisibilityFlag(..), + + mkForAllTy, mkForAllTys, mkInvForAllTys, mkNamedForAllTy, + mkFunTy, mkFunTys, + mkTyConApp, mkAppTy, mkAppTys, applyTys, + mkTyConTy, mkTyVarTy, + mkTyVarTys, - isClassPred, isEqPred, isIPPred, + isClassPred, isEqPred, isNomEqPred, isIPPred, mkClassPred, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, - mkEqPred, + isLevityVar, isLevityPolymorphic, isLevityPolymorphic_maybe, + isVisibleBinder, isInvisibleBinder, -- Type substitutions - TvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTvSubst, - mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, - mkTopTvSubst, notElemTvSubst, unionTvSubst, - getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, - Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr, - extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, - Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, + TCvSubst(..), -- Representation visible to a few friends + TvSubstEnv, emptyTCvSubst, + mkOpenTCvSubst, zipOpenTCvSubst, zipTopTCvSubst, + mkTopTCvSubst, notElemTCvSubst, unionTCvSubst, + getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, + Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, + extendTCvSubstList, isInScope, mkTCvSubst, zipTyEnv, zipCoEnv, + Type.substTy, substTys, substTyWith, substTyWithCoVars, + substTheta, isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto isPrimitiveType, - tyVarsOfType, tyVarsOfTypes, closeOverKinds, - tyVarsOfTypeList, tyVarsOfTypesList, - tyVarsOfTypeAcc, tyVarsOfTypesAcc, - tyVarsOfTypeDSet, tyVarsOfTypesDSet, closeOverKindsDSet, - tcTyVarsOfType, tcTyVarsOfTypes, + coreView, + + tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, + tyCoVarsOfTelescope, + tyCoVarsOfTypeAcc, tyCoVarsOfTypesAcc, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, + tyCoVarsOfTypeList, tyCoVarsOfTypesList, -------------------------------- -- Transforming Types to TcTypes toTcType, -- :: Type -> TcType - toTcTyVar, -- :: TyVar -> TcTyVar toTcTypeBag, -- :: Bag EvVar -> Bag EvVar pprKind, pprParendKind, pprSigmaType, pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTheta, pprThetaArrowTy, pprClassPred, - TypeSize, sizeType, sizeTypes + TypeSize, sizeType, sizeTypes, toposortTyVars ) where @@ -165,7 +180,7 @@ module TcType ( -- friends: import Kind -import TypeRep +import TyCoRep import Class import Var import ForeignCall @@ -188,16 +203,19 @@ import BasicTypes import Util import Bag import Maybes +import Pair import ListSetOps import Outputable import FastString import ErrUtils( Validity(..), MsgDoc, isValid ) +import FV import Data.IORef import Control.Monad (liftM, ap) #if __GLASGOW_HASKELL__ < 709 -import Control.Applicative (Applicative(..)) +import Control.Applicative (Applicative(..), (<$>) ) #endif +import Data.Functor.Identity {- ************************************************************************ @@ -237,12 +255,14 @@ tau ::= tyvar -} type TcTyVar = TyVar -- Used only during type inference -type TcCoVar = CoVar -- Used only during type inference; mutable +type TcCoVar = CoVar -- Used only during type inference type TcType = Type -- A TcType can have mutable type variables +type TcTyCoVar = Var -- Either a TcTyVar or a CoVar -- Invariant on ForAllTy in TcTypes: -- forall a. T -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a +type TcTyBinder = TyBinder -- These types do not have boxy type variables in them type TcPredType = PredType @@ -252,7 +272,9 @@ type TcRhoType = TcType -- Note [TcRhoType] type TcTauType = TcType type TcKind = Kind type TcTyVarSet = TyVarSet +type TcTyCoVarSet = TyCoVarSet type TcDTyVarSet = DTyVarSet +type TcDTyCoVarSet = DTyCoVarSet {- Note [TcRhoType] @@ -321,9 +343,21 @@ working. This happens in test case typecheck/should_fail/T5570, for example. See also the commentary on #9404. + +Note [TyVars and TcTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Var type has constructors TyVar and TcTyVar. They are used +as follows: + +* TcTyVar: used only during type checking. Should never appear + afterwards. May contain a mutable field, in the MetaTv case. + +* TyVar: can appear any time. During type checking they behave + precisely like (SkolemTv False) = vanillaSkolemTv -} -- A TyVarDetails is inside a TyVar +-- See Note [TyVars and TcTyVars] data TcTyVarDetails = SkolemTv -- A skolem Bool -- True <=> this skolem type variable can be overlapped @@ -528,6 +562,10 @@ topTcLevel :: TcLevel -- See Note [TcLevel assignment] topTcLevel = TcLevel 1 -- 1 = outermost level +isTopTcLevel :: TcLevel -> Bool +isTopTcLevel (TcLevel 1) = True +isTopTcLevel _ = False + pushTcLevel :: TcLevel -> TcLevel -- See Note [TcLevel assignment] pushTcLevel (TcLevel us) = TcLevel (us + 2) @@ -634,10 +672,12 @@ tcTyFamInsts (TyConApp tc tys) | isTypeFamilyTyCon tc = [(tc, tys)] | otherwise = concat (map tcTyFamInsts tys) tcTyFamInsts (LitTy {}) = [] -tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 +tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderType bndr) + ++ tcTyFamInsts ty tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 -tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty - +tcTyFamInsts (CastTy ty _) = tcTyFamInsts ty +tcTyFamInsts (CoercionTy _) = [] -- don't count tyfams in coercions, + -- as they never get normalized, anyway {- ************************************************************************ * * @@ -660,7 +700,7 @@ We have to generalise at the arg to f, and we don't want to capture the constraint (Monad (C u a)) because it appears to mention a. Pretty silly, but it was useful to him. -exactTyVarsOfType is used by the type checker to figure out exactly +exactTyCoVarsOfType is used by the type checker to figure out exactly which type variables are mentioned in a type. It's also used in the smart-app checking code --- see TcExpr.tcIdApp @@ -669,27 +709,83 @@ On the other hand, consider a *top-level* definition If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then if we have an application like (f "x") we get a confusing error message involving Any. So the conclusion is this: when generalising - - at top level use tyVarsOfType - - in nested bindings use exactTyVarsOfType + - at top level use tyCoVarsOfType + - in nested bindings use exactTyCoVarsOfType See Trac #1813 for example. -} -exactTyVarsOfType :: Type -> TyVarSet +exactTyCoVarsOfType :: Type -> TyCoVarSet -- Find the free type variables (of any kind) -- but *expand* type synonyms. See Note [Silly type synonym] above. -exactTyVarsOfType ty +exactTyCoVarsOfType ty = go ty where go ty | Just ty' <- coreView ty = go ty' -- This is the key line go (TyVarTy tv) = unitVarSet tv - go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (TyConApp _ tys) = exactTyCoVarsOfTypes tys go (LitTy {}) = emptyVarSet - go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg - go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) + go (CastTy ty co) = go ty `unionVarSet` goCo co + go (CoercionTy co) = goCo co + + goCo (Refl _ ty) = go ty + goCo (TyConAppCo _ _ args)= goCos args + goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg + goCo (ForAllCo tv k_co co) + = goCo co `delVarSet` tv `unionVarSet` goCo k_co + 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 + goCo (SymCo co) = goCo co + goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 + goCo (NthCo _ co) = goCo co + goCo (LRCo _ co) = goCo co + goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg + goCo (CoherenceCo c1 c2) = goCo c1 `unionVarSet` goCo c2 + goCo (KindCo co) = goCo co + goCo (SubCo co) = goCo co + goCo (AxiomRuleCo _ c) = goCos c + + goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos + + goProv UnsafeCoerceProv = emptyVarSet + goProv (PhantomProv kco) = goCo kco + goProv (ProofIrrelProv kco) = goCo kco + goProv (PluginProv _) = emptyVarSet + goProv (HoleProv _) = emptyVarSet + +exactTyCoVarsOfTypes :: [Type] -> TyVarSet +exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys -exactTyVarsOfTypes :: [Type] -> TyVarSet -exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType +{- +************************************************************************ +* * + Bound variables in a type +* * +************************************************************************ +-} + +-- | Find all variables bound anywhere in a type. +-- See also Note [Scope-check inferred kinds] in TcHsType +allBoundVariables :: Type -> TyVarSet +allBoundVariables ty = runFVSet $ go ty + where + go :: Type -> FV + go (TyVarTy tv) = go (tyVarKind tv) + go (TyConApp _ tys) = mapUnionFV go tys + go (AppTy t1 t2) = go t1 `unionFV` go t2 + go (ForAllTy (Anon t1) t2) = go t1 `unionFV` go t2 + go (ForAllTy (Named tv _) t2) = oneVar tv `unionFV` + go (tyVarKind tv) `unionFV` go t2 + go (LitTy {}) = noVars + go (CastTy ty _) = go ty + go (CoercionTy {}) = noVars + -- any types mentioned in a coercion should also be mentioned in + -- a type. + +allBoundVariabless :: [Type] -> TyVarSet +allBoundVariabless = mapUnionVarSet allBoundVariables {- ************************************************************************ @@ -701,8 +797,7 @@ exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType isTouchableOrFmv :: TcLevel -> TcTyVar -> Bool isTouchableOrFmv ctxt_tclvl tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) @@ -713,20 +808,22 @@ isTouchableOrFmv ctxt_tclvl tv isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isTouchableMetaTyVar ctxt_tclvl tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + | isTyVar tv + = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tv_tclvl } -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) tv_tclvl `sameDepthAs` ctxt_tclvl _ -> False + | otherwise = False isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isFloatedTouchableMetaTyVar ctxt_tclvl tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + | isTyVar tv + = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tv_tclvl } -> tv_tclvl `strictlyDeeperThan` ctxt_tclvl _ -> False + | otherwise = False isImmutableTyVar :: TyVar -> Bool isImmutableTyVar tv @@ -741,53 +838,51 @@ isTyConableTyVar tv -- True of a meta-type variable that can be filled in -- with a type constructor application; in particular, -- not a SigTv - = ASSERT( isTcTyVar tv) - case tcTyVarDetails tv of + | isTyVar tv + = case tcTyVarDetails tv of MetaTv { mtv_info = SigTv } -> False _ -> True + | otherwise = True isFmvTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_info = FlatMetaTv } -> True _ -> False -- | True of both given and wanted flatten-skolems (fak and usk) isFlattenTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of FlatSkol {} -> True MetaTv { mtv_info = FlatMetaTv } -> True _ -> False -- | True of FlatSkol skolems only isFskTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of FlatSkol {} -> True _ -> False isSkolemTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv {} -> False _other -> True isOverlappableTyVar tv - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of + | isTyVar tv + = case tcTyVarDetails tv of SkolemTv overlappable -> overlappable _ -> False + | otherwise = False isMetaTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + | isTyVar tv + = case tcTyVarDetails tv of MetaTv {} -> True _ -> False + | otherwise = False isReturnTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_info = ReturnTv } -> True _ -> False @@ -797,11 +892,12 @@ isReturnTyVar tv -- RtClosureInspect.zonkRTTIType. These are "ambiguous" in -- the sense that they stand for an as-yet-unknown type isAmbiguousTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + | isTyVar tv + = case tcTyVarDetails tv of MetaTv {} -> True RuntimeUnk {} -> True _ -> False + | otherwise = False isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv @@ -809,43 +905,37 @@ isMetaTyVarTy _ = False metaTyVarInfo :: TcTyVar -> MetaInfo metaTyVarInfo tv - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_info = info } -> info _ -> pprPanic "metaTyVarInfo" (ppr tv) metaTyVarTcLevel :: TcTyVar -> TcLevel metaTyVarTcLevel tv - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tclvl } -> tclvl _ -> pprPanic "metaTyVarTcLevel" (ppr tv) metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel metaTyVarTcLevel_maybe tv - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_tclvl = tclvl } -> Just tclvl _ -> Nothing setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar setMetaTyVarTcLevel tv tclvl - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) _ -> pprPanic "metaTyVarTcLevel" (ppr tv) isSigTyVar :: Var -> Bool isSigTyVar tv - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_info = SigTv } -> True _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv - = ASSERT2( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of + = case tcTyVarDetails tv of MetaTv { mtv_ref = ref } -> ref _ -> pprPanic "metaTvRef" (ppr tv) @@ -870,52 +960,40 @@ isRuntimeUnkSkol x ************************************************************************ -} -mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) +mkSigmaTy :: [TyBinder] -> [PredType] -> Type -> Type +mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) -mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy theta ty = foldr mkFunTy ty theta +mkInvSigmaTy :: [TyVar] -> [PredType] -> Type -> Type +mkInvSigmaTy tyvars + = mkSigmaTy (zipWith mkNamedBinder tyvars (repeat Invisible)) -mkTcEqPred :: TcType -> TcType -> Type --- During type checking we build equalities between --- type variables with OpenKind or ArgKind. Ultimately --- they will all settle, but we want the equality predicate --- itself to have kind '*'. I think. --- --- But for now we call mkTyConApp, not mkEqPred, because the invariants --- of the latter might not be satisfied during type checking. --- Notably when we form an equalty (a : OpenKind) ~ (Int : *) --- --- But this is horribly delicate: what about type variables --- that turn out to be bound to Int#? -mkTcEqPred ty1 ty2 - = mkTyConApp eqTyCon [k, ty1, ty2] - where - k = typeKind ty1 +mkPhiTy :: [PredType] -> Type -> Type +mkPhiTy = mkFunTys --- | Make a representational equality predicate -mkTcReprEqPred :: TcType -> TcType -> Type -mkTcReprEqPred ty1 ty2 - = mkTyConApp coercibleTyCon [k, ty1, ty2] - where - k = typeKind ty1 +mkNakedSigmaTy :: [TyBinder] -> [PredType] -> Type -> Type +-- See Note [Type-checking inside the knot] in TcHsType +mkNakedSigmaTy bndrs theta tau = mkForAllTys bndrs (mkNakedPhiTy theta tau) --- | Make an equality predicate at a given role. The role must not be Phantom. -mkTcEqPredRole :: Role -> TcType -> TcType -> Type -mkTcEqPredRole Nominal = mkTcEqPred -mkTcEqPredRole Representational = mkTcReprEqPred -mkTcEqPredRole Phantom = panic "mkTcEqPredRole Phantom" +mkNakedInvSigmaTy :: [TyVar] -> [PredType] -> Type -> Type +-- See Note [Type-checking inside the knot] in TcHsType +mkNakedInvSigmaTy tyvars + = mkNakedSigmaTy (zipWith mkNamedBinder tyvars (repeat Invisible)) --- @isTauTy@ tests for nested for-alls. +mkNakedPhiTy :: [PredType] -> Type -> Type +-- See Note [Type-checking inside the knot] in TcHsType +mkNakedPhiTy = flip $ foldr mkNakedFunTy +-- @isTauTy@ tests if a type is "simple".. isTauTy :: Type -> Bool isTauTy ty | Just ty' <- coreView ty = isTauTy ty' -isTauTy (TyVarTy _) = True -isTauTy (LitTy {}) = True -isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (ForAllTy {}) = False +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (ForAllTy (Anon a) b) = isTauTy a && isTauTy b +isTauTy (ForAllTy {}) = False +isTauTy (CastTy _ _) = False +isTauTy (CoercionTy _) = False isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype @@ -927,17 +1005,45 @@ isTauTyCon tc getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' -getDFunTyKey (TyVarTy tv) = getOccName tv -getDFunTyKey (TyConApp tc _) = getOccName tc -getDFunTyKey (LitTy x) = getDFunTyLitKey x -getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy _ _) = getOccName funTyCon -getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LitTy x) = getDFunTyLitKey x +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (ForAllTy (Anon _) _) = getOccName funTyCon +getDFunTyKey (ForAllTy (Named {}) t) = getDFunTyKey t +getDFunTyKey (CastTy ty _) = getDFunTyKey ty +getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) getDFunTyLitKey :: TyLit -> OccName getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm +--------------- +mkNakedTyConApp :: TyCon -> [Type] -> Type +-- Builds a TyConApp +-- * without being strict in TyCon, +-- * without satisfying the invariants of TyConApp +-- A subsequent zonking will establish the invariants +-- See Note [Type-checking inside the knot] in TcHsType +mkNakedTyConApp tc tys = TyConApp tc tys + +mkNakedAppTys :: Type -> [Type] -> Type +-- See Note [Type-checking inside the knot] in TcHsType +mkNakedAppTys ty1 [] = ty1 +mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) +mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 + +mkNakedAppTy :: Type -> Type -> Type +-- See Note [Type-checking inside the knot] in TcHsType +mkNakedAppTy ty1 ty2 = mkNakedAppTys ty1 [ty2] + +mkNakedFunTy :: Type -> Type -> Type +-- See Note [Type-checking inside the knot] in TcHsType +mkNakedFunTy arg res = ForAllTy (Anon arg) res + +mkNakedCastTy :: Type -> Coercion -> Type +mkNakedCastTy = CastTy + {- ************************************************************************ * * @@ -952,23 +1058,31 @@ However, they are non-monadic and do not follow through mutable type variables. It's up to you to make sure this doesn't matter. -} +-- | Splits a forall type into a list of 'TyBinder's and the inner type. +-- Always succeeds, even if it returns an empty list. +tcSplitPiTys :: Type -> ([TyBinder], Type) +tcSplitPiTys = splitPiTys + +-- | Like 'tcSplitPiTys', but splits off only named binders, returning +-- just the tycovars. tcSplitForAllTys :: Type -> ([TyVar], Type) -tcSplitForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) +tcSplitForAllTys = splitForAllTys + +-- | Like 'tcSplitForAllTys', but splits off only named binders. +tcSplitNamedPiTys :: Type -> ([TyBinder], Type) +tcSplitNamedPiTys = splitNamedPiTys +-- | Is this a ForAllTy with a named binder? tcIsForAllTy :: Type -> Bool tcIsForAllTy ty | Just ty' <- coreView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy {}) = True -tcIsForAllTy _ = False +tcIsForAllTy (ForAllTy (Named {}) _) = True +tcIsForAllTy _ = False tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type tcSplitPredFunTy_maybe ty | Just ty' <- coreView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (FunTy arg res) +tcSplitPredFunTy_maybe (ForAllTy (Anon arg) res) | isPredTy arg = Just (arg, res) tcSplitPredFunTy_maybe _ = Nothing @@ -982,6 +1096,7 @@ tcSplitPhiTy ty Just (pred, ty) -> split ty (pred:ts) Nothing -> (reverse ts, ty) +-- | Split a sigma type into its parts. tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) tcSplitSigmaTy ty = case tcSplitForAllTys ty of (tvs, rho) -> case tcSplitPhiTy rho of @@ -1022,12 +1137,13 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) tcSplitTyConApp_maybe ty | Just ty' <- coreView ty = tcSplitTyConApp_maybe ty' -tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) - -- Newtypes are opaque, so they may be split - -- However, predicates are not treated - -- as tycon applications by the type checker -tcSplitTyConApp_maybe _ = Nothing +tcSplitTyConApp_maybe ty = tcRepSplitTyConApp_maybe ty + +tcRepSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) +tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcRepSplitTyConApp_maybe (ForAllTy (Anon arg) res) = Just (funTyCon, [arg,res]) +tcRepSplitTyConApp_maybe _ = Nothing + ----------------------- tcSplitFunTys :: Type -> ([Type], Type) @@ -1039,7 +1155,8 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) tcSplitFunTy_maybe ty | Just ty' <- coreView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res) +tcSplitFunTy_maybe (ForAllTy (Anon arg) res) + | not (isPredTy arg) = Just (arg, res) tcSplitFunTy_maybe _ = Nothing -- Note the typeKind guard -- Consider (?x::Int) => Bool @@ -1076,7 +1193,7 @@ tcFunResultTy ty = snd (tcSplitFunTy ty) ----------------------- tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) tcSplitAppTy_maybe ty | Just ty' <- coreView ty = tcSplitAppTy_maybe ty' -tcSplitAppTy_maybe ty = repSplitAppTy_maybe ty +tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty tcSplitAppTy :: Type -> (Type, Type) tcSplitAppTy ty = case tcSplitAppTy_maybe ty of @@ -1101,7 +1218,18 @@ tcGetTyVar :: String -> Type -> TyVar tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty) tcIsTyVarTy :: Type -> Bool -tcIsTyVarTy ty = isJust (tcGetTyVar_maybe ty) +tcIsTyVarTy ty | Just ty' <- coreView ty = tcIsTyVarTy ty' +tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as + -- this is only used for + -- e.g., FlexibleContexts +tcIsTyVarTy (TyVarTy _) = True +tcIsTyVarTy _ = False + +----------------------- +tcSplitCastTy_maybe :: TcType -> Maybe (TcType, Coercion) +tcSplitCastTy_maybe ty | Just ty' <- coreView ty = tcSplitCastTy_maybe ty' +tcSplitCastTy_maybe (CastTy ty co) = Just (ty, co) +tcSplitCastTy_maybe _ = Nothing ----------------------- tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) @@ -1114,9 +1242,9 @@ tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) -- the latter specifically stops at PredTy arguments, -- and we don't want to do that here tcSplitDFunTy ty - = case tcSplitForAllTys ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> + = case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, tau) -> + case tcSplitDFunHead tau of { (clas, tys) -> (tvs, theta, clas, tys) }}} tcSplitDFunHead :: Type -> (Class, [Type]) @@ -1140,9 +1268,11 @@ tcInstHeadTyAppAllTyVars ty = tcInstHeadTyAppAllTyVars ty' | otherwise = case ty of - TyConApp _ tys -> ok (filter (not . isKind) tys) -- avoid kinds - FunTy arg res -> ok [arg, res] - _ -> False + TyConApp tc tys -> ok (filterOutInvisibleTypes tc tys) + -- avoid kinds + + ForAllTy (Anon arg) res -> ok [arg, res] + _ -> False where -- Check that all the types are type variables, -- and that each is distinct @@ -1157,31 +1287,103 @@ tcEqKind :: TcKind -> TcKind -> Bool tcEqKind = tcEqType tcEqType :: TcType -> TcType -> Bool --- tcEqType is a proper, sensible type-equality function, that does --- just what you'd expect The function Type.eqType (currently) has a --- grotesque hack that makes OpenKind = *, and that is NOT what we --- want in the type checker! Otherwise, for example, TcCanonical.reOrient --- thinks the LHS and RHS have the same kinds, when they don't, and --- fails to re-orient. That in turn caused Trac #8553. - +-- tcEqType is a proper implements the same Note [Non-trivial definitional +-- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* == +-- Constraint), and that is NOT what we want in the type checker! tcEqType ty1 ty2 - = go init_env ty1 ty2 + = isNothing (tc_eq_type coreView ki1 ki2) && + isNothing (tc_eq_type coreView ty1 ty2) + where + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | Just like 'tcEqType', but will return True for types of different kinds +-- as long as their non-coercion structure is identical. +tcEqTypeNoKindCheck :: TcType -> TcType -> Bool +tcEqTypeNoKindCheck ty1 ty2 + = isNothing $ tc_eq_type coreView ty1 ty2 + +-- | Like 'tcEqType', but returns information about whether the difference +-- is visible in the case of a mismatch. A return of Nothing means the types +-- are 'tcEqType'. +tcEqTypeVis :: TcType -> TcType -> Maybe VisibilityFlag +tcEqTypeVis ty1 ty2 + = tc_eq_type coreView ty1 ty2 <!> tc_eq_type coreView ki1 ki2 where - init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) - go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2 - | Just t2' <- coreView t2 = go env t1 t2' - go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 - go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 - go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go env (tyVarKind tv1) (tyVarKind tv2) - && go (rnBndr2 env tv1 tv2) t1 t2 - go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2 - go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2 - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2 - go _ _ _ = False - - gos _ [] [] = True - gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 - gos _ _ _ = False + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +(<!>) :: Maybe VisibilityFlag -> Maybe VisibilityFlag -> Maybe VisibilityFlag +Nothing <!> x = x +Just Visible <!> _ = Just Visible +Just Invisible <!> Just Visible = Just Visible +Just Invisible <!> _ = Just Invisible +infixr 3 <!> + +-- | Real worker for 'tcEqType'. No kind check! +tc_eq_type :: (TcType -> Maybe TcType) -- ^ @coreView@, if you want unwrapping + -> Type -> Type -> Maybe VisibilityFlag +tc_eq_type view_fun orig_ty1 orig_ty2 = go Visible orig_env orig_ty1 orig_ty2 + where + 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' + + go vis env (TyVarTy tv1) (TyVarTy tv2) + = check vis $ rnOccL env tv1 == rnOccR env tv2 + + go vis _ (LitTy lit1) (LitTy lit2) + = check vis $ lit1 == lit2 + + go vis env (ForAllTy (Named tv1 vis1) ty1) + (ForAllTy (Named tv2 vis2) ty2) + = go vis1 env (tyVarKind tv1) (tyVarKind tv2) + <!> go vis (rnBndr2 env tv1 tv2) ty1 ty2 + <!> check vis (vis1 == vis2) + go vis env (ForAllTy (Anon arg1) res1) (ForAllTy (Anon arg2) res2) + = go vis env arg1 arg2 <!> go vis env res1 res2 + + -- See Note [Equality on AppTys] in Type + go vis env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 + = go vis env s1 s2 <!> go vis env t1 t2 + go vis env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 + = go vis env s1 s2 <!> go vis env t1 t2 + go vis env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = check vis (tc1 == tc2) <!> gos (tc_vis tc1) env ts1 ts2 + go vis env (CastTy t1 _) t2 = go vis env t1 t2 + go vis env t1 (CastTy t2 _) = go vis env t1 t2 + go _ _ (CoercionTy {}) (CoercionTy {}) = Nothing + go vis _ _ _ = Just vis + + gos _ _ [] [] = Nothing + gos (v:vs) env (t1:ts1) (t2:ts2) = go v env t1 t2 <!> gos vs env ts1 ts2 + gos (v:_) _ _ _ = Just v + gos _ _ _ _ = panic "tc_eq_type" + + tc_vis :: TyCon -> [VisibilityFlag] + tc_vis tc = viss ++ repeat Visible + -- the repeat Visible is necessary because tycons can legitimately + -- be oversaturated + where + k = tyConKind tc + (bndrs, _) = splitPiTys k + viss = map binderVisibility bndrs + + check :: VisibilityFlag -> Bool -> Maybe VisibilityFlag + check _ True = Nothing + check vis False = Just vis + + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + +-- | Like 'pickyEqTypeVis', but returns a Bool for convenience +pickyEqType :: TcType -> TcType -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +-- This ignores kinds and coercions, because this is used only for printing. +pickyEqType ty1 ty2 + = isNothing $ + tc_eq_type (const Nothing) ty1 ty2 {- Note [Occurs check expansion] @@ -1247,92 +1449,148 @@ occurCheckExpand dflags tv ty | MetaTv { mtv_info = SigTv } <- details = go_sig_tv ty | fast_check ty = return ty - | otherwise = go ty + | otherwise = go emptyVarEnv ty where - details = ASSERT2( isTcTyVar tv, ppr tv ) tcTyVarDetails tv + details = tcTyVarDetails tv - impredicative = canUnifyWithPolyType dflags details (tyVarKind tv) + impredicative = canUnifyWithPolyType dflags details -- Check 'ty' is a tyvar, or can be expanded into one - go_sig_tv ty@(TyVarTy {}) = OC_OK ty + go_sig_tv ty@(TyVarTy tv') + | fast_check (tyVarKind tv') = return ty + | otherwise = do { k' <- go emptyVarEnv (tyVarKind tv') + ; return (mkTyVarTy (setTyVarKind tv' k')) } go_sig_tv ty | Just ty' <- coreView ty = go_sig_tv ty' go_sig_tv _ = OC_NonTyVar -- True => fine - fast_check (LitTy {}) = True - fast_check (TyVarTy tv') = tv /= tv' - fast_check (TyConApp tc tys) = all fast_check tys && (isTauTyCon tc || impredicative) - fast_check (FunTy arg res) = fast_check arg && fast_check res - fast_check (AppTy fun arg) = fast_check fun && fast_check arg - fast_check (ForAllTy tv' ty) = impredicative - && fast_check (tyVarKind tv') - && (tv == tv' || fast_check ty) - - go t@(TyVarTy tv') | tv == tv' = OC_Occurs - | otherwise = return t - go ty@(LitTy {}) = return ty - go (AppTy ty1 ty2) = do { ty1' <- go ty1 - ; ty2' <- go ty2 - ; return (mkAppTy ty1' ty2') } - go (FunTy ty1 ty2) = do { ty1' <- go ty1 - ; ty2' <- go ty2 - ; return (mkFunTy ty1' ty2') } - go ty@(ForAllTy tv' body_ty) - | not impredicative = OC_Forall - | not (fast_check (tyVarKind tv')) = OC_Occurs - -- Can't expand away the kinds unless we create - -- fresh variables which we don't want to do at this point. - -- In principle fast_check might fail because of a for-all - -- but we don't yet have poly-kinded tyvars so I'm not - -- going to worry about that now - | tv == tv' = return ty - | otherwise = do { body' <- go body_ty - ; return (ForAllTy tv' body') } + fast_check (LitTy {}) = True + fast_check (TyVarTy tv') = tv /= tv' && fast_check (tyVarKind tv') + fast_check (TyConApp tc tys) = all fast_check tys && (isTauTyCon tc || impredicative) + fast_check (ForAllTy (Anon a) r) = fast_check a && fast_check r + fast_check (AppTy fun arg) = fast_check fun && fast_check arg + fast_check (ForAllTy (Named tv' _) ty) + = impredicative + && fast_check (tyVarKind tv') + && (tv == tv' || fast_check ty) + fast_check (CastTy ty co) = fast_check ty && fast_check_co co + fast_check (CoercionTy co) = fast_check_co co + + -- we really are only doing an occurs check here; no bother about + -- impredicativity in coercions, as they're inferred + fast_check_co co = not (tv `elemVarSet` tyCoVarsOfCo co) + + go :: VarEnv TyVar -- carries mappings necessary because of kind expansion + -> Type -> OccCheckResult Type + go env (TyVarTy tv') + | tv == tv' = OC_Occurs + | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') + | otherwise = do { k' <- go env (tyVarKind tv') + ; return (mkTyVarTy $ + setTyVarKind tv' k') } + go _ ty@(LitTy {}) = return ty + go env (AppTy ty1 ty2) = do { ty1' <- go env ty1 + ; ty2' <- go env ty2 + ; return (mkAppTy ty1' ty2') } + go env (ForAllTy (Anon ty1) ty2) + = do { ty1' <- go env ty1 + ; ty2' <- go env ty2 + ; return (mkFunTy ty1' ty2') } + go env ty@(ForAllTy (Named tv' vis) body_ty) + | not impredicative = OC_Forall + | tv == tv' = return ty + | otherwise = do { ki' <- go env ki + ; let tv'' = setTyVarKind tv' ki' + env' = extendVarEnv env tv' tv'' + ; body' <- go env' body_ty + ; return (ForAllTy (Named tv'' vis) body') } + where ki = tyVarKind tv' -- For a type constructor application, first try expanding away the -- offending variable from the arguments. If that doesn't work, next -- see if the type constructor is a type synonym, and if so, expand -- it and try again. - go ty@(TyConApp tc tys) - = case do { tys <- mapM go tys; return (mkTyConApp tc tys) } of + go env ty@(TyConApp tc tys) + = case do { tys <- mapM (go env) tys + ; return (mkTyConApp tc tys) } of OC_OK ty | impredicative || isTauTyCon tc -> return ty -- First try to eliminate the tyvar from the args | otherwise -> OC_Forall -- A type synonym with a forall on the RHS - bad | Just ty' <- coreView ty -> go ty' + bad | Just ty' <- coreView ty -> go env ty' | otherwise -> bad -- Failing that, try to expand a synonym -canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> TcKind -> Bool -canUnifyWithPolyType dflags details kind + go env (CastTy ty co) = do { ty' <- go env ty + ; co' <- go_co env co + ; return (mkCastTy ty' co') } + go env (CoercionTy co) = do { co' <- go_co env co + ; return (mkCoercionTy co') } + + go_co env (Refl r ty) = do { ty' <- go env ty + ; return (mkReflCo r ty') } + -- Note: Coercions do not contain type synonyms + go_co env (TyConAppCo r tc args) = do { args' <- mapM (go_co env) args + ; return (mkTyConAppCo r tc args') } + go_co env (AppCo co arg) = do { co' <- go_co env co + ; arg' <- go_co env arg + ; return (mkAppCo co' arg') } + go_co env co@(ForAllCo tv' kind_co body_co) + | not impredicative = OC_Forall + | tv == tv' = return co + | otherwise = do { kind_co' <- go_co env kind_co + ; let tv'' = setTyVarKind tv' $ + pFst (coercionKind kind_co') + env' = extendVarEnv env tv' tv'' + ; body' <- go_co env' body_co + ; return (ForAllCo tv'' kind_co' body') } + 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 + ; return (mkAxiomInstCo ax ind args') } + go_co env (UnivCo p r ty1 ty2) = do { p' <- go_prov env p + ; ty1' <- go env ty1 + ; ty2' <- go env ty2 + ; return (mkUnivCo p' r ty1' ty2') } + go_co env (SymCo co) = do { co' <- go_co env co + ; return (mkSymCo co') } + go_co env (TransCo co1 co2) = do { co1' <- go_co env co1 + ; co2' <- go_co env co2 + ; return (mkTransCo co1' co2') } + go_co env (NthCo n co) = do { co' <- go_co env co + ; return (mkNthCo n co') } + go_co env (LRCo lr co) = do { co' <- go_co env co + ; return (mkLRCo lr co') } + go_co env (InstCo co arg) = do { co' <- go_co env co + ; arg' <- go_co env arg + ; return (mkInstCo co' arg') } + go_co env (CoherenceCo co1 co2) = do { co1' <- go_co env co1 + ; co2' <- go_co env co2 + ; return (mkCoherenceCo co1' co2') } + go_co env (KindCo co) = do { co' <- go_co env co + ; return (mkKindCo co') } + go_co env (SubCo co) = do { co' <- go_co env co + ; return (mkSubCo co') } + go_co env (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co env) cs + ; return (mkAxiomRuleCo ax cs') } + + go_prov _ UnsafeCoerceProv = return UnsafeCoerceProv + go_prov env (PhantomProv co) = PhantomProv <$> go_co env co + go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co + go_prov _ p@(PluginProv _) = return p + go_prov _ p@(HoleProv _) = return p + +canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool +canUnifyWithPolyType dflags details = case details of MetaTv { mtv_info = ReturnTv } -> True -- See Note [ReturnTv] MetaTv { mtv_info = SigTv } -> False MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags - || isOpenTypeKind kind - -- Note [OpenTypeKind accepts foralls] _other -> True -- We can have non-meta tyvars in given constraints {- -Note [OpenTypeKind accepts foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a common paradigm: - foo :: (forall a. a -> a) -> Int - foo = error "urk" -To make this work we need to instantiate 'error' with a polytype. -A similar case is - bar :: Bool -> (forall a. a->a) -> Int - bar True = \x. (x 3) - bar False = error "urk" -Here we need to instantiate 'error' with a polytype. - -But 'error' has an OpenTypeKind type variable, precisely so that -we can instantiate it with Int#. So we also allow such type variables -to be instantiated with foralls. It's a bit of a hack, but seems -straightforward. - ************************************************************************ * * \subsection{Predicate types} @@ -1356,17 +1614,17 @@ isTyVarClassPred ty = case getClassPredTys_maybe ty of _ -> False ------------------------- -checkValidClsArgs :: Bool -> [KindOrType] -> Bool +checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool -- If the Bool is True (flexible contexts), return True (i.e. ok) -- Otherwise, check that the type (not kind) args are all headed by a tyvar -- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected -- This function is here rather than in TcValidity because it is -- called from TcSimplify, which itself is imported by TcValidity -checkValidClsArgs flexible_contexts kts +checkValidClsArgs flexible_contexts cls kts | flexible_contexts = True | otherwise = all hasTyVarHead tys where - (_, tys) = span isKind kts -- see Note [Kind polymorphic type classes] + tys = filterOutInvisibleTypes (classTyCon cls) kts hasTyVarHead :: Type -> Bool -- Returns true of (a t1 .. tn), where 'a' is a type variable @@ -1390,15 +1648,58 @@ evVarPred var | otherwise = varType var +------------------ +-- | When inferring types, should we quantify over a given predicate? +-- Generally true of classes; generally false of equality constraints. +-- Equality constraints that mention quantified type variables and +-- implicit variables complicate the story. See Notes +-- [Inheriting implicit parameters] and [Quantifying over equality constraints] +pickQuantifiablePreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- This function decides whether a particular constraint shoudl be +-- quantified over, given the type variables that are being quantified +pickQuantifiablePreds qtvs theta + = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without + -- -XFlexibleContexts: see Trac #10608, #10351 + -- flex_ctxt <- xoptM Opt_FlexibleContexts + filter (pick_me flex_ctxt) theta + where + pick_me flex_ctxt pred + = case classifyPredType pred of + ClassPred cls tys + | isIPClass cls -> True -- See note [Inheriting implicit parameters] + | otherwise -> pick_cls_pred flex_ctxt cls tys + + EqPred ReprEq ty1 ty2 -> pick_cls_pred flex_ctxt coercibleClass [ty1, ty2] + -- representational equality is like a class constraint + + EqPred NomEq ty1 ty2 -> quant_fun ty1 || quant_fun ty2 + IrredPred ty -> tyCoVarsOfType ty `intersectsVarSet` qtvs + + pick_cls_pred flex_ctxt cls tys + = tyCoVarsOfTypes tys `intersectsVarSet` qtvs + && (checkValidClsArgs flex_ctxt cls tys) + -- Only quantify over predicates that checkValidType + -- will pass! See Trac #10351. + + -- See Note [Quantifying over equality constraints] + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) | isTypeFamilyTyCon tc + -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs + _ -> False + -- Superclasses mkMinimalBySCs :: [PredType] -> [PredType] -- Remove predicates that can be deduced from others by superclasses -mkMinimalBySCs ptys = [ ploc | ploc <- ptys - , ploc `not_in_preds` rec_scs ] +mkMinimalBySCs ptys = [ pty | pty <- ptys + , pty `not_in_preds` rec_scs ] where - rec_scs = concatMap trans_super_classes ptys - not_in_preds p ps = not (any (eqPred p) ps) + rec_scs = concatMap trans_super_classes ptys + not_in_preds p ps = not (any (eqType p) ps) trans_super_classes pred -- Superclasses of pred, excluding pred itself = case classifyPredType pred of @@ -1419,7 +1720,7 @@ transSuperClassesPred p immSuperClasses :: Class -> [Type] -> [PredType] immSuperClasses cls tys - = substTheta (zipTopTvSubst tyvars tys) sc_theta + = substTheta (zipTopTCvSubst tyvars tys) sc_theta where (tyvars,sc_theta,_,_) = classBigSig cls @@ -1433,6 +1734,46 @@ isImprovementPred ty IrredPred {} -> True -- Might have equalities after reduction? {- +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f x = (x::Int) + ?y + +where f is *not* a top-level binding. +From the RHS of f we'll get the constraint (?y::Int). +There are two types we might infer for f: + + f :: Int -> Int + +(so we get ?y from the context of f's definition), or + + f :: (?y::Int) => Int -> Int + +At first you might think the first was better, because then +?y behaves like a free variable of the definition, rather than +having to be passed at each call site. But of course, the WHOLE +IDEA is that ?y should be passed at each call site (that's what +dynamic binding means) so we'd better infer the second. + +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See pickQuantifiablePreds. + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t)? In general, we don't. +Doing so may simply postpone a type error from the function definition site to +its call site. (At worst, imagine (Int ~ Bool)). + +However, consider this + forall a. (F [a] ~ Int) => blah +Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call +site we will know 'a', and perhaps we have instance F [Bool] = Int. +So we *do* quantify over a type-family equality where the arguments mention +the quantified variables. + ************************************************************************ * * \subsection{Predicates} @@ -1445,23 +1786,23 @@ isSigmaTy :: TcType -> Bool -- *necessarily* have any foralls. E.g -- f :: (?x::Int) => Int -> Int isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' -isSigmaTy (ForAllTy _ _) = True -isSigmaTy (FunTy a _) = isPredTy a -isSigmaTy _ = False +isSigmaTy (ForAllTy (Named {}) _) = True +isSigmaTy (ForAllTy (Anon a) _) = isPredTy a +isSigmaTy _ = False isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty' -isRhoTy (ForAllTy {}) = False -isRhoTy (FunTy a r) = not (isPredTy a) && isRhoTy r -isRhoTy _ = True +isRhoTy (ForAllTy (Named {}) _) = False +isRhoTy (ForAllTy (Anon a) r) = not (isPredTy a) && isRhoTy r +isRhoTy _ = True isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy a _) = isPredTy a -isOverloadedTy _ = False +isOverloadedTy (ForAllTy (Named {}) ty) = isOverloadedTy ty +isOverloadedTy (ForAllTy (Anon a) _) = isPredTy a +isOverloadedTy _ = False isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, isUnitTy, isCharTy, isAnyTy :: Type -> Bool @@ -1502,10 +1843,11 @@ isTyVarExposed tv (TyConApp tc tys) | isNewTyCon tc = any (isTyVarExposed tv) tys | otherwise = False isTyVarExposed _ (LitTy {}) = False -isTyVarExposed _ (FunTy {}) = False isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun || isTyVarExposed tv arg isTyVarExposed _ (ForAllTy {}) = False +isTyVarExposed tv (CastTy ty _) = isTyVarExposed tv ty +isTyVarExposed _ (CoercionTy {}) = False -- | Does the given tyvar appear under a type generative w.r.t. -- representational equality? See Note [Occurs check error] in @@ -1520,11 +1862,13 @@ isTyVarUnderDatatype tv = go False Representational in any (go under_dt') tys go _ (LitTy {}) = False - go _ (FunTy arg res) = go True arg || go True res + go _ (ForAllTy (Anon arg) res) = go True arg || go True res go under_dt (AppTy fun arg) = go under_dt fun || go under_dt arg - go under_dt (ForAllTy tv' inner_ty) + go under_dt (ForAllTy (Named tv' _) inner_ty) | tv' == tv = False | otherwise = go under_dt inner_ty + go under_dt (CastTy ty _) = go under_dt ty + go _ (CoercionTy {}) = False isRigidTy :: TcType -> Bool isRigidTy ty @@ -1557,32 +1901,50 @@ isRigidEqPred _ _ = False -- Not an equality -} toTcType :: Type -> TcType -toTcType ty = to_tc_type emptyVarSet ty - where - to_tc_type :: VarSet -> Type -> TcType - -- The constraint solver expects EvVars to have TcType, in which the - -- free type variables are TcTyVars. So we convert from Type to TcType here - -- A bit tiresome; but one day I expect the two types to be entirely separate - -- in which case we'll definitely need to do this - to_tc_type forall_tvs (TyVarTy tv) - | Just var <- lookupVarSet forall_tvs tv = TyVarTy var - | otherwise = TyVarTy (toTcTyVar tv) - to_tc_type ftvs (FunTy t1 t2) = FunTy (to_tc_type ftvs t1) (to_tc_type ftvs t2) - to_tc_type ftvs (AppTy t1 t2) = AppTy (to_tc_type ftvs t1) (to_tc_type ftvs t2) - to_tc_type ftvs (TyConApp tc tys) = TyConApp tc (map (to_tc_type ftvs) tys) - to_tc_type ftvs (ForAllTy tv ty) = let tv' = toTcTyVar tv - in ForAllTy tv' (to_tc_type (ftvs `extendVarSet` tv') ty) - to_tc_type _ftvs (LitTy l) = LitTy l - -toTcTyVar :: TyVar -> TcTyVar -toTcTyVar tv - | isTcTyVar tv = setVarType tv (toTcType (tyVarKind tv)) - | isId tv = pprPanic "toTcTyVar: Id:" (ppr tv) - | otherwise = mkTcTyVar (tyVarName tv) (toTcType (tyVarKind tv)) vanillaSkolemTv +-- The constraint solver expects EvVars to have TcType, in which the +-- free type variables are TcTyVars. So we convert from Type to TcType here +-- A bit tiresome; but one day I expect the two types to be entirely separate +-- in which case we'll definitely need to do this +toTcType = runIdentity . to_tc_type emptyVarSet toTcTypeBag :: Bag EvVar -> Bag EvVar -- All TyVars are transformed to TcTyVars toTcTypeBag evvars = mapBag (\tv -> setTyVarKind tv (toTcType (tyVarKind tv))) evvars +to_tc_mapper :: TyCoMapper VarSet Identity +to_tc_mapper + = TyCoMapper { tcm_smart = False -- more efficient not to use smart ctors + , tcm_tyvar = tyvar + , tcm_covar = covar + , tcm_hole = hole + , tcm_tybinder = tybinder } + where + tyvar :: VarSet -> TyVar -> Identity Type + tyvar ftvs tv + | Just var <- lookupVarSet ftvs tv = return $ TyVarTy var + | isTcTyVar tv = TyVarTy <$> updateTyVarKindM (to_tc_type ftvs) tv + | otherwise + = do { kind' <- to_tc_type ftvs (tyVarKind tv) + ; return $ TyVarTy $ mkTcTyVar (tyVarName tv) kind' vanillaSkolemTv } + + covar :: VarSet -> CoVar -> Identity Coercion + covar ftvs cv + | Just var <- lookupVarSet ftvs cv = return $ CoVarCo var + | otherwise = CoVarCo <$> updateVarTypeM (to_tc_type ftvs) cv + + hole :: VarSet -> CoercionHole -> Role -> Type -> Type + -> Identity Coercion + hole ftvs h r t1 t2 = mkHoleCo h r <$> to_tc_type ftvs t1 + <*> to_tc_type ftvs t2 + + tybinder :: VarSet -> TyVar -> VisibilityFlag -> Identity (VarSet, TyVar) + tybinder ftvs tv _vis = do { kind' <- to_tc_type ftvs (tyVarKind tv) + ; let tv' = mkTcTyVar (tyVarName tv) kind' + vanillaSkolemTv + ; return (ftvs `extendVarSet` tv', tv') } + +to_tc_type :: VarSet -> Type -> Identity TcType +to_tc_type = mapType to_tc_mapper + {- ************************************************************************ * * @@ -1596,21 +1958,6 @@ deNoteType :: Type -> Type deNoteType ty | Just ty' <- coreView ty = deNoteType ty' deNoteType ty = ty -tcTyVarsOfType :: Type -> TcTyVarSet --- Just the *TcTyVars* free in the type --- (Types.tyVarsOfTypes finds all free TyVars) -tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv - else emptyVarSet -tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys -tcTyVarsOfType (LitTy {}) = emptyVarSet -tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res -tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg -tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar - -- We do sometimes quantify over skolem TcTyVars - -tcTyVarsOfTypes :: [Type] -> TyVarSet -tcTyVarsOfTypes = mapUnionVarSet tcTyVarsOfType - {- Find the free tycons and classes of a type. This is used in the front end of the compiler. @@ -1628,11 +1975,12 @@ orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys -orphNamesOfType (FunTy arg res) = orphNamesOfTyCon funTyCon -- NB! See Trac #8535 - `unionNameSet` orphNamesOfType arg +orphNamesOfType (ForAllTy bndr res) = orphNamesOfTyCon funTyCon -- NB! See Trac #8535 + `unionNameSet` orphNamesOfType (binderType bndr) `unionNameSet` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg -orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty +orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co +orphNamesOfType (CoercionTy co) = orphNamesOfCo co orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet @@ -1655,18 +2003,27 @@ orphNamesOfCo :: Coercion -> NameSet orphNamesOfCo (Refl _ ty) = orphNamesOfType ty orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co +orphNamesOfCo (ForAllCo _ kind_co co) + = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co orphNamesOfCo (CoVarCo _) = emptyNameSet orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (UnivCo _ _ ty1 ty2) = orphNamesOfType ty1 `unionNameSet` orphNamesOfType ty2 +orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 orphNamesOfCo (NthCo _ co) = orphNamesOfCo co orphNamesOfCo (LRCo _ co) = orphNamesOfCo co -orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSet` orphNamesOfType ty +orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg +orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (KindCo co) = orphNamesOfCo co orphNamesOfCo (SubCo co) = orphNamesOfCo co -orphNamesOfCo (AxiomRuleCo _ ts cs) = orphNamesOfTypes ts `unionNameSet` - orphNamesOfCos cs +orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs + +orphNamesOfProv :: UnivCoProvenance -> NameSet +orphNamesOfProv UnsafeCoerceProv = emptyNameSet +orphNamesOfProv (PhantomProv co) = orphNamesOfCo co +orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co +orphNamesOfProv (PluginProv _) = emptyNameSet +orphNamesOfProv (HoleProv _) = emptyNameSet orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo @@ -1956,22 +2313,25 @@ is irreducible. See Trac #5581. type TypeSize = IntWithInf -sizeType, size_type :: Type -> TypeSize +sizeType :: Type -> TypeSize -- Size of a type: the number of variables and constructors -- Ignore kinds altogether -sizeType ty | isKind ty = 0 - | otherwise = size_type ty - -size_type ty | Just exp_ty <- coreView ty = size_type exp_ty -size_type (TyVarTy {}) = 1 -size_type (TyConApp tc tys) - | isTypeFamilyTyCon tc = infinity -- Type-family applications can - -- expand to any arbitrary size - | otherwise = sizeTypes tys + 1 -size_type (LitTy {}) = 1 -size_type (FunTy arg res) = size_type arg + size_type res + 1 -size_type (AppTy fun arg) = size_type fun + size_type arg -size_type (ForAllTy _ ty) = size_type ty +sizeType = go + where + go ty | Just exp_ty <- coreView ty = go exp_ty + go (TyVarTy {}) = 1 + go (TyConApp tc tys) + | isTypeFamilyTyCon tc = infinity -- Type-family applications can + -- expand to any arbitrary size + | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 + go (LitTy {}) = 1 + go (ForAllTy (Anon arg) res) = go arg + go res + 1 + go (AppTy fun arg) = go fun + go arg + go (ForAllTy (Named tv vis) ty) + | Visible <- vis = go (tyVarKind tv) + go ty + 1 + | otherwise = go ty + 1 + go (CastTy ty _) = go ty + go (CoercionTy {}) = 0 sizeTypes :: [Type] -> TypeSize sizeTypes tys = sum (map sizeType tys) diff --git a/compiler/typecheck/TcType.hs-boot b/compiler/typecheck/TcType.hs-boot index 656c4242ce..2bc14735f1 100644 --- a/compiler/typecheck/TcType.hs-boot +++ b/compiler/typecheck/TcType.hs-boot @@ -5,3 +5,4 @@ data MetaDetails data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc +vanillaSkolemTv :: TcTyVarDetails diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index e64f43a9ba..bb349879d5 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase, CPP #-} + module TcTypeNats ( typeNatTyCons , typeNatCoAxiomRules @@ -19,18 +21,10 @@ import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon , Injectivity(..) ) import Coercion ( Role(..) ) import TcRnTypes ( Xi ) -import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..) ) +import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..), Eqn ) import Name ( Name, BuiltInSyntax(..) ) -import TysWiredIn ( typeNatKind, typeSymbolKind - , mkWiredInTyConName - , promotedBoolTyCon - , promotedFalseDataCon, promotedTrueDataCon - , promotedOrderingTyCon - , promotedLTDataCon - , promotedEQDataCon - , promotedGTDataCon - ) -import TysPrim ( mkArrowKinds, mkTemplateTyVars ) +import TysWiredIn +import TysPrim ( mkTemplateTyVars ) import PrelNames ( gHC_TYPELITS , typeNatAddTyFamNameKey , typeNatMulTyFamNameKey @@ -44,6 +38,10 @@ import FastString ( FastString, fsLit ) import qualified Data.Map as Map import Data.Maybe ( isJust ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Traversable ( traverse ) +#endif + {------------------------------------------------------------------------------- Built-in type constructors for functions on type-level nats -} @@ -106,7 +104,7 @@ typeNatExpTyCon = mkTypeNatFunTyCon2 name typeNatLeqTyCon :: TyCon typeNatLeqTyCon = mkFamilyTyCon name - (mkArrowKinds [ typeNatKind, typeNatKind ] boolKind) + (mkFunTys [ typeNatKind, typeNatKind ] boolTy) (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) @@ -125,7 +123,7 @@ typeNatLeqTyCon = typeNatCmpTyCon :: TyCon typeNatCmpTyCon = mkFamilyTyCon name - (mkArrowKinds [ typeNatKind, typeNatKind ] orderingKind) + (mkFunTys [ typeNatKind, typeNatKind ] orderingKind) (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) @@ -144,7 +142,7 @@ typeNatCmpTyCon = typeSymbolCmpTyCon :: TyCon typeSymbolCmpTyCon = mkFamilyTyCon name - (mkArrowKinds [ typeSymbolKind, typeSymbolKind ] orderingKind) + (mkFunTys [ typeSymbolKind, typeSymbolKind ] orderingKind) (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ]) Nothing (BuiltInSynFamTyCon ops) @@ -168,7 +166,7 @@ typeSymbolCmpTyCon = mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = mkFamilyTyCon op - (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind) + (mkFunTys [ typeNatKind, typeNatKind ] typeNatKind) (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon tcb) @@ -224,38 +222,33 @@ axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon axCmpSymbolDef = CoAxiomRule { coaxrName = fsLit "CmpSymbolDef" - , coaxrTypeArity = 2 - , coaxrAsmpRoles = [] + , coaxrAsmpRoles = [Nominal, Nominal] , coaxrRole = Nominal - , coaxrProves = \ts cs -> - case (ts,cs) of - ([s,t],[]) -> - do x <- isStrLitTy s - y <- isStrLitTy t - return (mkTyConApp typeSymbolCmpTyCon [s,t] === - ordering (compare x y)) - _ -> Nothing - } + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + [s2', t2'] <- traverse isStrLitTy [s2, t2] + return (mkTyConApp typeSymbolCmpTyCon [s1,t1] === + ordering (compare s2' t2')) } axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ \x y -> fmap num (minus x y) -axAdd0L = mkAxiom1 "Add0L" $ \t -> (num 0 .+. t) === t -axAdd0R = mkAxiom1 "Add0R" $ \t -> (t .+. num 0) === t -axSub0R = mkAxiom1 "Sub0R" $ \t -> (t .-. num 0) === t -axMul0L = mkAxiom1 "Mul0L" $ \t -> (num 0 .*. t) === num 0 -axMul0R = mkAxiom1 "Mul0R" $ \t -> (t .*. num 0) === num 0 -axMul1L = mkAxiom1 "Mul1L" $ \t -> (num 1 .*. t) === t -axMul1R = mkAxiom1 "Mul1R" $ \t -> (t .*. num 1) === t -axExp1L = mkAxiom1 "Exp1L" $ \t -> (num 1 .^. t) === num 1 -axExp0R = mkAxiom1 "Exp0R" $ \t -> (t .^. num 0) === num 1 -axExp1R = mkAxiom1 "Exp1R" $ \t -> (t .^. num 1) === t -axLeqRefl = mkAxiom1 "LeqRefl" $ \t -> (t <== t) === bool True +axAdd0L = mkAxiom1 "Add0L" $ \(Pair s t) -> (num 0 .+. s) === t +axAdd0R = mkAxiom1 "Add0R" $ \(Pair s t) -> (s .+. num 0) === t +axSub0R = mkAxiom1 "Sub0R" $ \(Pair s t) -> (s .-. num 0) === t +axMul0L = mkAxiom1 "Mul0L" $ \(Pair s _) -> (num 0 .*. s) === num 0 +axMul0R = mkAxiom1 "Mul0R" $ \(Pair s _) -> (s .*. num 0) === num 0 +axMul1L = mkAxiom1 "Mul1L" $ \(Pair s t) -> (num 1 .*. s) === t +axMul1R = mkAxiom1 "Mul1R" $ \(Pair s t) -> (s .*. num 1) === t +axExp1L = mkAxiom1 "Exp1L" $ \(Pair s _) -> (num 1 .^. s) === num 1 +axExp0R = mkAxiom1 "Exp0R" $ \(Pair s _) -> (s .^. num 0) === num 1 +axExp1R = mkAxiom1 "Exp1R" $ \(Pair s t) -> (s .^. num 1) === t +axLeqRefl = mkAxiom1 "LeqRefl" $ \(Pair s _) -> (s <== s) === bool True axCmpNatRefl = mkAxiom1 "CmpNatRefl" - $ \t -> (cmpNat t t) === ordering EQ + $ \(Pair s _) -> (cmpNat s s) === ordering EQ axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl" - $ \t -> (cmpSymbol t t) === ordering EQ -axLeq0L = mkAxiom1 "Leq0L" $ \t -> (num 0 <== t) === bool True + $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ +axLeq0L = mkAxiom1 "Leq0L" $ \(Pair s _) -> (num 0 <== s) === bool True typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) @@ -314,9 +307,6 @@ x === y = Pair x y num :: Integer -> Type num = mkNumLitTy -boolKind :: Kind -boolKind = mkTyConApp promotedBoolTyCon [] - bool :: Bool -> Type bool b = if b then mkTyConApp promotedTrueDataCon [] else mkTyConApp promotedFalseDataCon [] @@ -330,7 +320,7 @@ isBoolLitTy tc = | otherwise -> Nothing orderingKind :: Kind -orderingKind = mkTyConApp promotedOrderingTyCon [] +orderingKind = mkTyConApp orderingTyCon [] ordering :: Ordering -> Type ordering o = @@ -362,31 +352,25 @@ mkBinAxiom :: String -> TyCon -> mkBinAxiom str tc f = CoAxiomRule { coaxrName = fsLit str - , coaxrTypeArity = 2 - , coaxrAsmpRoles = [] + , coaxrAsmpRoles = [Nominal, Nominal] , coaxrRole = Nominal - , coaxrProves = \ts cs -> - case (ts,cs) of - ([s,t],[]) -> do x <- isNumLitTy s - y <- isNumLitTy t - z <- f x y - return (mkTyConApp tc [s,t] === z) - _ -> Nothing + , coaxrProves = \cs -> + do [Pair s1 s2, Pair t1 t2] <- return cs + [s2', t2'] <- traverse isNumLitTy [s2, t2] + z <- f s2' t2' + return (mkTyConApp tc [s1,t1] === z) } -mkAxiom1 :: String -> (Type -> Pair Type) -> CoAxiomRule +mkAxiom1 :: String -> (Eqn -> Eqn) -> CoAxiomRule mkAxiom1 str f = CoAxiomRule { coaxrName = fsLit str - , coaxrTypeArity = 1 - , coaxrAsmpRoles = [] + , coaxrAsmpRoles = [Nominal] , coaxrRole = Nominal - , coaxrProves = \ts cs -> - case (ts,cs) of - ([s],[]) -> return (f s) - _ -> Nothing + , coaxrProves = \case [eqn] -> Just (f eqn) + _ -> Nothing } @@ -690,10 +674,3 @@ genLog x base = Just (exactLoop 0 x) underLoop s i | i < base = s | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) - - - - - - - diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 62836d75ec..c951387861 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -189,7 +189,6 @@ mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) ty tycon_str = add_tick (occNameString (getOccName tycon)) add_tick s | isPromotedDataCon tycon = '\'' : s - | isPromotedTyCon tycon = '\'' : s | otherwise = s hashThis :: String @@ -205,6 +204,4 @@ mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) ty mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id mkTypeableDataConBinds stuff dc - = case promoteDataCon_maybe dc of - Promoted tc -> mkTyConRepBinds stuff tc - NotPromoted -> emptyBag + = mkTyConRepBinds stuff (promoteDataCon dc) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 6754cb5ce7..c854eac851 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -6,7 +6,7 @@ Type subsumption and unification -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MultiWayIf #-} module TcUnify ( -- Full-blown subsumption @@ -15,8 +15,8 @@ module TcUnify ( checkConstraints, buildImplication, buildImplicationFor, -- Various unifications - unifyType, unifyTypeList, unifyTheta, - unifyKindX, + unifyType_, unifyType, unifyTheta, unifyKind, noThing, + uType, -------------------------------- -- Holes @@ -26,7 +26,9 @@ module TcUnify ( matchExpectedTyConApp, matchExpectedAppTy, matchExpectedFunTys, + matchExpectedFunKind, + wrapFunResCoercion ) where @@ -34,15 +36,15 @@ module TcUnify ( #include "HsVersions.h" import HsSyn -import TypeRep +import TyCoRep import TcMType import TcRnMonad import TcType import Type +import Coercion import TcEvidence import Name ( isSystemName ) import Inst -import Kind import TyCon import TysWiredIn import Var @@ -51,7 +53,7 @@ import VarSet import ErrUtils import DynFlags import BasicTypes -import Maybes ( isJust ) +import Name ( Name ) import Bag import Util import Outputable @@ -132,7 +134,7 @@ matchExpectedFunTys herald arity orig_ty go n_req ty | Just ty' <- coreView ty = go n_req ty' - go n_req (FunTy arg_ty res_ty) + go n_req (ForAllTy (Anon arg_ty) res_ty) | not (isPredTy arg_ty) = do { (co, tys, ty_r) <- go (n_req-1) res_ty ; return (mkTcFunCo Nominal (mkTcNomReflCo arg_ty) co, arg_ty:tys, ty_r) } @@ -167,14 +169,16 @@ matchExpectedFunTys herald arity orig_ty -- really be a function type, then we need to allow the argument and -- result types also to be ReturnTvs. defer n_req fun_ty is_return - = do { arg_tys <- mapM new_ty_var_ty (nOfThem n_req openTypeKind) + = do { arg_tys <- replicateM n_req new_flexi -- See Note [Foralls to left of arrow] - ; res_ty <- new_ty_var_ty openTypeKind - ; co <- unifyType fun_ty (mkFunTys arg_tys res_ty) + ; res_ty <- new_flexi + ; co <- unifyType noThing fun_ty (mkFunTys arg_tys res_ty) ; return (co, arg_tys, res_ty) } where - new_ty_var_ty | is_return = newReturnTyVarTy - | otherwise = newFlexiTyVarTy + -- preserve ReturnTv-ness + new_flexi :: TcM TcType + new_flexi | is_return = (mkTyVarTy . fst) <$> newOpenReturnTyVar + | otherwise = newOpenFlexiTyVarTy ------------ mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) @@ -201,8 +205,9 @@ Consider f (x :: forall a. a -> a) = x We give 'f' the type (alpha -> beta), and then want to unify the alpha with (forall a. a->a). We want to the arg and result -of (->) to have openTypeKind, and this also permits foralls, so -we are ok. +of (->) to be sort-polymorphic, and this also permits foralls, so +we are ok. See Note [Sort-polymorphic tyvars accept foralls] in TcUnify +and Note [TYPE] in TysPrim. -} ---------------------- @@ -246,9 +251,9 @@ matchExpectedTyConApp tc orig_ty = do { cts <- readMetaTyVar tv ; case cts of Indirect ty -> go ty - Flexi -> defer } + Flexi -> defer (isReturnTyVar tv) } - go _ = defer + go _ = defer False -- If the common case does not occur, instantiate a template -- T k1 .. kn t1 .. tm, and unify with the original type @@ -260,19 +265,21 @@ matchExpectedTyConApp tc orig_ty -- (a::*) ~ Maybe -- because that'll make types that are utterly ill-kinded. -- This happened in Trac #7368 - defer = ASSERT2( isSubOpenTypeKind res_kind, ppr tc ) - do { kappa_tys <- mapM (const newMetaKindVar) kvs - ; let arg_kinds' = map (substKiWith kvs kappa_tys) arg_kinds - ; tau_tys <- mapM newFlexiTyVarTy arg_kinds' - ; co <- unifyType (mkTyConApp tc (kappa_tys ++ tau_tys)) orig_ty - ; return (co, kappa_tys ++ tau_tys) } - - (kvs, body) = splitForAllTys (tyConKind tc) - (arg_kinds, res_kind) = splitKindFunTys body + defer is_return + = ASSERT2( classifiesTypeWithValues res_kind, ppr tc ) + do { (k_subst, kvs') <- tcInstTyVars kvs + ; let arg_kinds' = substTys k_subst arg_kinds + kappa_tys = mkTyVarTys kvs' + ; tau_tys <- mapM (newMaybeReturnTyVarTy is_return) arg_kinds' + ; co <- unifyType noThing (mkTyConApp tc (kappa_tys ++ tau_tys)) orig_ty + ; return (co, kappa_tys ++ tau_tys) } + + (bndrs, res_kind) = splitPiTys (tyConKind tc) + (kvs, arg_kinds) = partitionBinders bndrs ---------------------- matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (TcCoercion, -- m a ~ orig_ty + -> TcM (TcCoercion, -- m a ~N orig_ty (TcSigmaType, TcSigmaType)) -- Returns m, a -- If the incoming type is a mutable type variable of kind k, then -- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. @@ -291,24 +298,21 @@ matchExpectedAppTy orig_ty = do { cts <- readMetaTyVar tv ; case cts of Indirect ty -> go ty - Flexi -> defer } + Flexi -> defer (isReturnTyVar tv) } - go _ = defer + go _ = defer False -- Defer splitting by generating an equality constraint - defer = do { ty1 <- newFlexiTyVarTy kind1 - ; ty2 <- newFlexiTyVarTy kind2 - ; co <- unifyType (mkAppTy ty1 ty2) orig_ty - ; return (co, (ty1, ty2)) } + defer is_return + = do { ty1 <- newMaybeReturnTyVarTy is_return kind1 + ; ty2 <- newMaybeReturnTyVarTy is_return kind2 + ; co <- unifyType noThing (mkAppTy ty1 ty2) orig_ty + ; return (co, (ty1, ty2)) } orig_kind = typeKind orig_ty - kind1 = mkArrowKind liftedTypeKind (defaultKind orig_kind) + kind1 = mkFunTy liftedTypeKind orig_kind kind2 = liftedTypeKind -- m :: * -> k -- arg type :: * - -- The defaultKind is a bit smelly. If you remove it, - -- try compiling f x = do { x } - -- and you'll get a kind mis-match. It smells, but - -- not enough to lose sleep over. {- ************************************************************************ @@ -383,19 +387,29 @@ So it's important that we unify beta := forall a. a->a, rather than skolemising the type. -} -tcSubType :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +tcSubType :: UserTypeCtxt -> Maybe Id -- ^ If present, it has type ty_actual + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper -- Checks that actual <= expected -- Returns HsWrapper :: actual ~ expected -tcSubType ctxt ty_actual ty_expected +tcSubType ctxt maybe_id ty_actual ty_expected = addSubTypeCtxt ty_actual ty_expected $ - tcSubType_NC ctxt ty_actual ty_expected + do { traceTc "tcSubType" (vcat [ pprUserTypeCtxt ctxt + , ppr maybe_id + , ppr ty_actual + , ppr ty_expected ]) + ; tc_sub_type origin ctxt ty_actual ty_expected } + where + origin = TypeEqOrigin { uo_actual = ty_actual + , uo_expected = ty_expected + , uo_thing = mkErrorThing <$> maybe_id } -tcSubTypeDS :: UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper +tcSubTypeDS :: Outputable a => UserTypeCtxt -> a -- ^ has type ty_actual + -> TcSigmaType -> TcRhoType -> TcM HsWrapper -- Just like tcSubType, but with the additional precondition that -- ty_expected is deeply skolemised (hence "DS") -tcSubTypeDS ctxt ty_actual ty_expected +tcSubTypeDS ctxt expr ty_actual ty_expected = addSubTypeCtxt ty_actual ty_expected $ - tcSubTypeDS_NC ctxt ty_actual ty_expected + tcSubTypeDS_NC ctxt (Just expr) ty_actual ty_expected addSubTypeCtxt :: TcType -> TcType -> TcM a -> TcM a @@ -424,20 +438,27 @@ tcSubType_NC ctxt ty_actual ty_expected = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) ; tc_sub_type origin ctxt ty_actual ty_expected } where - origin = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty_expected } - -tcSubTypeDS_NC :: UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper -tcSubTypeDS_NC ctxt ty_actual ty_expected + origin = TypeEqOrigin { uo_actual = ty_actual + , uo_expected = ty_expected + , uo_thing = Nothing } + +tcSubTypeDS_NC :: Outputable a + => UserTypeCtxt + -> Maybe a -- ^ If present, this has type ty_actual + -> TcSigmaType -> TcRhoType -> TcM HsWrapper +tcSubTypeDS_NC ctxt maybe_thing ty_actual ty_expected = do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) ; tc_sub_type_ds origin ctxt ty_actual ty_expected } where - origin = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty_expected } + origin = TypeEqOrigin { uo_actual = ty_actual + , uo_expected = ty_expected + , uo_thing = mkErrorThing <$> maybe_thing } --------------- tc_sub_type :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper tc_sub_type origin ctxt ty_actual ty_expected | isTyVarTy ty_actual -- See Note [Higher rank types] - = do { cow <- uType origin ty_actual ty_expected + = do { cow <- uType origin TypeLevel ty_actual ty_expected ; return (mkWpCastN cow) } | otherwise -- See Note [Deep skolemisation] @@ -466,17 +487,17 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected theta' = substTheta subst theta in_rho' = substTy subst in_rho ; in_wrap <- instCall origin tys' theta' - ; body_wrap <- tcSubTypeDS_NC ctxt in_rho' ty_expected + ; body_wrap <- tcSubTypeDS_NC ctxt noThing in_rho' ty_expected ; return (body_wrap <.> in_wrap) } | otherwise -- Revert to unification - = do { cow <- uType origin ty_actual ty_expected + = do { cow <- uType origin TypeLevel ty_actual ty_expected ; return (mkWpCastN cow) } ----------------- tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId) tcWrapResult expr actual_ty res_ty - = do { cow <- tcSubTypeDS GenSigCtxt actual_ty res_ty + = do { cow <- tcSubTypeDS GenSigCtxt expr actual_ty res_ty -- Both types are deeply skolemised ; return (mkHsWrap cow expr) } @@ -499,14 +520,14 @@ wrapFunResCoercion arg_tys co_fn_res -- which can unify with *anything*. See also Note [ReturnTv] in TcType tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) tcInfer tc_check - = do { ret_tv <- newReturnTyVar openTypeKind + = do { (ret_tv, ret_kind) <- newOpenReturnTyVar ; res <- tc_check (mkTyVarTy ret_tv) ; details <- readMetaTyVar ret_tv ; res_ty <- case details of Indirect ty -> return ty Flexi -> -- Checking was uninformative do { traceTc "Defaulting un-filled ReturnTv to a TauTv" (ppr ret_tv) - ; tau_ty <- newFlexiTyVarTy openTypeKind + ; tau_ty <- newFlexiTyVarTy ret_kind ; writeMetaTyVar ret_tv tau_ty ; return tau_ty } ; return (res, res_ty) } @@ -521,8 +542,11 @@ tcInfer tc_check tcGen :: UserTypeCtxt -> TcType -> ([TcTyVar] -> TcRhoType -> TcM result) + -- ^ thing_inside is passed only the *type* variables, not + -- *coercion* variables. They are only ever used for scoped type + -- variables. -> TcM (HsWrapper, result) - -- The expression has type: spec_ty -> expected_ty + -- ^ The expression has type: spec_ty -> expected_ty tcGen ctxt expected_ty thing_inside -- We expect expected_ty to be a forall-type @@ -532,9 +556,12 @@ tcGen ctxt expected_ty thing_inside ; lvl <- getTcLevel ; when debugIsOn $ - traceTc "tcGen" $ vcat [ ppr lvl, - text "expected_ty" <+> ppr expected_ty, - text "inst ty" <+> ppr tvs' <+> ppr rho' ] + traceTc "tcGen" $ vcat [ + ppr lvl, + text "expected_ty" <+> ppr expected_ty, + text "inst tyvars" <+> ppr tvs', + text "given" <+> ppr given, + text "inst type" <+> ppr rho' ] -- Generally we must check that the "forall_tvs" havn't been constrained -- The interesting bit here is that we must include the free variables @@ -551,7 +578,7 @@ tcGen ctxt expected_ty thing_inside -- Use the *instantiated* type in the SkolemInfo -- so that the names of displayed type variables line up - ; let skol_info = SigSkol ctxt (mkPiTypes given rho') + ; let skol_info = SigSkol ctxt (mkFunTys (map varType given) rho') ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ thing_inside tvs' rho' @@ -567,7 +594,8 @@ checkConstraints :: SkolemInfo -> TcM (TcEvBinds, result) checkConstraints skol_info skol_tvs given thing_inside - = do { (implics, ev_binds, result) <- buildImplication skol_info skol_tvs given thing_inside + = do { (implics, ev_binds, result) + <- buildImplication skol_info skol_tvs given thing_inside ; emitImplications implics ; return (ev_binds, result) } @@ -577,16 +605,23 @@ buildImplication :: SkolemInfo -> TcM result -> TcM (Bag Implication, TcEvBinds, result) buildImplication skol_info skol_tvs given thing_inside - | null skol_tvs && null given - = do { res <- thing_inside - ; return (emptyBag, emptyTcEvBinds, res) } + = do { tc_lvl <- getTcLevel + ; deferred_type_errors <- goptM Opt_DeferTypeErrors <||> + goptM Opt_DeferTypedHoles + ; if null skol_tvs && null given && (not deferred_type_errors || + not (isTopTcLevel tc_lvl)) + then do { res <- thing_inside + ; return (emptyBag, emptyTcEvBinds, res) } -- Fast path. We check every function argument with -- tcPolyExpr, which uses tcGen and hence checkConstraints. - - | otherwise - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + -- But with the solver producing unlifted equalities, we need + -- to have an EvBindsVar for them when they might be deferred to + -- runtime. Otherwise, they end up as top-level unlifted bindings, + -- which are verboten. + else + do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted - ; return (implics, ev_binds, result) } + ; return (implics, ev_binds, result) }} buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] -> [EvVar] -> WantedConstraints @@ -610,7 +645,7 @@ buildImplicationFor tclvl skol_info skol_tvs given wanted , ic_given = given , ic_wanted = wanted , ic_status = IC_Unsolved - , ic_binds = ev_binds_var + , ic_binds = Just ev_binds_var , ic_env = env , ic_info = skol_info } @@ -627,17 +662,36 @@ The exported functions are all defined as versions of some non-exported generic functions. -} -unifyType :: TcTauType -> TcTauType -> TcM TcCoercion +-- | Unify two types, discarding a resultant coercion. Any constraints +-- generated will still need to be solved, however. +unifyType_ :: Outputable a => Maybe a -- ^ If present, has type 'ty1' + -> TcTauType -> TcTauType -> TcM () +unifyType_ thing ty1 ty2 = void $ unifyType thing ty1 ty2 + +unifyType :: Outputable a => Maybe a -- ^ If present, has type 'ty1' + -> TcTauType -> TcTauType -> TcM TcCoercion -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 -unifyType ty1 ty2 = uType origin ty1 ty2 +unifyType thing ty1 ty2 = uType origin TypeLevel ty1 ty2 where - origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } + origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 + , uo_thing = mkErrorThing <$> thing } + +-- | Use this instead of 'Nothing' when calling 'unifyType' without +-- a good "thing" (where the "thing" has the "actual" type passed in) +-- This has an 'Outputable' instance, avoiding amgiguity problems. +noThing :: Maybe (HsExpr Name) +noThing = Nothing + +unifyKind :: Outputable a => Maybe a -> TcKind -> TcKind -> TcM Coercion +unifyKind thing ty1 ty2 = uType origin KindLevel ty1 ty2 + where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 + , uo_thing = mkErrorThing <$> thing } --------------- unifyPred :: PredType -> PredType -> TcM TcCoercion -- Actual and expected types -unifyPred = unifyType +unifyPred = unifyType noThing --------------- unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercion] @@ -649,47 +703,32 @@ unifyTheta theta1 theta2 ; zipWithM unifyPred theta1 theta2 } {- -@unifyTypeList@ takes a single list of @TauType@s and unifies them -all together. It is used, for example, when typechecking explicit -lists, when all the elts should be of the same type. --} - -unifyTypeList :: [TcTauType] -> TcM () -unifyTypeList [] = return () -unifyTypeList [_] = return () -unifyTypeList (ty1:tys@(ty2:_)) = do { _ <- unifyType ty1 ty2 - ; unifyTypeList tys } - -{- -************************************************************************ -* * +%************************************************************************ +%* * uType and friends -* * -************************************************************************ +%* * +%************************************************************************ -uType is the heart of the unifier. Each arg occurs twice, because -we want to report errors in terms of synomyms if possible. The first of -the pair is used in error messages only; it is always the same as the -second, except that if the first is a synonym then the second may be a -de-synonym'd version. This way we get better error messages. +uType is the heart of the unifier. -} ------------ uType, uType_defer :: CtOrigin + -> TypeOrKind -> TcType -- ty1 is the *actual* type -> TcType -- ty2 is the *expected* type - -> TcM TcCoercion + -> TcM Coercion -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] -uType_defer origin ty1 ty2 - = do { eqv <- newEq ty1 ty2 - ; loc <- getCtLocM origin +uType_defer origin t_or_k ty1 ty2 + = do { hole <- newCoercionHole + ; loc <- getCtLocM origin (Just t_or_k) ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_evar = eqv - , ctev_pred = mkTcEqPred ty1 ty2 + CtWanted { ctev_dest = HoleDest hole + , ctev_pred = mkPrimEqPred ty1 ty2 , ctev_loc = loc } -- Error trace only @@ -698,26 +737,25 @@ uType_defer origin ty1 ty2 ; whenDOptM Opt_D_dump_tc_trace $ do { ctxt <- getErrCtxt ; doc <- mkErrInfo emptyTidyEnv ctxt - ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, + ; traceTc "utype_defer" (vcat [ppr hole, ppr ty1, ppr ty2, pprCtOrigin origin, doc]) } - ; return (mkTcCoVarCo eqv) } + ; return (mkHoleCo hole Nominal ty1 ty2) } -------------- --- unify_np (short for "no push" on the origin stack) does the work -uType origin orig_ty1 orig_ty2 +uType origin t_or_k orig_ty1 orig_ty2 = do { tclvl <- getTcLevel ; traceTc "u_tys " $ vcat [ text "tclvl" <+> ppr tclvl , sep [ ppr orig_ty1, text "~", ppr orig_ty2] , pprCtOrigin origin] ; co <- go orig_ty1 orig_ty2 - ; if isTcReflCo co + ; if isReflCo co then traceTc "u_tys yields no coercion" Outputable.empty else traceTc "u_tys yields coercion:" (ppr co) ; return co } where - go :: TcType -> TcType -> TcM TcCoercion + go :: TcType -> TcType -> TcM Coercion -- The arguments to 'go' are always semantically identical -- to orig_ty{1,2} except for looking through type synonyms @@ -728,13 +766,20 @@ uType origin orig_ty1 orig_ty2 go (TyVarTy tv1) ty2 = do { lookup_res <- lookupTcTyVar tv1 ; case lookup_res of - Filled ty1 -> go ty1 ty2 - Unfilled ds1 -> uUnfilledVar origin NotSwapped tv1 ds1 ty2 } + Filled ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) + ; go ty1 ty2 } + Unfilled ds1 -> uUnfilledVar origin t_or_k NotSwapped tv1 ds1 ty2 } go ty1 (TyVarTy tv2) = do { lookup_res <- lookupTcTyVar tv2 ; case lookup_res of - Filled ty2 -> go ty1 ty2 - Unfilled ds2 -> uUnfilledVar origin IsSwapped tv2 ds2 ty1 } + Filled ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) + ; go ty1 ty2 } + Unfilled ds2 -> uUnfilledVar origin t_or_k IsSwapped tv2 ds2 ty1 } + + -- See Note [Expanding synonyms during unification] + go ty1@(TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = return $ mkReflCo Nominal ty1 -- See Note [Expanding synonyms during unification] -- @@ -748,11 +793,19 @@ uType origin orig_ty1 orig_ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' + go (CastTy t1 co1) t2 + = do { co_tys <- go t1 t2 + ; return (mkCoherenceLeftCo co_tys co1) } + + go t1 (CastTy t2 co2) + = do { co_tys <- go t1 t2 + ; return (mkCoherenceRightCo co_tys co2) } + -- Functions (or predicate functions) just check the two parts - go (FunTy fun1 arg1) (FunTy fun2 arg2) - = do { co_l <- uType origin fun1 fun2 - ; co_r <- uType origin arg1 arg2 - ; return $ mkTcFunCo Nominal co_l co_r } + go (ForAllTy (Anon fun1) arg1) (ForAllTy (Anon fun2) arg2) + = do { co_l <- uType origin t_or_k fun1 fun2 + ; co_r <- uType origin t_or_k arg1 arg2 + ; return $ mkFunCo Nominal co_l co_r } -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.) @@ -764,13 +817,21 @@ uType origin orig_ty1 orig_ty2 go (TyConApp tc1 tys1) (TyConApp tc2 tys2) -- See Note [Mismatched type lists and application decomposition] | tc1 == tc2, length tys1 == length tys2 - = ASSERT( isGenerativeTyCon tc1 Nominal ) - do { cos <- zipWithM (uType origin) tys1 tys2 - ; return $ mkTcTyConAppCo Nominal tc1 cos } + = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 ) + do { cos <- zipWith3M (uType origin) t_or_ks tys1 tys2 + ; return $ mkTyConAppCo Nominal tc1 cos } + where + (bndrs, _) = splitPiTys (tyConKind tc1) + t_or_ks = case t_or_k of + KindLevel -> repeat KindLevel + TypeLevel -> map (\bndr -> if isNamedBinder bndr + then KindLevel + else TypeLevel) + bndrs go (LitTy m) ty@(LitTy n) | m == n - = return $ mkTcNomReflCo ty + = return $ mkNomReflCo ty -- See Note [Care with type applications] -- Do not decompose FunTy against App; @@ -788,20 +849,28 @@ uType origin orig_ty1 orig_ty2 = ASSERT( mightBeUnsaturatedTyCon tc1 ) go_app (TyConApp tc1 ts1') t1' s2 t2 + go (CoercionTy co1) (CoercionTy co2) + = do { let ty1 = coercionType co1 + ty2 = coercionType co2 + ; kco <- uType (KindEqOrigin orig_ty1 orig_ty2 origin (Just t_or_k)) + KindLevel + ty1 ty2 + ; return $ mkProofIrrelCo Nominal kco co1 co2 } + -- Anything else fails -- E.g. unifying for-all types, which is relative unusual go ty1 ty2 = defer ty1 ty2 ------------------ defer ty1 ty2 -- See Note [Check for equality before deferring] - | ty1 `tcEqType` ty2 = return (mkTcNomReflCo ty1) - | otherwise = uType_defer origin ty1 ty2 + | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1) + | otherwise = uType_defer origin t_or_k ty1 ty2 ------------------ go_app s1 t1 s2 t2 - = do { co_s <- uType origin s1 s2 -- See Note [Unifying AppTy] - ; co_t <- uType origin t1 t2 - ; return $ mkTcAppCo co_s co_t } + = do { co_s <- uType origin t_or_k s1 s2 + ; co_t <- uType origin t_or_k t1 t2 + ; return $ mkAppCo co_s co_t } {- Note [Check for equality before deferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -821,16 +890,6 @@ They can match FunTy and TyConApp, so use splitAppTy_maybe NB: we've already dealt with type variables and Notes, so if one type is an App the other one jolly well better be too -Note [Unifying AppTy] -~~~~~~~~~~~~~~~~~~~~~ -Consider unifying (m Int) ~ (IO Int) where m is a unification variable -that is now bound to (say) (Bool ->). Then we want to report - "Can't unify (Bool -> Int) with (IO Int) -and not - "Can't unify ((->) Bool) with IO" -That is why we use the "_np" variant of uType, which does not alter the error -message. - Note [Mismatched type lists and application decomposition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we find two TyConApps, you might think that the argument lists @@ -863,6 +922,11 @@ We expand synonyms during unification, but: Phantom Int ~ Phantom Char it is *wrong* to unify Int and Char. + * The problem case immediately above can happen only with arguments + to the tycon. So we check for nullary tycons *before* expanding. + This is particularly helpful when checking (* ~ *), because * is + now a type synonym. + Note [Deferred Unification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, @@ -900,32 +964,37 @@ back into @uTys@ if it turns out that the variable is already bound. -} uUnfilledVar :: CtOrigin + -> TypeOrKind -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTauType -- Type 2 - -> TcM TcCoercion + -> TcM Coercion -- "Unfilled" means that the variable is definitely not a filled-in meta tyvar -- It might be a skolem, or untouchable, or meta -uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2) +uUnfilledVar origin t_or_k swapped tv1 details1 (TyVarTy tv2) | tv1 == tv2 -- Same type variable => no-op - = return (mkTcNomReflCo (mkTyVarTy tv1)) + = return (mkNomReflCo (mkTyVarTy tv1)) | otherwise -- Distinct type variables = do { lookup2 <- lookupTcTyVar tv2 ; case lookup2 of - Filled ty2' -> uUnfilledVar origin swapped tv1 details1 ty2' - Unfilled details2 -> uUnfilledVars origin swapped tv1 details1 tv2 details2 + Filled ty2' + -> uUnfilledVar origin t_or_k swapped tv1 details1 ty2' + Unfilled details2 + -> uUnfilledVars origin t_or_k swapped tv1 details1 tv2 details2 } -uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type variable +uUnfilledVar origin t_or_k swapped tv1 details1 non_var_ty2 +-- ty2 is not a type variable = case details1 of MetaTv { mtv_ref = ref1 } -> do { dflags <- getDynFlags - ; mb_ty2' <- checkTauTvUpdate dflags tv1 non_var_ty2 + ; mb_ty2' <- checkTauTvUpdate dflags origin t_or_k tv1 non_var_ty2 ; case mb_ty2' of - Just ty2' -> updateMeta tv1 ref1 ty2' - Nothing -> do { traceTc "Occ/kind defer" + Just (ty2', co_k) -> maybe_sym swapped <$> + updateMeta tv1 ref1 ty2' co_k + Nothing -> do { traceTc "Occ/type-family defer" (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) $$ ppr non_var_ty2 $$ ppr (typeKind non_var_ty2)) ; defer } @@ -933,63 +1002,76 @@ uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type varia _other -> do { traceTc "Skolem defer" (ppr tv1); defer } -- Skolems of all sorts where - defer = unSwap swapped (uType_defer origin) (mkTyVarTy tv1) non_var_ty2 + defer = unSwap swapped (uType_defer origin t_or_k) (mkTyVarTy tv1) non_var_ty2 -- Occurs check or an untouchable: just defer -- NB: occurs check isn't necessarily fatal: -- eg tv1 occured in type family parameter ---------------- uUnfilledVars :: CtOrigin + -> TypeOrKind -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTyVar -> TcTyVarDetails -- Tyvar 2 - -> TcM TcCoercion + -> TcM Coercion -- Invarant: The type variables are distinct, -- Neither is filled in yet -uUnfilledVars origin swapped tv1 details1 tv2 details2 - = do { traceTc "uUnfilledVars" ( text "trying to unify" <+> ppr k1 +uUnfilledVars origin t_or_k swapped tv1 details1 tv2 details2 + = do { traceTc "uUnfilledVars for" (ppr tv1 <+> text "and" <+> ppr tv2) + ; traceTc "uUnfilledVars" ( text "trying to unify" <+> ppr k1 <+> text "with" <+> ppr k2) - ; mb_sub_kind <- unifyKindX k1 k2 - ; case mb_sub_kind of { - Nothing -> unSwap swapped (uType_defer origin) (mkTyVarTy tv1) ty2 ; - Just sub_kind -> - - case (sub_kind, details1, details2) of - -- k1 < k2, so update tv2 - (LT, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 - - -- k2 < k1, so update tv1 - (GT, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 - - -- k1 = k2, so we are free to update either way - (EQ, MetaTv { mtv_info = i1, mtv_ref = ref1 }, - MetaTv { mtv_info = i2, mtv_ref = ref2 }) - | nicer_to_update_tv1 tv1 i1 i2 -> updateMeta tv1 ref1 ty2 - | otherwise -> updateMeta tv2 ref2 ty1 - (EQ, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 - (EQ, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 + ; co_k <- uType kind_origin KindLevel k1 k2 + ; let no_swap ref = maybe_sym swapped <$> + updateMeta tv1 ref ty2 (mkSymCo co_k) + do_swap ref = maybe_sym (flipSwap swapped) <$> + updateMeta tv2 ref ty1 co_k + ; case (details1, details2) of + { ( MetaTv { mtv_info = i1, mtv_ref = ref1 } + , MetaTv { mtv_info = i2, mtv_ref = ref2 } ) + | nicer_to_update_tv1 tv1 i1 i2 -> no_swap ref1 + | otherwise -> do_swap ref2 + ; (MetaTv { mtv_ref = ref1 }, _) -> no_swap ref1 + ; (_, MetaTv { mtv_ref = ref2 }) -> do_swap ref2 -- Can't do it in-place, so defer -- This happens for skolems of all sorts - (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } } + ; _ -> do { traceTc "deferring because I can't find a meta-tyvar:" + (pprTcTyVarDetails details1 <+> pprTcTyVarDetails details2) + ; unSwap swapped (uType_defer origin t_or_k) ty1 ty2 } } } where k1 = tyVarKind tv1 k2 = tyVarKind tv2 ty1 = mkTyVarTy tv1 ty2 = mkTyVarTy tv2 + kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k) + +-- | apply sym iff swapped +maybe_sym :: SwapFlag -> Coercion -> Coercion +maybe_sym IsSwapped = mkSymCo +maybe_sym NotSwapped = id nicer_to_update_tv1 :: TcTyVar -> MetaInfo -> MetaInfo -> Bool nicer_to_update_tv1 _ _ SigTv = True nicer_to_update_tv1 _ SigTv _ = False -nicer_to_update_tv1 tv1 _ _ = isSystemName (Var.varName tv1) -- Try not to update SigTvs; and try to update sys-y type -- variables in preference to ones gotten (say) by -- instantiating a polymorphic function with a user-written -- type sig +nicer_to_update_tv1 _ ReturnTv _ = True +nicer_to_update_tv1 _ _ ReturnTv = False + -- ReturnTvs are really holes just begging to be filled in. + -- Let's oblige. +nicer_to_update_tv1 tv1 _ _ = isSystemName (Var.varName tv1) ---------------- -checkTauTvUpdate :: DynFlags -> TcTyVar -> TcType -> TcM (Maybe TcType) +checkTauTvUpdate :: DynFlags + -> CtOrigin + -> TypeOrKind + -> TcTyVar -- tv :: k1 + -> TcType -- ty :: k2 + -> TcM (Maybe ( TcType -- possibly-expanded ty + , Coercion )) -- :: k2 ~N k1 -- (checkTauTvUpdate tv ty) -- We are about to update the TauTv/ReturnTv tv with ty. -- Check (a) that tv doesn't occur in ty (occurs check) @@ -1010,37 +1092,31 @@ checkTauTvUpdate :: DynFlags -> TcTyVar -> TcType -> TcM (Maybe TcType) -- we return Nothing, leaving it to the later constraint simplifier to -- sort matters out. -checkTauTvUpdate dflags tv ty +checkTauTvUpdate dflags origin t_or_k tv ty | SigTv <- info = ASSERT( not (isTyVarTy ty) ) return Nothing | otherwise - = do { ty <- zonkTcType ty - ; sub_k <- unifyKindX (tyVarKind tv) (typeKind ty) - ; case sub_k of - Nothing -> return Nothing -- Kinds don't unify - Just LT -> return Nothing -- (tv :: *) ~ (ty :: ?) - -- Don't unify because that would widen tv's kind - - _ | is_return_tv -- ReturnTv: a simple occurs-check is all that we need + = do { ty <- zonkTcType ty + ; co_k <- uType kind_origin KindLevel (typeKind ty) (tyVarKind tv) + ; if | is_return_tv -> -- ReturnTv: a simple occurs-check is all that we need -- See Note [ReturnTv] in TcType - -> if tv `elemVarSet` tyVarsOfType ty - then return Nothing - else return (Just ty) - - _ | defer_me ty -- Quick test - -> -- Failed quick test so try harder - case occurCheckExpand dflags tv ty of + if tv `elemVarSet` tyCoVarsOfType ty + then return Nothing + else return (Just (ty, co_k)) + | defer_me ty -> -- Quick test + -- Failed quick test so try harder + case occurCheckExpand dflags tv ty of OC_OK ty2 | defer_me ty2 -> return Nothing - | otherwise -> return (Just ty2) - _ -> return Nothing - - _ | otherwise -> return (Just ty) } + | otherwise -> return (Just (ty2, co_k)) + _ -> return Nothing + | otherwise -> return (Just (ty, co_k)) } where - details = ASSERT2( isMetaTyVar tv, ppr tv ) tcTyVarDetails tv - info = mtv_info details - is_return_tv = isReturnTyVar tv - impredicative = canUnifyWithPolyType dflags details (tyVarKind tv) + kind_origin = KindEqOrigin (mkTyVarTy tv) ty origin (Just t_or_k) + details = tcTyVarDetails tv + info = mtv_info details + is_return_tv = isReturnTyVar tv + impredicative = canUnifyWithPolyType dflags details defer_me :: TcType -> Bool -- Checks for (a) occurrence of tv @@ -1049,12 +1125,17 @@ checkTauTvUpdate dflags tv ty -- See Note [Conservative unification check] defer_me (LitTy {}) = False defer_me (TyVarTy tv') = tv == tv' - defer_me (TyConApp tc tys) = isTypeFamilyTyCon tc - || any defer_me tys + defer_me (TyConApp tc tys) = isTypeFamilyTyCon tc || any defer_me tys || not (impredicative || isTauTyCon tc) - defer_me (FunTy arg res) = defer_me arg || defer_me res + defer_me (ForAllTy bndr t) = defer_me (binderType bndr) || defer_me t + || (isNamedBinder bndr && not impredicative) defer_me (AppTy fun arg) = defer_me fun || defer_me arg - defer_me (ForAllTy _ ty) = not impredicative || defer_me ty + defer_me (CastTy ty co) = defer_me ty || defer_me_co co + defer_me (CoercionTy co) = defer_me_co co + + -- We don't really care if there are type families in a coercion, + -- but we still can't have an occurs-check failure + defer_me_co co = tv `elemVarSet` tyCoVarsOfCo co {- Note [Conservative unification check] @@ -1150,6 +1231,33 @@ use a local "ok" function, a variant of TcType.occurCheckExpand. HOWEVER, we *do* now have a flat-cache, which effectively recovers the sharing, so there's no great harm in losing it -- and it's generally more efficient to do the unification up-front. + +Note [Non-TcTyVars in TcUnify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because the same code is now shared between unifying types and unifying +kinds, we sometimes will see proper TyVars floating around the unifier. +Example (from test case polykinds/PolyKinds12): + + type family Apply (f :: k1 -> k2) (x :: k1) :: k2 + type instance Apply g y = g y + +When checking the instance declaration, we first *kind-check* the LHS +and RHS, discovering that the instance really should be + + type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y + +During this kind-checking, all the tyvars will be TcTyVars. Then, however, +as a second pass, we desugar the RHS (which is done in functions prefixed +with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper +TyVars, not TcTyVars, get some kind unification must happen. + +Thus, we always check if a TyVar is a TcTyVar before asking if it's a +meta-tyvar. + +This used to not be necessary for type-checking (that is, before * :: *) +because expressions get desugared via an algorithm separate from +type-checking (with wrappers, etc.). Types get desugared very differently, +causing this wibble in behavior seen here. -} data LookupTyVarResult -- The result of a lookupTcTyVar call @@ -1171,13 +1279,20 @@ lookupTcTyVar tyvar | otherwise = return (Unfilled details) where - details = ASSERT2( isTcTyVar tyvar, ppr tyvar ) - tcTyVarDetails tyvar - -updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM TcCoercion -updateMeta tv1 ref1 ty2 - = do { writeMetaTyVarRef tv1 ref1 ty2 - ; return (mkTcNomReflCo ty2) } + details = tcTyVarDetails tyvar + +-- | Fill in a meta-tyvar +updateMeta :: TcTyVar -- ^ tv to fill in, tv :: k1 + -> TcRef MetaDetails -- ^ ref to tv's metadetails + -> TcType -- ^ ty2 :: k2 + -> Coercion -- ^ kind_co :: k2 ~N k1 + -> TcM Coercion -- ^ :: tv ~N ty2 (= ty2 |> kind_co ~N ty2) +updateMeta tv1 ref1 ty2 kind_co + = do { let ty2_refl = mkNomReflCo ty2 + (ty2', co) = ( ty2 `mkCastTy` kind_co + , mkCoherenceLeftCo ty2_refl kind_co ) + ; writeMetaTyVarRef tv1 ref1 ty2' + ; return co } {- Note [Unifying untouchables] @@ -1185,176 +1300,41 @@ Note [Unifying untouchables] We treat an untouchable type variable as if it was a skolem. That ensures it won't unify with anything. It's a slight had, because we return a made-up TcTyVarDetails, but I think it works smoothly. - - -************************************************************************ -* * - Kind unification -* * -************************************************************************ - -Unifying kinds is much, much simpler than unifying types. - -One small wrinkle is that as far as the user is concerned, types of kind -Constraint should only be allowed to occur where we expect *exactly* that kind. -We SHOULD NOT allow a type of kind fact to appear in a position expecting -one of argTypeKind or openTypeKind. - -The situation is different in the core of the compiler, where we are perfectly -happy to have types of kind Constraint on either end of an arrow. - -Note [Kind variables can be untouchable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must use the careful function lookupTcTyVar to see if a kind -variable is filled or unifiable. It checks for touchablity, and kind -variables can certainly be untouchable --- for example the variable -might be bound outside an enclosing existental pattern match that -binds an inner kind variable, which we don't want to escape outside. - -This, or something closely related, was the cause of Trac #8985. - -Note [Unifying kind variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather hackily, kind variables can be TyVars not just TcTyVars. -Main reason is in - data instance T (D (x :: k)) = ...con-decls... -Here we bring into scope a kind variable 'k', and use it in the -con-decls. BUT the con-decls will be finished and frozen, and -are not amenable to subsequent substitution, so it makes sense -to have the *final* kind-variable (a KindVar, not a TcKindVar) in -scope. So at least during kind unification we can encounter a -KindVar. - -Hence the isTcTyVar tests before calling lookupTcTyVar. -} -matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) --- Like unifyFunTy, but does not fail; instead just returns Nothing - -matchExpectedFunKind (FunTy arg_kind res_kind) - = return (Just (arg_kind,res_kind)) - -matchExpectedFunKind (TyVarTy kvar) - | isTcTyVar kvar, isMetaTyVar kvar - = do { maybe_kind <- readMetaTyVar kvar - ; case maybe_kind of - Indirect fun_kind -> matchExpectedFunKind fun_kind - Flexi -> - do { arg_kind <- newMetaKindVar - ; res_kind <- newMetaKindVar - ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) - ; return (Just (arg_kind,res_kind)) } } - -matchExpectedFunKind _ = return Nothing - ------------------ -unifyKindX :: TcKind -- k1 (actual) - -> TcKind -- k2 (expected) - -> TcM (Maybe Ordering) - -- Returns the relation between the kinds - -- Just LT <=> k1 is a sub-kind of k2 - -- Nothing <=> incomparable - --- unifyKindX deals with the top-level sub-kinding story --- but recurses into the simpler unifyKindEq for any sub-terms --- The sub-kinding stuff only applies at top level - -unifyKindX (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindX kv1 k2 -unifyKindX k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindX kv2 k1 - -unifyKindX k1 k2 -- See Note [Expanding synonyms during unification] - | Just k1' <- coreView k1 = unifyKindX k1' k2 - | Just k2' <- coreView k2 = unifyKindX k1 k2' - -unifyKindX (TyConApp kc1 []) (TyConApp kc2 []) - | kc1 == kc2 = return (Just EQ) - | kc1 `tcIsSubKindCon` kc2 = return (Just LT) - | kc2 `tcIsSubKindCon` kc1 = return (Just GT) - | otherwise = return Nothing - -unifyKindX k1 k2 = unifyKindEq k1 k2 - -- In all other cases, let unifyKindEq do the work - -------------------- -uKVar :: SwapFlag -> (TcKind -> TcKind -> TcM (Maybe Ordering)) - -> MetaKindVar -> TcKind -> TcM (Maybe Ordering) -uKVar swapped unify_kind kv1 k2 - | isTcTyVar kv1 - = do { lookup_res <- lookupTcTyVar kv1 -- See Note [Kind variables can be untouchable] - ; case lookup_res of - Filled k1 -> unSwap swapped unify_kind k1 k2 - Unfilled ds1 -> uUnfilledKVar kv1 ds1 k2 } - - | otherwise -- See Note [Unifying kind variables] - = uUnfilledKVar kv1 vanillaSkolemTv k2 - -------------------- -uUnfilledKVar :: MetaKindVar -> TcTyVarDetails -> TcKind -> TcM (Maybe Ordering) -uUnfilledKVar kv1 ds1 (TyVarTy kv2) - | kv1 == kv2 - = return (Just EQ) - - | isTcTyVar kv2 - = do { lookup_res <- lookupTcTyVar kv2 - ; case lookup_res of - Filled k2 -> uUnfilledKVar kv1 ds1 k2 - Unfilled ds2 -> uUnfilledKVars kv1 ds1 kv2 ds2 } - - | otherwise -- See Note [Unifying kind variables] - = uUnfilledKVars kv1 ds1 kv2 vanillaSkolemTv - -uUnfilledKVar kv1 ds1 non_var_k2 - = case ds1 of - MetaTv { mtv_info = SigTv } - -> return Nothing - MetaTv { mtv_ref = ref1 } - -> do { k2a <- zonkTcKind non_var_k2 - ; let k2b = defaultKind k2a - -- MetaKindVars must be bound only to simple kinds - - ; dflags <- getDynFlags - ; case occurCheckExpand dflags kv1 k2b of - OC_OK k2c -> do { writeMetaTyVarRef kv1 ref1 k2c; return (Just EQ) } - _ -> return Nothing } - _ -> return Nothing - -------------------- -uUnfilledKVars :: MetaKindVar -> TcTyVarDetails - -> MetaKindVar -> TcTyVarDetails - -> TcM (Maybe Ordering) --- kv1 /= kv2 -uUnfilledKVars kv1 ds1 kv2 ds2 - = case (ds1, ds2) of - (MetaTv { mtv_info = i1, mtv_ref = r1 }, - MetaTv { mtv_info = i2, mtv_ref = r2 }) - | nicer_to_update_tv1 kv1 i1 i2 -> do_update kv1 r1 kv2 - | otherwise -> do_update kv2 r2 kv1 - (MetaTv { mtv_ref = r1 }, _) -> do_update kv1 r1 kv2 - (_, MetaTv { mtv_ref = r2 }) -> do_update kv2 r2 kv1 - _ -> return Nothing +-- | Breaks apart a function kind into its pieces. +matchExpectedFunKind :: Arity -- ^ # of args remaining, only for errors + -> TcType -- ^ type, only for errors + -> TcKind -- ^ function kind + -> TcM (Coercion, TcKind, TcKind) + -- ^ co :: old_kind ~ arg -> res +matchExpectedFunKind num_args_remaining ty = go where - do_update kv1 r1 kv2 - = do { writeMetaTyVarRef kv1 r1 (mkTyVarTy kv2); return (Just EQ) } - ---------------------------- -unifyKindEq :: TcKind -> TcKind -> TcM (Maybe Ordering) --- Unify two kinds looking for equality not sub-kinding --- So it returns Nothing or (Just EQ) only -unifyKindEq (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindEq kv1 k2 -unifyKindEq k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindEq kv2 k1 - -unifyKindEq (FunTy a1 r1) (FunTy a2 r2) - = do { mb1 <- unifyKindEq a1 a2; mb2 <- unifyKindEq r1 r2 - ; return (if isJust mb1 && isJust mb2 then Just EQ else Nothing) } - -unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) - | kc1 == kc2 - = ASSERT(length k1s == length k2s) - -- Should succeed since the kind constructors are the same, - -- and the kinds are sort-checked, thus fully applied - do { mb_eqs <- zipWithM unifyKindEq k1s k2s - ; return (if all isJust mb_eqs - then Just EQ - else Nothing) } - -unifyKindEq _ _ = return Nothing + go k | Just k' <- coreView k = go k' + + go k@(TyVarTy kvar) + | isTcTyVar kvar, isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> go fun_kind + Flexi -> defer (isReturnTyVar kvar) k } + + go k@(ForAllTy (Anon arg) res) + = return (mkNomReflCo k, arg, res) + + go other = defer False other + + defer is_return k + = do { arg_kind <- new_flexi + ; res_kind <- new_flexi + ; let new_fun = mkFunTy arg_kind res_kind + thing = mkTypeErrorThingArgs ty num_args_remaining + origin = TypeEqOrigin { uo_actual = k + , uo_expected = new_fun + , uo_thing = Just thing + } + ; co <- uType origin KindLevel k new_fun + ; return (co, arg_kind, res_kind) } + where + new_flexi | is_return = newReturnTyVarTy liftedTypeKind + | otherwise = newMetaKindVar diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot index 2acecd6d74..4d36bfa2d9 100644 --- a/compiler/typecheck/TcUnify.hs-boot +++ b/compiler/typecheck/TcUnify.hs-boot @@ -2,8 +2,13 @@ module TcUnify where import TcType ( TcTauType ) import TcRnTypes ( TcM ) import TcEvidence ( TcCoercion ) +import Outputable ( Outputable ) +import HsExpr ( HsExpr ) +import Name ( Name ) -- This boot file exists only to tie the knot between -- TcUnify and Inst -unifyType :: TcTauType -> TcTauType -> TcM TcCoercion +unifyType :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion +unifyKind :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion +noThing :: Maybe (HsExpr Name) diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 75da391147..4579686ab7 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -3,18 +3,19 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TupleSections, ViewPatterns #-} module TcValidity ( Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - expectedKindInCtxt, + ContextKind(..), expectedKindInCtxt, checkValidTheta, checkValidFamPats, checkValidInstance, validDerivPred, checkInstTermination, ClsInfo, checkValidCoAxiom, checkValidCoAxBranch, checkValidTyFamEqn, checkConsistentFamInst, - arityErr, badATErr + arityErr, badATErr, + checkValidTelescope, checkZonkValidTelescope, checkValidInferredKinds ) where #include "HsVersions.h" @@ -22,12 +23,12 @@ module TcValidity ( -- friends: import TcUnify ( tcSubType_NC ) import TcSimplify ( simplifyAmbiguityCheck ) -import TypeRep -import TcType +import TyCoRep +import TcType hiding ( sizeType, sizeTypes ) import TcMType -import TysWiredIn ( coercibleClass, eqTyCon ) import PrelNames import Type +import Coercion import Unify( tcMatchTyX ) import Kind import CoAxiom @@ -35,7 +36,6 @@ import Class import TyCon -- others: -import Coercion ( pprCoAxBranch ) import HsSyn -- HsType import TcRnMonad -- TcType, amongst others import FunDeps @@ -52,6 +52,8 @@ import ListSetOps import SrcLoc import Outputable import FastString +import BasicTypes +import Module import Control.Monad import Data.Maybe @@ -192,24 +194,13 @@ checkAmbiguity :: UserTypeCtxt -> Type -> TcM () checkAmbiguity ctxt ty | wantAmbiguityCheck ctxt = do { traceTc "Ambiguity check for" (ppr ty) - ; let free_tkvs = varSetElemsKvsFirst (closeOverKinds (tyVarsOfType ty)) - ; (subst, _tvs) <- tcInstSkolTyVars free_tkvs - ; let ty' = substTy subst ty - -- The type might have free TyVars, esp when the ambiguity check - -- happens during a call to checkValidType, - -- so we skolemise them as TcTyVars. - -- Tiresome; but the type inference engine expects TcTyVars - -- NB: The free tyvar might be (a::k), so k is also free - -- and we must skolemise it as well. Hence closeOverKinds. - -- (Trac #9222) - -- Solve the constraints eagerly because an ambiguous type -- can cause a cascade of further errors. Since the free -- tyvars are skolemised, we can safely use tcSimplifyTop ; allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $ - tcSubType_NC ctxt ty' ty' + tcSubType_NC ctxt ty ty ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) } @@ -330,13 +321,15 @@ checkValidType ctxt ty _ -> panic "checkValidType" -- Can't happen; not used for *user* sigs + ; env <- tcInitOpenTidyEnv (tyCoVarsOfType ty) + -- Check the internal validity of the type itself - ; check_type ctxt rank ty + ; check_type env ctxt rank ty -- Check that the thing has kind Type, and is lifted if necessary. -- Do this *after* check_type, because we can't usefully take -- the kind of an ill-formed type such as (a~Int) - ; check_kind ctxt ty + ; check_kind env ctxt ty ; checkUserTypeError ty @@ -349,42 +342,48 @@ checkValidType ctxt ty checkValidMonoType :: Type -> TcM () -- Assumes arguemt is fully zonked -checkValidMonoType ty = check_mono_type SigmaCtxt MustBeMonoType ty - +checkValidMonoType ty + = do { env <- tcInitOpenTidyEnv (tyCoVarsOfType ty) + ; check_type env SigmaCtxt MustBeMonoType ty } -check_kind :: UserTypeCtxt -> TcType -> TcM () +check_kind :: TidyEnv -> UserTypeCtxt -> TcType -> TcM () -- Check that the type's kind is acceptable for the context -check_kind ctxt ty +check_kind env ctxt ty | TySynCtxt {} <- ctxt , returnsConstraintKind actual_kind = do { ck <- xoptM Opt_ConstraintKinds ; if ck then when (isConstraintKind actual_kind) (do { dflags <- getDynFlags - ; check_pred_ty dflags ctxt ty }) - else addErrTc (constraintSynErr actual_kind) } - - | Just k <- expectedKindInCtxt ctxt - = checkTc (tcIsSubKind actual_kind k) (kindErr actual_kind) + ; check_pred_ty env dflags ctxt ty }) + else addErrTcM (constraintSynErr env actual_kind) } | otherwise - = return () -- Any kind will do + = case expectedKindInCtxt ctxt of + TheKind k -> checkTcM (tcEqType actual_kind k) (kindErr env actual_kind) + OpenKind -> checkTcM (classifiesTypeWithValues actual_kind) (kindErr env actual_kind) + AnythingKind -> return () where actual_kind = typeKind ty +-- | The kind expected in a certain context. +data ContextKind = TheKind Kind -- ^ a specific kind + | AnythingKind -- ^ any kind will do + | OpenKind -- ^ something of the form @TYPE _@ + -- Depending on the context, we might accept any kind (for instance, in a TH -- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt :: UserTypeCtxt -> Maybe Kind -expectedKindInCtxt (TySynCtxt _) = Nothing -- Any kind will do -expectedKindInCtxt ThBrackCtxt = Nothing -expectedKindInCtxt GhciCtxt = Nothing +expectedKindInCtxt :: UserTypeCtxt -> ContextKind +expectedKindInCtxt (TySynCtxt _) = AnythingKind +expectedKindInCtxt ThBrackCtxt = AnythingKind +expectedKindInCtxt GhciCtxt = AnythingKind -- The types in a 'default' decl can have varying kinds -- See Note [Extended defaults]" in TcEnv -expectedKindInCtxt DefaultDeclCtxt = Nothing -expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind -expectedKindInCtxt InstDeclCtxt = Just constraintKind -expectedKindInCtxt SpecInstCtxt = Just constraintKind -expectedKindInCtxt _ = Just openTypeKind +expectedKindInCtxt DefaultDeclCtxt = AnythingKind +expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind +expectedKindInCtxt InstDeclCtxt = TheKind constraintKind +expectedKindInCtxt SpecInstCtxt = TheKind constraintKind +expectedKindInCtxt _ = OpenKind {- Note [Higher rank types] @@ -421,65 +420,68 @@ forAllAllowed (LimitedRank forall_ok _) = forall_ok forAllAllowed _ = False ---------------------------------------- -check_mono_type :: UserTypeCtxt -> Rank - -> KindOrType -> TcM () -- No foralls anywhere - -- No unlifted types of any kind -check_mono_type ctxt rank ty - | isKind ty = return () -- IA0_NOTE: Do we need to check kinds? - | otherwise - = do { check_type ctxt rank ty - ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } +-- | Fail with error message if the type is unlifted +check_lifted :: TidyEnv -> Type -> TcM () +check_lifted env ty + = checkTcM (not (isUnLiftedType ty)) (unliftedArgErr env ty) -check_type :: UserTypeCtxt -> Rank -> Type -> TcM () +check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM () -- The args say what the *type context* requires, independent -- of *flag* settings. You test the flag settings at usage sites. -- -- Rank is allowed rank for function args -- Rank 0 means no for-alls anywhere -check_type ctxt rank ty +check_type env ctxt rank ty | not (null tvs && null theta) - = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty) + = do { checkTcM (forAllAllowed rank) (forAllTyErr env' rank ty) -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message - ; check_valid_theta SigmaCtxt theta + ; check_valid_theta env' SigmaCtxt theta -- Allow type T = ?x::Int => Int -> Int -- but not type T = ?x::Int - ; check_type ctxt rank tau } -- Allow foralls to right of arrow + ; check_type env' ctxt rank tau -- Allow foralls to right of arrow + ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType tau_kind) tvs)) + (forAllEscapeErr env' ty tau_kind) + } where (tvs, theta, tau) = tcSplitSigmaTy ty + tau_kind = typeKind tau + (env', _) = tidyTyCoVarBndrs env tvs -check_type _ _ (TyVarTy _) = return () +check_type _ _ _ (TyVarTy _) = return () -check_type ctxt rank (FunTy arg_ty res_ty) - = do { check_type ctxt arg_rank arg_ty - ; check_type ctxt res_rank res_ty } +check_type env ctxt rank (ForAllTy (Anon arg_ty) res_ty) + = do { check_type env ctxt arg_rank arg_ty + ; check_type env ctxt res_rank res_ty } where (arg_rank, res_rank) = funArgResRank rank -check_type ctxt rank (AppTy ty1 ty2) - = do { check_arg_type ctxt rank ty1 - ; check_arg_type ctxt rank ty2 } +check_type env ctxt rank (AppTy ty1 ty2) + = do { check_arg_type env ctxt rank ty1 + ; check_arg_type env ctxt rank ty2 } -check_type ctxt rank ty@(TyConApp tc tys) +check_type env ctxt rank ty@(TyConApp tc tys) | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = check_syn_tc_app ctxt rank ty tc tys - | isUnboxedTupleTyCon tc = check_ubx_tuple ctxt ty tys - | otherwise = mapM_ (check_arg_type ctxt rank) tys + = check_syn_tc_app env ctxt rank ty tc tys + | isUnboxedTupleTyCon tc = check_ubx_tuple env ctxt ty tys + | otherwise = mapM_ (check_arg_type env ctxt rank) tys + +check_type _ _ _ (LitTy {}) = return () -check_type _ _ (LitTy {}) = return () +check_type env ctxt rank (CastTy ty _) = check_type env ctxt rank ty -check_type _ _ ty = pprPanic "check_type" (ppr ty) +check_type _ _ _ ty = pprPanic "check_type" (ppr ty) ---------------------------------------- -check_syn_tc_app :: UserTypeCtxt -> Rank -> KindOrType +check_syn_tc_app :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType -> TyCon -> [KindOrType] -> TcM () -- Used for type synonyms and type synonym families, -- which must be saturated, -- but not data families, which need not be saturated -check_syn_tc_app ctxt rank ty tc tys +check_syn_tc_app env ctxt rank ty tc tys | tc_arity <= length tys -- Saturated -- Check that the synonym has enough args -- This applies equally to open and closed synonyms @@ -495,7 +497,7 @@ check_syn_tc_app ctxt rank ty tc tys else -- In the liberal case (only for closed syns), expand then check case coreView ty of - Just ty' -> check_type ctxt rank ty' + Just ty' -> check_type env ctxt rank ty' Nothing -> pprPanic "check_tau_type" (ppr ty) } | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in @@ -506,25 +508,25 @@ check_syn_tc_app ctxt rank ty tc tys = failWithTc (tyConArityErr tc tys) where tc_arity = tyConArity tc - check_arg | isTypeFamilyTyCon tc = check_arg_type ctxt rank - | otherwise = check_mono_type ctxt synArgMonoType + check_arg | isTypeFamilyTyCon tc = check_arg_type env ctxt rank + | otherwise = check_type env ctxt synArgMonoType ---------------------------------------- -check_ubx_tuple :: UserTypeCtxt -> KindOrType +check_ubx_tuple :: TidyEnv -> UserTypeCtxt -> KindOrType -> [KindOrType] -> TcM () -check_ubx_tuple ctxt ty tys +check_ubx_tuple env ctxt ty tys = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples - ; checkTc ub_tuples_allowed (ubxArgTyErr ty) + ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty) ; impred <- xoptM Opt_ImpredicativeTypes ; let rank' = if impred then ArbitraryRank else tyConArgMonoType -- c.f. check_arg_type -- However, args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty - ; mapM_ (check_type ctxt rank') tys } + ; mapM_ (check_type env ctxt rank') tys } ---------------------------------------- -check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM () +check_arg_type :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType -> TcM () -- The sort of type that can instantiate a type variable, -- or be the argument of a type constructor. -- Not an unboxed tuple, but now *can* be a forall (since impredicativity) @@ -543,9 +545,9 @@ check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM () -- But not in user code. -- Anyway, they are dealt with by a special case in check_tau_type -check_arg_type ctxt rank ty - | isKind ty = return () -- IA0_NOTE: Do we need to check a kind? - | otherwise +check_arg_type _ _ _ (CoercionTy {}) = return () + +check_arg_type env ctxt rank ty = do { impred <- xoptM Opt_ImpredicativeTypes ; let rank' = case rank of -- Predictive => must be monotype MustBeMonoType -> MustBeMonoType -- Monotype, regardless @@ -556,30 +558,39 @@ check_arg_type ctxt rank ty -- (Ord (forall a.a)) => a -> a -- and so that if it Must be a monotype, we check that it is! - ; check_type ctxt rank' ty - ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } + ; check_type env ctxt rank' ty + ; check_lifted env ty } -- NB the isUnLiftedType test also checks for -- T State# -- where there is an illegal partial application of State# (which has - -- kind * -> #); see Note [The kind invariant] in TypeRep + -- kind * -> #); see Note [The kind invariant] in TyCoRep ---------------------------------------- -forAllTyErr :: Rank -> Type -> SDoc -forAllTyErr rank ty - = vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr ty) - , suggestion ] +forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) +forAllTyErr env rank ty + = ( env + , vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr_tidy env ty) + , suggestion ] ) where suggestion = case rank of LimitedRank {} -> ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types") MonoType d -> d _ -> Outputable.empty -- Polytype is always illegal -unliftedArgErr, ubxArgTyErr :: Type -> SDoc -unliftedArgErr ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty] -ubxArgTyErr ty = sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr ty] +forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc) +forAllEscapeErr env ty tau_kind + = ( env + , hang (vcat [ text "Quantified type's kind mentions quantified type variable" + , text "(skolem escape)" ]) + 2 (vcat [ text " type:" <+> ppr_tidy env ty + , text "of kind:" <+> ppr_tidy env tau_kind ]) ) + +unliftedArgErr, ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +unliftedArgErr env ty = (env, sep [ptext (sLit "Illegal unlifted type:"), ppr_tidy env ty]) +ubxArgTyErr env ty = (env, sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr_tidy env ty]) -kindErr :: Kind -> SDoc -kindErr kind = sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr kind] +kindErr :: TidyEnv -> Kind -> (TidyEnv, SDoc) +kindErr env kind = (env, sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr_tidy env kind]) {- Note [Liberal type synonyms] @@ -633,86 +644,92 @@ applying the instance decl would show up two uses of ?x. Trac #8912. checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () -- Assumes arguemt is fully zonked checkValidTheta ctxt theta - = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta) + = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypes theta) + ; addErrCtxtM (checkThetaCtxt ctxt theta) $ + check_valid_theta env ctxt theta } ------------------------- -check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM () -check_valid_theta _ [] +check_valid_theta :: TidyEnv -> UserTypeCtxt -> [PredType] -> TcM () +check_valid_theta _ _ [] = return () -check_valid_theta ctxt theta +check_valid_theta env ctxt theta = do { dflags <- getDynFlags - ; warnTc (wopt Opt_WarnDuplicateConstraints dflags && - notNull dups) (dupPredWarn dups) + ; warnTcM (wopt Opt_WarnDuplicateConstraints dflags && + notNull dups) (dupPredWarn env dups) ; traceTc "check_valid_theta" (ppr theta) - ; mapM_ (check_pred_ty dflags ctxt) theta } + ; mapM_ (check_pred_ty env dflags ctxt) theta } where - (_,dups) = removeDups cmpPred theta + (_,dups) = removeDups cmpType theta ------------------------- -check_pred_ty :: DynFlags -> UserTypeCtxt -> PredType -> TcM () +check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -- Check the validity of a predicate in a signature -- Do not look through any type synonyms; any constraint kinded -- type synonyms have been checked at their definition site -- C.f. Trac #9838 -check_pred_ty dflags ctxt pred - = do { checkValidMonoType pred - ; check_pred_help False dflags ctxt pred } +check_pred_ty env dflags ctxt pred + = do { check_type env SigmaCtxt MustBeMonoType pred + ; check_pred_help False env dflags ctxt pred } check_pred_help :: Bool -- True <=> under a type synonym + -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -check_pred_help under_syn dflags ctxt pred +check_pred_help under_syn env dflags ctxt pred | Just pred' <- coreView pred -- Switch on under_syn when going under a -- synonym (Trac #9838, yuk) - = check_pred_help True dflags ctxt pred' + = check_pred_help True env dflags ctxt pred' | otherwise = case splitTyConApp_maybe pred of Just (tc, tys) | isTupleTyCon tc - -> check_tuple_pred under_syn dflags ctxt pred tys + -> check_tuple_pred under_syn env dflags ctxt pred tys + -- NB: this equality check must come first, because (~) is a class, + -- too. + | tc `hasKey` heqTyConKey || + tc `hasKey` eqTyConKey || + tc `hasKey` eqPrimTyConKey + -> check_eq_pred env dflags pred tc tys | Just cls <- tyConClass_maybe tc - -> check_class_pred dflags ctxt pred cls tys -- Includes Coercible - | tc `hasKey` eqTyConKey - -> check_eq_pred dflags pred tys - _ -> check_irred_pred under_syn dflags ctxt pred + -> check_class_pred env dflags ctxt pred cls tys -- Includes Coercible + _ -> check_irred_pred under_syn env dflags ctxt pred -check_eq_pred :: DynFlags -> PredType -> [TcType] -> TcM () -check_eq_pred dflags pred tys +check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM () +check_eq_pred env dflags pred tc tys = -- Equational constraints are valid in all contexts if type -- families are permitted - do { checkTc (length tys == 3) - (tyConArityErr eqTyCon tys) - ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) - (eqPredTyErr pred) } + do { checkTc (length tys == tyConArity tc) (tyConArityErr tc tys) + ; checkTcM (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) + (eqPredTyErr env pred) } -check_tuple_pred :: Bool -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () -check_tuple_pred under_syn dflags ctxt pred ts +check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM () +check_tuple_pred under_syn env dflags ctxt pred ts = do { -- See Note [ConstraintKinds in predicates] - checkTc (under_syn || xopt Opt_ConstraintKinds dflags) - (predTupleErr pred) - ; mapM_ (check_pred_help under_syn dflags ctxt) ts } + checkTcM (under_syn || xopt Opt_ConstraintKinds dflags) + (predTupleErr env pred) + ; mapM_ (check_pred_help under_syn env dflags ctxt) ts } -- This case will not normally be executed because without -- -XConstraintKinds tuple types are only kind-checked as * -check_irred_pred :: Bool -> DynFlags -> UserTypeCtxt -> PredType -> TcM () -check_irred_pred under_syn dflags ctxt pred +check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM () +check_irred_pred under_syn env dflags ctxt pred -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint -- where X is a type function = do { -- If it looks like (x t1 t2), require ConstraintKinds -- see Note [ConstraintKinds in predicates] -- But (X t1 t2) is always ok because we just require ConstraintKinds -- at the definition site (Trac #9838) - failIfTc (not under_syn && not (xopt Opt_ConstraintKinds dflags) + failIfTcM (not under_syn && not (xopt Opt_ConstraintKinds dflags) && hasTyVarHead pred) - (predIrredErr pred) + (predIrredErr env pred) -- Make sure it is OK to have an irred pred in this context -- See Note [Irreducible predicates in superclasses] - ; failIfTc (is_superclass ctxt - && not (xopt Opt_UndecidableInstances dflags) - && has_tyfun_head pred) - (predSuperClassErr pred) } + ; failIfTcM (is_superclass ctxt + && not (xopt Opt_UndecidableInstances dflags) + && has_tyfun_head pred) + (predSuperClassErr env pred) } where is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False } has_tyfun_head ty @@ -744,15 +761,15 @@ This will cause the constraint simplifier to loop because every time we canonica solved to add+canonicalise another (Foo a) constraint. -} ------------------------- -check_class_pred :: DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () -check_class_pred dflags ctxt pred cls tys +check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () +check_class_pred env dflags ctxt pred cls tys | isIPClass cls = do { check_arity - ; checkTc (okIPCtxt ctxt) (badIPPred pred) } + ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) } | otherwise = do { check_arity - ; checkTc arg_tys_ok (predTyVarErr pred) } + ; checkTcM arg_tys_ok (env, predTyVarErr (tidyType env pred)) } where check_arity = checkTc (classArity cls == length tys) (tyConArityErr (classTyCon cls) tys) @@ -761,10 +778,10 @@ check_class_pred dflags ctxt pred cls tys arg_tys_ok = case ctxt of SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) tys + InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys -- Further checks on head and theta -- in checkInstTermination - _ -> checkValidClsArgs flexible_contexts tys + _ -> checkValidClsArgs flexible_contexts cls tys ------------------------- okIPCtxt :: UserTypeCtxt -> Bool @@ -790,8 +807,10 @@ okIPCtxt (TySynCtxt {}) = False okIPCtxt (RuleSigCtxt {}) = False okIPCtxt DefaultDeclCtxt = False -badIPPred :: PredType -> SDoc -badIPPred pred = ptext (sLit "Illegal implicit parameter") <+> quotes (ppr pred) +badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) +badIPPred env pred + = ( env + , ptext (sLit "Illegal implicit parameter") <+> quotes (ppr_tidy env pred) ) {- Note [Kind polymorphic type classes] @@ -814,51 +833,63 @@ Flexibility check: generalized actually. -} -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> SDoc -checkThetaCtxt ctxt theta - = vcat [ptext (sLit "In the context:") <+> pprTheta theta, - ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] - -eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predSuperClassErr :: PredType -> SDoc -eqPredTyErr pred = vcat [ ptext (sLit "Illegal equational constraint") <+> pprType pred - , parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) ] -predTyVarErr pred = vcat [ hang (ptext (sLit "Non type-variable argument")) - 2 (ptext (sLit "in the constraint:") <+> pprType pred) - , parens (ptext (sLit "Use FlexibleContexts to permit this")) ] -predTupleErr pred = hang (ptext (sLit "Illegal tuple constraint:") <+> pprType pred) - 2 (parens constraintKindsMsg) -predIrredErr pred = hang (ptext (sLit "Illegal constraint:") <+> pprType pred) - 2 (parens constraintKindsMsg) -predSuperClassErr pred - = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred) - <+> ptext (sLit "in a superclass context")) - 2 (parens undecidableMsg) - -constraintSynErr :: Type -> SDoc -constraintSynErr kind = hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr kind)) - 2 (parens constraintKindsMsg) - -dupPredWarn :: [[PredType]] -> SDoc -dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprType (map head dups) +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) +checkThetaCtxt ctxt theta env + = return ( env + , vcat [ ptext (sLit "In the context:") <+> pprTheta (tidyTypes env theta) + , ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] ) + +eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) +eqPredTyErr env pred + = ( env + , ptext (sLit "Illegal equational constraint") <+> ppr_tidy env pred $$ + parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) ) +predTupleErr env pred + = ( env + , hang (ptext (sLit "Illegal tuple constraint:") <+> ppr_tidy env pred) + 2 (parens constraintKindsMsg) ) +predIrredErr env pred + = ( env + , hang (ptext (sLit "Illegal constraint:") <+> ppr_tidy env pred) + 2 (parens constraintKindsMsg) ) +predSuperClassErr env pred + = ( env + , hang (ptext (sLit "Illegal constraint") <+> quotes (ppr_tidy env pred) + <+> ptext (sLit "in a superclass context")) + 2 (parens undecidableMsg) ) + +predTyVarErr :: PredType -> SDoc -- type is already tidied! +predTyVarErr pred + = vcat [ hang (ptext (sLit "Non type-variable argument")) + 2 (ptext (sLit "in the constraint:") <+> ppr pred) + , parens (ptext (sLit "Use FlexibleContexts to permit this")) ] + +constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) +constraintSynErr env kind + = ( env + , hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr_tidy env kind)) + 2 (parens constraintKindsMsg) ) + +dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc) +dupPredWarn env dups + = ( env + , ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas (ppr_tidy env) (map head dups) ) tyConArityErr :: TyCon -> [TcType] -> SDoc -- For type-constructor arity errors, be careful to report --- the number of /type/ arguments required and supplied, --- ignoring the /kind/ arguments, which the user does not see. +-- the number of /visible/ arguments required and supplied, +-- ignoring the /invisible/ arguments, which the user does not see. -- (e.g. Trac #10516) tyConArityErr tc tks = arityErr (tyConFlavour tc) (tyConName tc) tc_type_arity tc_type_args where - tvs = tyConTyVars tc - - kbs :: [Bool] -- True for a Type arg, false for a Kind arg - kbs = map isTypeVar tvs + vis_tks = filterOutInvisibleTypes tc tks -- tc_type_arity = number of *type* args expected -- tc_type_args = number of *type* args encountered - tc_type_arity = count id kbs - tc_type_args = count (id . fst) (kbs `zip` tks) + tc_type_arity = count isVisibleBinder $ fst $ splitPiTys (tyConKind tc) + tc_type_args = length vis_tks arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr what name n m @@ -891,12 +922,14 @@ checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () checkValidInstHead ctxt clas cls_args = do { dflags <- getDynFlags - ; checkTc (clas `notElem` abstractClasses) + ; mod <- getModule + ; checkTc (getUnique clas `notElem` abstractClassKeys || + nameModule (getName clas) == mod) (instTypeErr clas cls_args abstract_class_msg) -- Check language restrictions; -- but not for SPECIALISE isntance pragmas - ; let ty_args = dropWhile isKind cls_args + ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args ; unless spec_inst_prag $ do { checkTc (xopt Opt_TypeSynonymInstances dflags || all tcInstHeadTyNotSynonym ty_args) @@ -919,6 +952,11 @@ checkValidInstHead ctxt clas cls_args -- E.g. instance C (forall a. a->a) is rejected -- One could imagine generalising that, but I'm not sure -- what all the consequences might be + + -- We can't have unlifted type arguments. + -- check_arg_type is redundant with checkValidMonoType + ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypes ty_args) + ; mapM_ (check_lifted env) ty_args } where @@ -940,10 +978,13 @@ checkValidInstHead ctxt clas cls_args text "Use MultiParamTypeClasses if you want to allow more, or zero.") abstract_class_msg = - text "The class is abstract, manual instances are not permitted." + text "Manual instances of this class are not permitted." -abstractClasses :: [ Class ] -abstractClasses = [ coercibleClass ] -- See Note [Coercible Instances] +abstractClassKeys :: [Unique] +abstractClassKeys = [ heqTyConKey + , eqTyConKey + , coercibleTyConKey + ] -- See Note [Equality class instances] instTypeErr :: Class -> [Type] -> SDoc -> SDoc instTypeErr cls tys msg @@ -974,21 +1015,32 @@ It checks for three things problems; in particular, it's hard to compare solutions for equality when finding the fixpoint, and that means the inferContext loop does not converge. See Trac #5287. + +Note [Equality class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't have users writing instances for the equality classes. But we +still need to be able to write instances for them ourselves. So we allow +instances only in the defining module. + -} validDerivPred :: TyVarSet -> PredType -> Bool -- See Note [Valid 'deriving' predicate] validDerivPred tv_set pred = case classifyPredType pred of - ClassPred _ tys -> check_tys tys + ClassPred cls _ -> cls `hasKey` typeableClassKey + -- Typeable constraints are bigger than they appear due + -- to kind polymorphism, but that's OK + || check_tys EqPred {} -> False -- reject equality constraints _ -> True -- Non-class predicates are ok where - check_tys tys = hasNoDups fvs - && sizeTypes tys == fromIntegral (length fvs) - && all (`elemVarSet` tv_set) fvs - where - fvs = fvTypes tys + check_tys = hasNoDups fvs + -- use sizePred to ignore implicit args + && sizePred pred == fromIntegral (length fvs) + && all (`elemVarSet` tv_set) fvs + + fvs = fvType pred {- ************************************************************************ @@ -1074,14 +1126,15 @@ checkInstTermination tys theta EqPred {} -> return () -- See Trac #4200. IrredPred {} -> check2 pred (sizeType pred) ClassPred cls tys - | isIPClass cls - -> return () -- You can't get to class predicates from implicit params + | isTerminatingClass cls + -> return () | isCTupleClass cls -- Look inside tuple predicates; Trac #8359 -> check_preds tys | otherwise - -> check2 pred (sizeTypes tys) -- Other ClassPreds + -> check2 pred (sizeTypes $ filterOutInvisibleTypes (classTyCon cls) tys) + -- Other ClassPreds check2 pred pred_size | not (null bad_tvs) = addErrTc (noMoreMsg bad_tvs what) @@ -1205,12 +1258,12 @@ checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys -- See Note [Checking consistent instantiation] in TcTyClsDecls -- Check right to left, so that we spot type variable -- inconsistencies before (more confusing) kind variables - ; discardResult $ foldrM check_arg emptyTvSubst $ + ; discardResult $ foldrM check_arg emptyTCvSubst $ tyConTyVars fam_tc `zip` at_tys } where at_tv_set = mkVarSet at_tvs - check_arg :: (TyVar, Type) -> TvSubst -> TcM TvSubst + check_arg :: (TyVar, Type) -> TCvSubst -> TcM TCvSubst check_arg (fam_tc_tv, at_ty) subst | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv = case tcMatchTyX at_tv_set subst at_ty inst_ty of @@ -1222,7 +1275,7 @@ checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys = return subst -- Allow non-type-variable instantiation -- See Note [Associated type instances] - all_distinct :: TvSubst -> Bool + all_distinct :: TCvSubst -> Bool -- True if all the variables mapped the substitution -- map to *distinct* type *variables* all_distinct subst = go [] at_tvs @@ -1313,9 +1366,10 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) checkValidCoAxBranch :: Maybe ClsInfo -> TyCon -> CoAxBranch -> TcM () checkValidCoAxBranch mb_clsinfo fam_tc - (CoAxBranch { cab_tvs = tvs, cab_lhs = typats + (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = typats , cab_rhs = rhs, cab_loc = loc }) - = checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc + = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc -- | Do validity checks on a type family equation, including consistency -- with any enclosing class instance head, termination, and lack of @@ -1323,13 +1377,14 @@ checkValidCoAxBranch mb_clsinfo fam_tc checkValidTyFamEqn :: Maybe ClsInfo -> TyCon -- ^ of the type family -> [TyVar] -- ^ bound tyvars in the equation + -> [CoVar] -- ^ bound covars in the equation -> [Type] -- ^ type patterns -> Type -- ^ rhs -> SrcSpan -> TcM () -checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc +checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc = setSrcSpan loc $ - do { checkValidFamPats fam_tc tvs typats + do { checkValidFamPats fam_tc tvs cvs typats -- The argument patterns, and RHS, are all boxed tau types -- E.g Reject type family F (a :: k1) :: k2 @@ -1338,8 +1393,11 @@ checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc -- type instance F Int = forall a. a->a -- type instance F Int = Int# -- See Trac #9357 + ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypes (rhs : typats)) ; mapM_ checkValidMonoType typats + ; mapM_ (check_lifted env) typats ; checkValidMonoType rhs + ; check_lifted env rhs -- We have a decidable instance unless otherwise permitted ; undecidable_ok <- xoptM Opt_UndecidableInstances @@ -1371,7 +1429,7 @@ checkFamInstRhs lhsTys famInsts what = ptext (sLit "type family application") <+> quotes (pprType (TyConApp tc tys)) bad_tvs = fvTypes tys \\ fvs -checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM () +checkValidFamPats :: TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM () -- Patterns in a 'type instance' or 'data instance' decl should -- a) contain no type family applications -- (vanilla synonyms are fine, though) @@ -1380,18 +1438,26 @@ checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM () -- type T a = Int -- type instance F (T a) = a -- c) Have the right number of patterns -checkValidFamPats fam_tc tvs ty_pats - = ASSERT2( length ty_pats == tyConArity fam_tc - , ppr ty_pats $$ ppr fam_tc $$ ppr (tyConArity fam_tc) ) - -- A family instance must have exactly the same number of type - -- parameters as the family declaration. You can't write - -- type family F a :: * -> * - -- type instance F Int y = y - -- because then the type (F Int) would be like (\y.y) - -- But this is checked at the time the axiom is created - do { mapM_ checkTyFamFreeness ty_pats - ; let unbound_tvs = filterOut (`elemVarSet` exactTyVarsOfTypes ty_pats) tvs - ; checkTc (null unbound_tvs) (famPatErr fam_tc unbound_tvs ty_pats) } +checkValidFamPats fam_tc tvs cvs ty_pats + = do { -- A family instance must have exactly the same number of type + -- parameters as the family declaration. You can't write + -- type family F a :: * -> * + -- type instance F Int y = y + -- because then the type (F Int) would be like (\y.y) + checkTc (length ty_pats == fam_arity) $ + wrongNumberOfParmsErr (fam_arity - count isInvisibleBinder fam_bndrs) + -- report only explicit arguments + + ; mapM_ checkTyFamFreeness ty_pats + ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes ty_pats) (tvs ++ cvs) + ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs ty_pats) } + where fam_arity = tyConArity fam_tc + fam_bndrs = take fam_arity $ fst $ splitPiTys (tyConKind fam_tc) + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr exp_arity + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr exp_arity -- Ensure that no type family instances occur in a type. checkTyFamFreeness :: Type -> TcM () @@ -1432,28 +1498,220 @@ famPatErr fam_tc tvs pats {- ************************************************************************ * * + Telescope checking +* * +************************************************************************ + +Note [Bad telescopes] +~~~~~~~~~~~~~~~~~~~~~ +Now that we can mix type and kind variables, there are an awful lot of +ways to shoot yourself in the foot. Here are some. + + data SameKind :: k -> k -> * -- just to force unification + +1. data T1 a k (b :: k) (x :: SameKind a b) + +The problem here is that we discover that a and b should have the same +kind. But this kind mentions k, which is bound *after* a. +(Testcase: dependent/should_fail/BadTelescope) + +2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +Note that b is not bound. Yet its kind mentions a. Because we have +a nice rule that all implicitly bound variables come before others, +this is bogus. (We could probably figure out to put b between a and c. +But I think this is doing users a disservice, in the long run.) +(Testcase: dependent/should_fail/BadTelescope4) + +3. t3 :: forall a. (forall k (b :: k). SameKind a b) -> () + +This is a straightforward skolem escape. Note that a and b need to have +the same kind. +(Testcase: polykinds/T11142) + +How do we deal with all of this? For TyCons, we have checkValidTyConTyVars. +That function looks to see if any of the tyConTyVars are repeated, but +it's really a telescope check. It works because all tycons are kind-generalized. +If there is a bad telescope, the kind-generalization will end up generalizing +over a variable bound later in the telescope. + +For non-tycons, we do scope checking when we bring tyvars into scope, +in tcImplicitTKBndrs and tcHsTyVarBndrs. Note that we also have to +sort implicit binders into a well-scoped order whenever we have implicit +binders to worry about. This is done in quantifyTyVars and in +tcImplicitTKBndrs. +-} + +-- | Check a list of binders to see if they make a valid telescope. +-- The key property we're checking for is scoping. For example: +-- > data SameKind :: k -> k -> * +-- > data X a k (b :: k) (c :: SameKind a b) +-- Kind inference says that a's kind should be k. But that's impossible, +-- because k isn't in scope when a is bound. This check has to come before +-- general validity checking, because once we kind-generalise, this sort +-- of problem is harder to spot (as we'll generalise over the unbound +-- k in a's type.) See also Note [Bad telescopes]. +checkValidTelescope :: SDoc -- the original user-written telescope + -> [TyVar] -- explicit vars (not necessarily zonked) + -> SDoc -- note to put at bottom of message + -> TcM () -- returns zonked tyvars +checkValidTelescope hs_tvs orig_tvs extra + = discardResult $ checkZonkValidTelescope hs_tvs orig_tvs extra + +-- | Like 'checkZonkValidTelescope', but returns the zonked tyvars +checkZonkValidTelescope :: SDoc + -> [TyVar] + -> SDoc + -> TcM [TyVar] +checkZonkValidTelescope hs_tvs orig_tvs extra + = do { orig_tvs <- mapM zonkTyCoVarKind orig_tvs + ; let (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $ + toposortTyVars orig_tvs + ; unless (go [] emptyVarSet orig_tvs) $ + addErr $ + vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$ + text "are out of dependency order. Perhaps try this ordering:") + 2 (sep (map pprTvBndr sorted_tidied_tvs)) + , extra ] + ; return orig_tvs } + + where + go :: [TyVar] -- misplaced variables + -> TyVarSet -> [TyVar] -> Bool + go errs in_scope [] = null (filter (`elemVarSet` in_scope) errs) + -- report an error only when the variable in the kind is brought + -- into scope later in the telescope. Otherwise, we'll just quantify + -- over it in kindGeneralize, as we should. + + go errs in_scope (tv:tvs) + = let bad_tvs = tyCoVarsOfType (tyVarKind tv) `minusVarSet` in_scope in + go (varSetElems bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs + +-- | After inferring kinds of type variables, check to make sure that the +-- inferred kinds any of the type variables bound in a smaller scope. +-- This is a skolem escape check. See also Note [Bad telescopes]. +checkValidInferredKinds :: [TyVar] -- ^ vars to check (zonked) + -> TyVarSet -- ^ vars out of scope + -> SDoc -- ^ suffix to error message + -> TcM () +checkValidInferredKinds orig_kvs out_of_scope extra + = do { let bad_pairs = [ (tv, kv) + | kv <- orig_kvs + , Just tv <- map (lookupVarSet out_of_scope) + (tyCoVarsOfTypeList (tyVarKind kv)) ] + report (tidyTyVarOcc env -> tv, tidyTyVarOcc env -> kv) + = addErr $ + text "The kind of variable" <+> + quotes (ppr kv) <> text ", namely" <+> + quotes (ppr (tyVarKind kv)) <> comma $$ + text "depends on variable" <+> + quotes (ppr tv) <+> text "from an inner scope" $$ + text "Perhaps bind" <+> quotes (ppr kv) <+> + text "sometime after binding" <+> + quotes (ppr tv) $$ + extra + ; mapM_ report bad_pairs } + + where + (env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs + (env, _) = tidyTyCoVarBndrs env1 (varSetElems out_of_scope) + +{- +************************************************************************ +* * \subsection{Auxiliary functions} * * ************************************************************************ -} -- Free variables of a type, retaining repetitions, and expanding synonyms --- Ignore kinds altogether: rightly or wrongly, we only check for --- excessive occurrences of *type* variables. --- e.g. type instance Demote {T k} a = T (Demote {k} (Any {k})) --- --- c.f. sizeType, which is often called side by side with fvType -fvType, fv_type :: Type -> [TyVar] -fvType ty | isKind ty = [] - | otherwise = fv_type ty - -fv_type ty | Just exp_ty <- coreView ty = fv_type exp_ty -fv_type (TyVarTy tv) = [tv] -fv_type (TyConApp _ tys) = fvTypes tys -fv_type (LitTy {}) = [] -fv_type (FunTy arg res) = fv_type arg ++ fv_type res -fv_type (AppTy fun arg) = fv_type fun ++ fv_type arg -fv_type (ForAllTy tyvar ty) = filter (/= tyvar) (fv_type ty) +fvType :: Type -> [TyCoVar] +fvType ty | Just exp_ty <- coreView ty = fvType exp_ty +fvType (TyVarTy tv) = [tv] +fvType (TyConApp _ tys) = fvTypes tys +fvType (LitTy {}) = [] +fvType (AppTy fun arg) = fvType fun ++ fvType arg +fvType (ForAllTy bndr ty) + = fvType (binderType bndr) ++ + caseBinder bndr (\tv -> filter (/= tv)) (const id) (fvType ty) +fvType (CastTy ty co) = fvType ty ++ fvCo co +fvType (CoercionTy co) = fvCo co fvTypes :: [Type] -> [TyVar] -fvTypes tys = concat (map fvType tys) +fvTypes tys = concat (map fvType tys) + +fvCo :: Coercion -> [TyCoVar] +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 (CoVarCo v) = [v] +fvCo (AxiomInstCo _ _ args) = concatMap fvCo args +fvCo (UnivCo p _ t1 t2) = fvProv p ++ fvType t1 ++ fvType t2 +fvCo (SymCo co) = fvCo co +fvCo (TransCo co1 co2) = fvCo co1 ++ fvCo co2 +fvCo (NthCo _ co) = fvCo co +fvCo (LRCo _ co) = fvCo co +fvCo (InstCo co arg) = fvCo co ++ fvCo arg +fvCo (CoherenceCo co1 co2) = fvCo co1 ++ fvCo co2 +fvCo (KindCo co) = fvCo co +fvCo (SubCo co) = fvCo co +fvCo (AxiomRuleCo _ cs) = concatMap fvCo cs + +fvProv :: UnivCoProvenance -> [TyCoVar] +fvProv UnsafeCoerceProv = [] +fvProv (PhantomProv co) = fvCo co +fvProv (ProofIrrelProv co) = fvCo co +fvProv (PluginProv _) = [] +fvProv (HoleProv h) = pprPanic "fvProv falls into a hole" (ppr h) + +sizeType :: Type -> Int +-- Size of a type: the number of variables and constructors +sizeType ty | Just exp_ty <- coreView ty = sizeType exp_ty +sizeType (TyVarTy {}) = 1 +sizeType (TyConApp _ tys) = sizeTypes tys + 1 +sizeType (LitTy {}) = 1 +sizeType (AppTy fun arg) = sizeType fun + sizeType arg +sizeType (ForAllTy (Anon arg) res) + = sizeType arg + sizeType res + 1 +sizeType (ForAllTy (Named {}) ty) + = sizeType ty +sizeType (CastTy ty _) = sizeType ty +sizeType (CoercionTy _) = 1 + +sizeTypes :: [Type] -> Int +sizeTypes = sum . map sizeType + +-- Size of a predicate +-- +-- We are considering whether class constraints terminate. +-- Equality constraints and constraints for the implicit +-- parameter class always termiante so it is safe to say "size 0". +-- (Implicit parameter constraints always terminate because +-- there are no instances for them---they are only solved by +-- "local instances" in expressions). +-- See Trac #4200. +sizePred :: PredType -> Int +sizePred ty = goClass ty + where + goClass p = go (classifyPredType p) + + go (ClassPred cls tys') + | isTerminatingClass cls = 0 + | otherwise = sizeTypes tys' + go (EqPred {}) = 0 + go (IrredPred ty) = sizeType ty + +-- | When this says "True", ignore this class constraint during +-- a termination check +isTerminatingClass :: Class -> Bool +isTerminatingClass cls + = isIPClass cls + || cls `hasKey` typeableClassKey + || cls `hasKey` coercibleTyConKey + || cls `hasKey` eqTyConKey + || cls `hasKey` heqTyConKey + +-- | Tidy before printing a type +ppr_tidy :: TidyEnv -> Type -> SDoc +ppr_tidy env ty = pprType (tidyType env ty) diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs index a1d5a400dd..bb7cdaf124 100644 --- a/compiler/types/Class.hs +++ b/compiler/types/Class.hs @@ -17,19 +17,22 @@ module Class ( mkClass, classTyVars, classArity, classKey, className, classATs, classATItems, classTyCon, classMethods, classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, - classAllSelIds, classSCSelId, classMinimalDef, classHasFds + classAllSelIds, classSCSelId, classMinimalDef, classHasFds, + naturallyCoherentClass ) where #include "HsVersions.h" import {-# SOURCE #-} TyCon ( TyCon, tyConName, tyConUnique ) -import {-# SOURCE #-} TypeRep ( Type, PredType ) +import {-# SOURCE #-} TyCoRep ( Type, PredType ) import Var import Name import BasicTypes import Unique import Util import SrcLoc +import PrelNames ( eqTyConKey, coercibleTyConKey, typeableClassKey, + heqTyConKey ) import Outputable import FastString import BooleanFormula (BooleanFormula) @@ -51,7 +54,7 @@ data Class = Class { classTyCon :: TyCon, -- The data type constructor for -- dictionaries of this class - -- See Note [ATyCon for classes] in TypeRep + -- See Note [ATyCon for classes] in TyCoRep className :: Name, -- Just the cached name of the TyCon classKey :: Unique, -- Cached unique of TyCon @@ -59,7 +62,7 @@ data Class classTyVars :: [TyVar], -- The class kind and type variables; -- identical to those of the TyCon - classFunDeps :: [FunDep TyVar], -- The functional dependencies + classFunDeps :: [FunDep TyVar], -- The functional dependencies -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) -- We need value-level selectors for both the dictionary @@ -255,6 +258,15 @@ classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, classATStuff = ats, classOpStuff = op_stuff}) = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) +-- | If a class is "naturally coherent", then we needn't worry at all, in any +-- way, about overlapping/incoherent instances. Just solve the thing! +naturallyCoherentClass :: Class -> Bool +naturallyCoherentClass cls + = cls `hasKey` heqTyConKey || + cls `hasKey` eqTyConKey || + cls `hasKey` coercibleTyConKey || + cls `hasKey` typeableClassKey + {- ************************************************************************ * * diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs index 5b049a40f9..01c6502f5e 100644 --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -18,7 +18,8 @@ module CoAxiom ( coAxiomName, coAxiomArity, coAxiomBranches, coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, - coAxiomSingleBranch, coAxBranchTyVars, coAxBranchRoles, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, + coAxBranchRoles, coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, placeHolderIncomps, @@ -28,7 +29,7 @@ module CoAxiom ( BuiltInSynFamily(..), trivialBuiltInFamily ) where -import {-# SOURCE #-} TypeRep ( Type ) +import {-# SOURCE #-} TyCoRep ( Type ) import {-# SOURCE #-} TyCon ( TyCon ) import Outputable import FastString @@ -64,9 +65,9 @@ type family F a where This will give rise to this axiom: -axF :: { F [Int] ~ Bool - ; forall (a :: *). F [a] ~ Double - ; forall (k :: BOX) (a :: k -> *) (b :: k). F (a b) ~ Char +axF :: { F [Int] ~ Bool + ; forall (a :: *). F [a] ~ Double + ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char } The axiom is used with the AxiomInstCo constructor of Coercion. If we wish @@ -222,6 +223,10 @@ data CoAxBranch -- See Note [CoAxiom locations] , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh -- See Note [CoAxBranch type variables] + , cab_cvs :: [CoVar] -- Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in TcTyClsDecls , cab_roles :: [Role] -- See Note [CoAxBranch roles] , cab_lhs :: [Type] -- Type patterns to match against , cab_rhs :: Type -- Right-hand side of the equality @@ -247,7 +252,9 @@ coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index coAxiomArity :: CoAxiom br -> BranchIndex -> Arity coAxiomArity ax index - = length $ cab_tvs $ coAxiomNthBranch ax index + = length tvs + length cvs + where + CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index coAxiomName :: CoAxiom br -> Name coAxiomName = co_ax_name @@ -275,6 +282,9 @@ coAxiomTyCon = co_ax_tc coAxBranchTyVars :: CoAxBranch -> [TyVar] coAxBranchTyVars = cab_tvs +coAxBranchCoVars :: CoAxBranch -> [CoVar] +coAxBranchCoVars = cab_cvs + coAxBranchLHS :: CoAxBranch -> [Type] coAxBranchLHS = cab_lhs @@ -395,6 +405,13 @@ instance Typeable br => Data.Data (CoAxiom br) where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "CoAxiom" +instance Outputable CoAxBranch where + ppr (CoAxBranch { cab_loc = loc + , cab_lhs = lhs + , cab_rhs = rhs }) = + text "CoAxBranch" <+> parens (ppr loc) <> colon <+> ppr lhs <+> + text "=>" <+> ppr rhs + {- ************************************************************************ * * @@ -408,7 +425,7 @@ Roles are defined here to avoid circular dependencies. -- See Note [Roles] in Coercion -- defined here to avoid cyclic dependency with Coercion data Role = Nominal | Representational | Phantom - deriving (Eq, Data.Data, Data.Typeable) + deriving (Eq, Ord, Data.Data, Data.Typeable) -- These names are slurped into the parser code. Changing these strings -- will change the **surface syntax** that GHC accepts! If you want to @@ -457,10 +474,9 @@ type Eqn = Pair Type -- | For now, we work only with nominal equality. data CoAxiomRule = CoAxiomRule { coaxrName :: FastString - , coaxrTypeArity :: Int -- number of type argumentInts , coaxrAsmpRoles :: [Role] -- roles of parameter equations , coaxrRole :: Role -- role of resulting equation - , coaxrProves :: [Type] -> [Eqn] -> Maybe Eqn + , coaxrProves :: [Eqn] -> Maybe Eqn -- ^ coaxrProves returns @Nothing@ when it doesn't like -- the supplied arguments. When this happens in a coercion -- that means that the coercion is ill-formed, and Core Lint diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index 9aff2c4407..277936960f 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -1,6 +1,8 @@ --- (c) The University of Glasgow 2006 +{- +(c) The University of Glasgow 2006 +-} -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes, CPP, DeriveDataTypeable, MultiWayIf #-} -- | Module for (a) type kinds and (b) type coercions, -- as used in System FC. See 'CoreSyn.Expr' for @@ -8,27 +10,36 @@ -- module Coercion ( -- * Main data type - Coercion(..), CoercionN, CoercionR, - Var, CoVar, - LeftOrRight(..), pickLR, + Coercion, CoercionN, CoercionR, CoercionP, + UnivCoProvenance, CoercionHole, LeftOrRight(..), + Var, CoVar, TyCoVar, Role(..), ltRole, -- ** Functions over coercions - coVarKind, coVarRole, - coercionType, coercionKind, coercionKinds, isReflCo, - isReflCo_maybe, coercionRole, coercionKindRole, + coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, + coercionType, coercionKind, coercionKinds, mkCoercionType, + coercionRole, coercionKindRole, -- ** Constructing coercions - mkReflCo, mkCoVarCo, - mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstLHS, mkAxInstRHS, - mkUnbranchedAxInstRHS, + mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkNthCo, mkNthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCoFlexible, mkTyConAppCo, mkFunCo, - mkForAllCo, mkUnsafeCo, mkUnivCo, mkSubCo, mkPhantomCo, - mkNewTypeCo, downgradeRole, - mkAxiomRuleCo, + mkSymCo, mkTransCo, mkTransAppCo, + mkNthCo, mkNthCoRole, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunCos, + mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl, + mkPhantomCo, mkHomoPhantomCo, toPhantomCo, + mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, + mkNewTypeCo, mkAxiomInstCo, mkProofIrrelCo, + downgradeRole, maybeSubCo, mkAxiomRuleCo, + mkCoherenceCo, mkCoherenceRightCo, mkCoherenceLeftCo, + mkKindCo, castCoercionKind, + + mkHeteroCoercionType, -- ** Decomposition instNewTyCon_maybe, @@ -38,506 +49,109 @@ module Coercion ( topNormaliseNewType_maybe, topNormaliseTypeX_maybe, decomposeCo, getCoVar_maybe, + splitTyConAppCo_maybe, splitAppCo_maybe, splitForAllCo_maybe, - nthRole, tyConRolesX, - setNominalRole_maybe, + + nthRole, tyConRolesX, setNominalRole_maybe, + + pickLR, + + isReflCo, isReflCo_maybe, -- ** Coercion variables - mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique, + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + isCoVar_maybe, -- ** Free variables - tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize, - tyCoVarsOfCoAcc, tyCoVarsOfCosAcc, + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoVarsOfCoAcc, tyCoVarsOfCosAcc, tyCoVarsOfCoDSet, + coercionSize, -- ** Substitution CvSubstEnv, emptyCvSubstEnv, - CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar, - isEmptyCvSubst, zapCvSubstEnv, getCvInScope, - substCo, substCos, substCoVar, substCoVars, - substCoWithTy, substCoWithTys, - cvTvSubst, tvCvSubst, mkCvSubst, zipOpenCvSubst, - substTy, extendTvSubst, - extendCvSubstAndInScope, extendTvSubstAndInScope, - substTyVarBndr, substCoVarBndr, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTCvSubstAndInScope, getCvSubstEnv, -- ** Lifting - liftCoMatch, liftCoSubstTyVar, liftCoSubstWith, + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, + liftCoSubstVarBndrCallback, isMappedByLC, + + mkSubstLiftingContext, zapLiftingContext, + substForAllCoBndrCallbackLC, lcTCvSubst, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, -- ** Comparison - coreEqCoercion, coreEqCoercion2, + eqCoercion, eqCoercionX, -- ** Forcing evaluation of coercions seqCo, -- * Pretty-printing - pprCo, pprParendCo, + pprCo, pprParendCo, pprCoBndr, pprCoAxiom, pprCoAxBranch, pprCoAxBranchHdr, -- * Tidying tidyCo, tidyCos, -- * Other - applyCo, + promoteCoercion ) where #include "HsVersions.h" -import Unify ( MatchEnv(..), matchList ) -import TypeRep -import qualified Type -import Type hiding( substTy, substTyVarBndr, extendTvSubst ) +import TyCoRep +import Type import TyCon import CoAxiom import Var import VarEnv -import VarSet -import Binary -import Maybes ( orElse ) -import Name ( Name, NamedThing(..), nameUnique, nameModule, getSrcSpan ) -import OccName ( parenSymOcc ) +import Name hiding ( varName ) import Util import BasicTypes import Outputable import Unique import Pair import SrcLoc -import PrelNames ( funTyConKey, eqPrimTyConKey, eqReprPrimTyConKey ) +import PrelNames +import TysPrim ( eqPhantPrimTyCon ) +import ListSetOps +import Maybes + #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding ( empty ) +import Prelude hiding ( and ) import Data.Traversable (traverse, sequenceA) +import Data.Foldable ( and ) #endif +import Control.Monad (foldM) import FastString -import ListSetOps -import FV - -import qualified Data.Data as Data hiding ( TyCon ) import Control.Arrow ( first ) +import Data.Function ( on ) -{- -************************************************************************ -* * - Coercions -* * -************************************************************************ --} +----------------------------------------------------------------- +-- These synonyms are very useful as documentation -type CoercionR = Coercion -- A coercion at Representation role ~R -type CoercionN = Coercion -- A coercion at Nominal role ~N - --- | A 'Coercion' is concrete evidence of the equality/convertibility --- of two types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Coercion - -- Each constructor has a "role signature", indicating the way roles are - -- propagated through coercions. P, N, and R stand for coercions of the - -- given role. e stands for a coercion of a specific unknown role (think - -- "role polymorphism"). "e" stands for an explicit role parameter - -- indicating role e. _ stands for a parameter that is not a Role or - -- Coercion. - - -- These ones mirror the shape of types - = -- Refl :: "e" -> _ -> e - Refl Role Type -- See Note [Refl invariant] - -- Invariant: applications of (Refl T) to a bunch of identity coercions - -- always show up as Refl. - -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). - - -- Applications of (Refl T) to some coercions, at least one of - -- which is NOT the identity, show up as TyConAppCo. - -- (They may not be fully saturated however.) - -- ConAppCo coercions (like all coercions other than Refl) - -- are NEVER the identity. - - -- Use (Refl Representational _), not (SubCo (Refl Nominal _)) - - -- These ones simply lift the correspondingly-named - -- Type constructors into Coercions - - -- TyConAppCo :: "e" -> _ -> ?? -> e - -- See Note [TyConAppCo roles] - | TyConAppCo Role TyCon [Coercion] -- lift TyConApp - -- The TyCon is never a synonym; - -- we expand synonyms eagerly - -- But it can be a type function - - | AppCo Coercion Coercion -- lift AppTy - -- AppCo :: e -> N -> e - - -- See Note [Forall coercions] - | ForAllCo TyVar Coercion -- forall a. g - -- :: _ -> e -> e - - -- These are special - | CoVarCo CoVar -- :: _ -> (N or R) - -- result role depends on the tycon of the variable's type - - -- AxiomInstCo :: e -> _ -> [N] -> e - | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] - -- See also [CoAxiom index] +type CoercionN = Coercion -- nominal coercion +type CoercionR = Coercion -- representational coercion +type CoercionP = Coercion -- phantom coercion + +{- +%************************************************************************ +%* * -- The coercion arguments always *precisely* saturate -- arity of (that branch of) the CoAxiom. If there are -- any left over, we use AppCo. See -- See [Coercion axioms applied to coercions] - -- see Note [UnivCo] - | UnivCo FastString Role Type Type -- :: "e" -> _ -> _ -> e - -- the FastString is just a note for provenance - | SymCo Coercion -- :: e -> e - | TransCo Coercion Coercion -- :: e -> e -> e - - -- The number of types and coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - | AxiomRuleCo CoAxiomRule [Type] [Coercion] - - -- These are destructors - - | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- and (F t0 ... tn), assuming F is injective. - -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- See Note [NthCo and newtypes] - - | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) - -- :: _ -> N -> N - | InstCo Coercion Type - -- :: e -> _ -> e - - | SubCo Coercion -- Turns a ~N into a ~R - -- :: N -> R - deriving (Data.Data, Data.Typeable) - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data LeftOrRight = CLeft | CRight - deriving( Eq, Data.Data, Data.Typeable ) - -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -pickLR :: LeftOrRight -> (a,a) -> a -pickLR CLeft (l,_) = l -pickLR CRight (_,r) = r - -{- -Note [Refl invariant] -~~~~~~~~~~~~~~~~~~~~~ -Coercions have the following invariant - Refl is always lifted as far as possible. - -You might think that a consequencs is: - Every identity coercions has Refl at the root - -But that's not quite true because of coercion variables. Consider - g where g :: Int~Int - Left h where h :: Maybe Int ~ Maybe Int -etc. So the consequence is only true of coercions that -have no coercion variables. - -Note [Coercion axioms applied to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The reason coercion axioms can be applied to coercions and not just -types is to allow for better optimization. There are some cases where -we need to be able to "push transitivity inside" an axiom in order to -expose further opportunities for optimization. - -For example, suppose we have - - C a : t[a] ~ F a - g : b ~ c - -and we want to optimize - - sym (C b) ; t[g] ; C c - -which has the kind - - F b ~ F c - -(stopping through t[b] and t[c] along the way). - -We'd like to optimize this to just F g -- but how? The key is -that we need to allow axioms to be instantiated by *coercions*, -not just by types. Then we can (in certain cases) push -transitivity inside the axiom instantiations, and then react -opposite-polarity instantiations of the same axiom. In this -case, e.g., we match t[g] against the LHS of (C c)'s kind, to -obtain the substitution a |-> g (note this operation is sort -of the dual of lifting!) and hence end up with - - C g : t[b] ~ F c - -which indeed has the same kind as t[g] ; C c. - -Now we have - - sym (C b) ; C g - -which can be optimized to F g. - -Note [CoAxiom index] -~~~~~~~~~~~~~~~~~~~~ -A CoAxiom has 1 or more branches. Each branch has contains a list -of the free type variables in that branch, the LHS type patterns, -and the RHS type for that branch. When we apply an axiom to a list -of coercions, we must choose which branch of the axiom we wish to -use, as the different branches may have different numbers of free -type variables. (The number of type patterns is always the same -among branches, but that doesn't quite concern us here.) - -The Int in the AxiomInstCo constructor is the 0-indexed number -of the chosen branch. - -Note [Forall coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -Constructing coercions between forall-types can be a bit tricky. -Currently, the situation is as follows: - - ForAllCo TyVar Coercion - -represents a coercion between polymorphic types, with the rule - - v : k g : t1 ~ t2 - ---------------------------------------------- - ForAllCo v g : (all v:k . t1) ~ (all v:k . t2) - -Note that it's only necessary to coerce between polymorphic types -where the type variables have identical kinds, because equality on -kinds is trivial. - -Note [Predicate coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: a~b -How can we coerce between types - ([c]~a) => [a] -> c -and - ([c]~b) => [b] -> c -where the equality predicate *itself* differs? - -Answer: we simply treat (~) as an ordinary type constructor, so these -types really look like - - ((~) [c] a) -> [a] -> c - ((~) [c] b) -> [b] -> c - -So the coercion between the two is obviously - - ((~) [c] g) -> [g] -> c - -Another way to see this to say that we simply collapse predicates to -their representation type (see Type.coreView and Type.predTypeRep). - -This collapse is done by mkPredCo; there is no PredCo constructor -in Coercion. This is important because we need Nth to work on -predicates too: - Nth 1 ((~) [c] g) = g -See Simplify.simplCoercionF, which generates such selections. - -Note [Kind coercions] -~~~~~~~~~~~~~~~~~~~~~ -Suppose T :: * -> *, and g :: A ~ B -Then the coercion - TyConAppCo T [g] T g : T A ~ T B - -Now suppose S :: forall k. k -> *, and g :: A ~ B -Then the coercion - TyConAppCo S [Refl *, g] T <*> g : T * A ~ T * B - -Notice that the arguments to TyConAppCo are coercions, but the first -represents a *kind* coercion. Now, we don't allow any non-trivial kind -coercions, so it's an invariant that any such kind coercions are Refl. -Lint checks this. - -However it's inconvenient to insist that these kind coercions are always -*structurally* (Refl k), because the key function exprIsConApp_maybe -pushes coercions into constructor arguments, so - C k ty e |> g -may turn into - C (Nth 0 g) .... -Now (Nth 0 g) will optimise to Refl, but perhaps not instantly. - -Note [Roles] -~~~~~~~~~~~~ -Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated -in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see -http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation - -Here is one way to phrase the problem: - -Given: -newtype Age = MkAge Int -type family F x -type instance F Age = Bool -type instance F Int = Char - -This compiles down to: -axAge :: Age ~ Int -axF1 :: F Age ~ Bool -axF2 :: F Int ~ Char - -Then, we can make: -(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char - -Yikes! - -The solution is _roles_, as articulated in "Generative Type Abstraction and -Type-level Computation" (POPL 2010), available at -http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf - -The specification for roles has evolved somewhat since that paper. For the -current full details, see the documentation in docs/core-spec. Here are some -highlights. - -We label every equality with a notion of type equivalence, of which there are -three options: Nominal, Representational, and Phantom. A ground type is -nominally equivalent only with itself. A newtype (which is considered a ground -type in Haskell) is representationally equivalent to its representation. -Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" -to denote the equivalences. - -The axioms above would be: -axAge :: Age ~R Int -axF1 :: F Age ~N Bool -axF2 :: F Age ~N Char - -Then, because transitivity applies only to coercions proving the same notion -of equivalence, the above construction is impossible. - -However, there is still an escape hatch: we know that any two types that are -nominally equivalent are representationally equivalent as well. This is what -the form SubCo proves -- it "demotes" a nominal equivalence into a -representational equivalence. So, it would seem the following is possible: - -sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG - -What saves us here is that the arguments to a type function F, lifted into a -coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and -we are safe. - -Roles are attached to parameters to TyCons. When lifting a TyCon into a -coercion (through TyConAppCo), we need to ensure that the arguments to the -TyCon respect their roles. For example: - -data T a b = MkT a (F b) - -If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know -that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because -the type function F branches on b's *name*, not representation. So, we say -that 'a' has role Representational and 'b' has role Nominal. The third role, -Phantom, is for parameters not used in the type's definition. Given the -following definition - -data Q a = MkQ Int - -the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we -can construct the coercion Bool ~P Char (using UnivCo). - -See the paper cited above for more examples and information. - -Note [UnivCo] -~~~~~~~~~~~~~ -The UnivCo ("universal coercion") serves two rather separate functions: - - the implementation for unsafeCoerce# - - placeholder for phantom parameters in a TyConAppCo - -At Representational, it asserts that two (possibly unrelated) -types have the same representation and can be casted to one another. -This form is necessary for unsafeCoerce#. - -For optimisation purposes, it is convenient to allow UnivCo to appear -at Nominal role. If we have - -data Foo a = MkFoo (F a) -- F is a type family - -and we want an unsafe coercion from Foo Int to Foo Bool, then it would -be nice to have (TyConAppCo Foo (UnivCo Nominal Int Bool)). So, we allow -Nominal UnivCo's. - -At Phantom role, it is used as an argument to TyConAppCo in the place -of a phantom parameter (a type parameter unused in the type definition). - -For example: - -data Q a = MkQ Int - -We want a coercion for (Q Bool) ~R (Q Char). - -(TyConAppCo Representational Q [UnivCo Phantom Bool Char]) does the trick. - -Note [TyConAppCo roles] -~~~~~~~~~~~~~~~~~~~~~~~ -The TyConAppCo constructor has a role parameter, indicating the role at -which the coercion proves equality. The choice of this parameter affects -the required roles of the arguments of the TyConAppCo. To help explain -it, assume the following definition: - - type instance F Int = Bool -- Axiom axF : F Int ~N Bool - newtype Age = MkAge Int -- Axiom axAge : Age ~R Int - data Foo a = MkFoo a -- Role on Foo's parameter is Representational - -TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool - For (TyConAppCo Nominal) all arguments must have role Nominal. Why? - So that Foo Age ~N Foo Int does *not* hold. - -TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool -TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int - For (TyConAppCo Representational), all arguments must have the roles - corresponding to the result of tyConRoles on the TyCon. This is the - whole point of having roles on the TyCon to begin with. So, we can - have Foo Age ~R Foo Int, if Foo's parameter has role R. - - If a Representational TyConAppCo is over-saturated (which is otherwise fine), - the spill-over arguments must all be at Nominal. This corresponds to the - behavior for AppCo. - -TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool - All arguments must have role Phantom. This one isn't strictly - necessary for soundness, but this choice removes ambiguity. - -The rules here dictate the roles of the parameters to mkTyConAppCo -(should be checked by Lint). - -Note [NthCo and newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype N a = MkN Int - type role N representational - -This yields axiom - - NTCo:N :: forall a. N a ~R Int - -We can then build - - co :: forall a b. N a ~R N b - co = NTCo:N a ; sym (NTCo:N b) - -for any `a` and `b`. Because of the role annotation on N, if we use -NthCo, we'll get out a representational coercion. That is: - - NthCo 0 co :: forall a b. a ~R b - -Yikes! Clearly, this is terrible. The solution is simple: forbid -NthCo to be used on newtypes if the internal coercion is representational. - -This is not just some corner case discovered by a segfault somewhere; -it was discovered in the proof of soundness of roles and described -in the "Safe Coercions" paper (ICFP '14). - -************************************************************************ -* * \subsection{Coercion variables} -* * -************************************************************************ +%* * +%************************************************************************ -} coVarName :: CoVar -> Name @@ -549,141 +163,37 @@ setCoVarUnique = setVarUnique setCoVarName :: CoVar -> Name -> CoVar setCoVarName = setVarName -isCoVar :: Var -> Bool -isCoVar v = isCoVarType (varType v) - -isCoVarType :: Type -> Bool -isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality - = case splitTyConApp_maybe ty of - Just (tc,tys) -> (tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) - && tys `lengthAtLeast` 2 - Nothing -> False - -tyCoVarsOfCo :: Coercion -> VarSet -tyCoVarsOfCo co = runFVSet $ tyCoVarsOfCoAcc co --- Extracts type and coercion variables from a coercion - -tyCoVarsOfCos :: [Coercion] -> VarSet -tyCoVarsOfCos cos = runFVSet $ tyCoVarsOfCosAcc cos - -tyCoVarsOfCoAcc :: Coercion -> FV -tyCoVarsOfCoAcc (Refl _ ty) fv_cand in_scope acc = - tyVarsOfTypeAcc ty fv_cand in_scope acc -tyCoVarsOfCoAcc (TyConAppCo _ _ cos) fv_cand in_scope acc = - tyCoVarsOfCosAcc cos fv_cand in_scope acc -tyCoVarsOfCoAcc (AppCo co1 co2) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc -tyCoVarsOfCoAcc (ForAllCo tv co) fv_cand in_scope acc = - delFV tv (tyCoVarsOfCoAcc co) fv_cand in_scope acc -tyCoVarsOfCoAcc (CoVarCo v) fv_cand in_scope acc = oneVar v fv_cand in_scope acc -tyCoVarsOfCoAcc (AxiomInstCo _ _ cos) fv_cand in_scope acc = - tyCoVarsOfCosAcc cos fv_cand in_scope acc -tyCoVarsOfCoAcc (UnivCo _ _ ty1 ty2) fv_cand in_scope acc = - (tyVarsOfTypeAcc ty1 `unionFV` tyVarsOfTypeAcc ty2) fv_cand in_scope acc -tyCoVarsOfCoAcc (SymCo co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (TransCo co1 co2) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc -tyCoVarsOfCoAcc (NthCo _ co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (LRCo _ co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (InstCo co ty) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co `unionFV` tyVarsOfTypeAcc ty) fv_cand in_scope acc -tyCoVarsOfCoAcc (SubCo co) fv_cand in_scope acc = - tyCoVarsOfCoAcc co fv_cand in_scope acc -tyCoVarsOfCoAcc (AxiomRuleCo _ ts cs) fv_cand in_scope acc = - (tyVarsOfTypesAcc ts `unionFV` tyCoVarsOfCosAcc cs) fv_cand in_scope acc - -tyCoVarsOfCosAcc :: [Coercion] -> FV -tyCoVarsOfCosAcc (co:cos) fv_cand in_scope acc = - (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCosAcc cos) fv_cand in_scope acc -tyCoVarsOfCosAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc - -coVarsOfCo :: Coercion -> VarSet --- Extract *coerction* variables only. Tiresome to repeat the code, but easy. -coVarsOfCo (Refl _ _) = emptyVarSet -coVarsOfCo (TyConAppCo _ _ cos) = coVarsOfCos cos -coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (ForAllCo _ co) = coVarsOfCo co -coVarsOfCo (CoVarCo v) = unitVarSet v -coVarsOfCo (AxiomInstCo _ _ cos) = coVarsOfCos cos -coVarsOfCo (UnivCo _ _ _ _) = emptyVarSet -coVarsOfCo (SymCo co) = coVarsOfCo co -coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (NthCo _ co) = coVarsOfCo co -coVarsOfCo (LRCo _ co) = coVarsOfCo co -coVarsOfCo (InstCo co _) = coVarsOfCo co -coVarsOfCo (SubCo co) = coVarsOfCo co -coVarsOfCo (AxiomRuleCo _ _ cos) = coVarsOfCos cos - -coVarsOfCos :: [Coercion] -> VarSet -coVarsOfCos = mapUnionVarSet coVarsOfCo - coercionSize :: Coercion -> Int -coercionSize (Refl _ ty) = typeSize ty -coercionSize (TyConAppCo _ _ cos) = 1 + sum (map coercionSize cos) -coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2 -coercionSize (ForAllCo _ co) = 1 + coercionSize co -coercionSize (CoVarCo _) = 1 -coercionSize (AxiomInstCo _ _ cos) = 1 + sum (map coercionSize cos) -coercionSize (UnivCo _ _ ty1 ty2) = typeSize ty1 + typeSize ty2 -coercionSize (SymCo co) = 1 + coercionSize co -coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (NthCo _ co) = 1 + coercionSize co -coercionSize (LRCo _ co) = 1 + coercionSize co -coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty -coercionSize (SubCo co) = 1 + coercionSize co -coercionSize (AxiomRuleCo _ tys cos) = 1 + sum (map typeSize tys) - + sum (map coercionSize cos) +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 (CoVarCo _) = 1 +coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg +coercionSize (CoherenceCo c1 c2) = 1 + coercionSize c1 + coercionSize c2 +coercionSize (KindCo co) = 1 + coercionSize co +coercionSize (SubCo co) = 1 + coercionSize co +coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) + +provSize :: UnivCoProvenance -> Int +provSize UnsafeCoerceProv = 1 +provSize (PhantomProv co) = 1 + coercionSize co +provSize (ProofIrrelProv co) = 1 + coercionSize co +provSize (PluginProv _) = 1 +provSize (HoleProv h) = pprPanic "provSize hits a hole" (ppr h) {- -************************************************************************ -* * - Tidying coercions -* * -************************************************************************ --} - -tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co - = go co - where - go (Refl r ty) = Refl r (tidyType env ty) - go (TyConAppCo r tc cos) = let args = map go cos - in args `seqList` TyConAppCo r tc args - go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 - go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co) - where - (envp, tvp) = tidyTyVarBndr env tv - go (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' - go (AxiomInstCo con ind cos) = let args = tidyCos env cos - in args `seqList` AxiomInstCo con ind args - go (UnivCo s r ty1 ty2) = (UnivCo s r $! tidyType env ty1) $! tidyType env ty2 - go (SymCo co) = SymCo $! go co - go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo d co) = NthCo d $! go co - go (LRCo lr co) = LRCo lr $! go co - go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty - go (SubCo co) = SubCo $! go co - - go (AxiomRuleCo ax tys cos) = let tys1 = map (tidyType env) tys - cos1 = tidyCos env cos - in tys1 `seqList` cos1 `seqList` - AxiomRuleCo ax tys1 cos1 - - -tidyCos :: TidyEnv -> [Coercion] -> [Coercion] -tidyCos env = map (tidyCo env) - -{- -************************************************************************ -* * +%************************************************************************ +%* * Pretty-printing coercions -* * -************************************************************************ +%* * +%************************************************************************ @pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@ function is defined to use this. @pprParendCo@ is the same, except it @@ -692,8 +202,7 @@ puts parens around the type, except for the atomic cases. very high. -} -instance Outputable Coercion where - ppr = pprCo +-- Outputable instances are in TyCoRep, to avoid orphans pprCo, pprParendCo :: Coercion -> SDoc pprCo co = ppr_co TopPrec co @@ -705,47 +214,44 @@ ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r ppr_co p co@(TyConAppCo _ tc [_,_]) | tc `hasKey` funTyConKey = ppr_fun_co p co -ppr_co _ (TyConAppCo r tc cos) = pprTcApp TyConPrec ppr_co tc cos <> ppr_role r -ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ - pprCo co1 <+> ppr_co TyConPrec co2 -ppr_co p co@(ForAllCo {}) = ppr_forall_co p co -ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con index cos) +ppr_co _ (TyConAppCo r tc cos) = pprTcAppCo TyConPrec ppr_co tc cos <> ppr_role r +ppr_co p (AppCo co arg) = maybeParen p TyConPrec $ + pprCo co <+> ppr_co TyConPrec arg +ppr_co p co@(ForAllCo {}) = ppr_forall_co p co +ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) +ppr_co p (AxiomInstCo con index args) = pprPrefixApp p (ppr (getName con) <> brackets (ppr index)) - (map (ppr_co TyConPrec) cos) + (map (ppr_co TyConPrec) args) ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ case trans_co_list co [] of [] -> panic "ppr_co" (co:cos) -> sep ( ppr_co FunPrec co : [ char ';' <+> ppr_co FunPrec co | co <- cos]) -ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ - pprParendCo co <> ptext (sLit "@") <> pprType ty - -ppr_co p (UnivCo s r ty1 ty2) = pprPrefixApp p (ptext (sLit "UnivCo") <+> ftext s <+> ppr r) - [pprParendType ty1, pprParendType ty2] -ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] -ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] -ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] -ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co] -ppr_co p (AxiomRuleCo co ts cs) = maybeParen p TopPrec $ - ppr_axiom_rule_co co ts cs +ppr_co p (InstCo co arg) = maybeParen p TyConPrec $ + pprParendCo co <> ptext (sLit "@") <> ppr_co TopPrec arg -ppr_axiom_rule_co :: CoAxiomRule -> [Type] -> [Coercion] -> SDoc -ppr_axiom_rule_co co ts ps = ppr (coaxrName co) <> ppTs ts $$ nest 2 (ppPs ps) +ppr_co p (UnivCo UnsafeCoerceProv r ty1 ty2) + = pprPrefixApp p (ptext (sLit "UnsafeCo") <+> ppr r) + [pprParendType ty1, pprParendType ty2] +ppr_co _ (UnivCo p r t1 t2)= angleBrackets ( ppr t1 <> comma <+> ppr t2 ) <> ppr_role r <> ppr_prov where - ppTs [] = Outputable.empty - ppTs [t] = ptext (sLit "@") <> ppr_type TopPrec t - ppTs ts = ptext (sLit "@") <> - parens (hsep $ punctuate comma $ map pprType ts) - - ppPs [] = Outputable.empty - ppPs [p] = pprParendCo p - ppPs (p : ps) = ptext (sLit "(") <+> pprCo p $$ - vcat [ ptext (sLit ",") <+> pprCo q | q <- ps ] $$ - ptext (sLit ")") - + ppr_prov = case p of + HoleProv h -> ppr h + PhantomProv kind_co -> braces (ppr kind_co) + _ -> empty +ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] +ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] +ppr_co p (CoherenceCo c1 c2) = maybeParen p TyConPrec $ + (ppr_co FunPrec c1) <+> (ptext (sLit "|>")) <+> + (ppr_co FunPrec c2) +ppr_co p (KindCo co) = pprPrefixApp p (ptext (sLit "kind")) [pprParendCo co] +ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co] +ppr_co p (AxiomRuleCo co cs) = maybeParen p TopPrec $ ppr_axiom_rule_co co cs +ppr_axiom_rule_co :: CoAxiomRule -> [Coercion] -> SDoc +ppr_axiom_rule_co co ps = ppr (coaxrName co) <+> parens (interpp'SP ps) ppr_role :: Role -> SDoc ppr_role r = underscore <> pp_role @@ -758,27 +264,24 @@ trans_co_list :: Coercion -> [Coercion] -> [Coercion] trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos) trans_co_list co cos = co : cos -instance Outputable LeftOrRight where - ppr CLeft = ptext (sLit "Left") - ppr CRight = ptext (sLit "Right") - ppr_fun_co :: TyPrec -> Coercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) where split :: Coercion -> [SDoc] - split (TyConAppCo _ f [arg,res]) + split (TyConAppCo _ f [arg, res]) | f `hasKey` funTyConKey = ppr_co FunPrec arg : split res split co = [ppr_co TopPrec co] ppr_forall_co :: TyPrec -> Coercion -> SDoc -ppr_forall_co p ty +ppr_forall_co p (ForAllCo tv h co) = maybeParen p FunPrec $ - sep [pprForAll tvs, ppr_co TopPrec rho] - where - (tvs, rho) = split1 [] ty - split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) + sep [pprCoBndr (tyVarName tv) h, ppr_co TopPrec co] +ppr_forall_co _ _ = panic "ppr_forall_co" + +pprCoBndr :: Name -> Coercion -> SDoc +pprCoBndr name eta = + forAllLit <+> parens (ppr name <+> dcolon <+> ppr eta) <> dot pprCoAxiom :: CoAxiom br -> SDoc pprCoAxiom ax@(CoAxiom { co_ax_branches = branches }) @@ -800,11 +303,12 @@ ppr_co_ax_branch :: (TyCon -> Type -> SDoc) -> CoAxiom br -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs (CoAxiom { co_ax_tc = fam_tc, co_ax_name = name }) (CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs , cab_lhs = lhs , cab_rhs = rhs , cab_loc = loc }) = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll tvs + [ pprUserForAll (map (flip mkNamedBinder Invisible) (tvs ++ cvs)) , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs , text "-- Defined" <+> pprLoc loc ] where @@ -817,11 +321,11 @@ ppr_co_ax_branch ppr_rhs quotes (ppr (nameModule name)) {- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ -} -- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into @@ -838,35 +342,61 @@ getCoVar_maybe :: Coercion -> Maybe CoVar getCoVar_maybe (CoVarCo cv) = Just cv getCoVar_maybe _ = Nothing --- first result has role equal to input; second result is Nominal +-- | Attempts to tease a coercion apart into a type constructor and the application +-- of a number of coercion arguments to that constructor +splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) +splitTyConAppCo_maybe (Refl r ty) + = do { (tc, tys) <- splitTyConApp_maybe ty + ; let args = zipWith mkReflCo (tyConRolesX r tc) tys + ; return (tc, args) } +splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) +splitTyConAppCo_maybe _ = Nothing + +-- first result has role equal to input; third result is Nominal splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -- ^ Attempt to take a coercion application apart. -splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2) -splitAppCo_maybe (TyConAppCo r tc cos) - | mightBeUnsaturatedTyCon tc || cos `lengthExceeds` tyConArity tc - , Just (cos', co') <- snocView cos - , Just co'' <- setNominalRole_maybe co' - = Just (mkTyConAppCo r tc cos', co'') -- Never create unsaturated type family apps! +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | mightBeUnsaturatedTyCon tc || args `lengthExceeds` tyConArity tc + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe arg' + = Just ( mkTyConAppCo r tc args', arg'' ) -- Use mkTyConAppCo to preserve the invariant -- that identity coercions are always represented by Refl + splitAppCo_maybe (Refl r ty) | Just (ty1, ty2) <- splitAppTy_maybe ty - = Just (Refl r ty1, Refl Nominal ty2) + = Just (mkReflCo r ty1, mkNomReflCo ty2) splitAppCo_maybe _ = Nothing -splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) -splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co) -splitForAllCo_maybe _ = Nothing +splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) +splitForAllCo_maybe _ = Nothing ------------------------------------------------------- -- and some coercion kind stuff -coVarKind :: CoVar -> (Type,Type) +coVarTypes :: CoVar -> (Type,Type) +coVarTypes cv + | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv + = (ty1, ty2) + +coVarKindsTypesRole :: CoVar -> (Kind,Kind,Type,Type,Role) +coVarKindsTypesRole cv + | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = let role + | tc `hasKey` eqPrimTyConKey = Nominal + | tc `hasKey` eqReprPrimTyConKey = Representational + | otherwise = panic "coVarKindsTypesRole" + in (k1,k2,ty1,ty2,role) + | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type coVarKind cv - | Just (tc, [_kind,ty1,ty2]) <- splitTyConApp_maybe (varType cv) - = ASSERT(tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) - (ty1,ty2) - | otherwise = panic "coVarKind, non coercion variable" + = ASSERT( isCoVar cv ) + varType cv coVarRole :: CoVar -> Role coVarRole cv @@ -875,7 +405,7 @@ coVarRole cv | tc `hasKey` eqReprPrimTyConKey = Representational | otherwise - = pprPanic "coVarRole: unknown tycon" (ppr cv) + = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv)) where tc = case tyConAppTyCon_maybe (varType cv) of @@ -887,22 +417,34 @@ coVarRole cv mkCoercionType :: Role -> Type -> Type -> Type mkCoercionType Nominal = mkPrimEqPred mkCoercionType Representational = mkReprPrimEqPred -mkCoercionType Phantom = panic "mkCoercionType" +mkCoercionType Phantom = \ty1 ty2 -> + let ki1 = typeKind ty1 + ki2 = typeKind ty2 + in + TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] + +mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type +mkHeteroCoercionType Nominal = mkHeteroPrimEqPred +mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred +mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" isReflCo :: Coercion -> Bool -isReflCo (Refl {}) = True -isReflCo _ = False +isReflCo (Refl {}) = True +isReflCo _ = False -isReflCo_maybe :: Coercion -> Maybe Type -isReflCo_maybe (Refl _ ty) = Just ty -isReflCo_maybe _ = Nothing +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl r ty) = Just (ty, r) +isReflCo_maybe _ = Nothing {- -************************************************************************ -* * +%************************************************************************ +%* * Building coercions -* * -************************************************************************ +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. Note [Role twiddling functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -925,18 +467,19 @@ This function could have been written using coercionRole to ascertain the role of the input. But, that function is recursive, and the caller of downgradeRole_maybe often knows the input role. So, this is more efficient. -downgradeRole: This is just like downgradeRole_maybe, but it panics if the conversion -isn't a downgrade. +downgradeRole: This is just like downgradeRole_maybe, but it panics if the +conversion isn't a downgrade. -setNominalRole_maybe: This is the only function that can *upgrade* a coercion. The result -(if it exists) is always Nominal. The input can be at any role. It works on a -"best effort" basis, as it should never be strictly necessary to upgrade a coercion -during compilation. It is currently only used within GHC in splitAppCo_maybe. In order -to be a proper inverse of mkAppCo, the second coercion that splitAppCo_maybe returns -must be nominal. But, it's conceivable that splitAppCo_maybe is operating over a -TyConAppCo that uses a representational coercion. Hence the need for setNominalRole_maybe. -splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, it is -not absolutely critical that setNominalRole_maybe be complete. +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. +The result (if it exists) is always Nominal. The input can be at any role. It +works on a "best effort" basis, as it should never be strictly necessary to +upgrade a coercion during compilation. It is currently only used within GHC in +splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second +coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable +that splitAppCo_maybe is operating over a TyConAppCo that uses a +representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, +it is not absolutely critical that setNominalRole_maybe be complete. Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom UnivCos are perfectly type-safe, whereas representational and nominal ones are @@ -944,110 +487,63 @@ not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. (Nominal ones are no worse than representational ones, so this function *will* change a UnivCo Representational to a UnivCo Nominal.) -Conal Elliott also came across a need for this function while working with the GHC -API, as he was decomposing Core casts. The Core casts use representational coercions, -as they must, but his use case required nominal coercions (he was building a GADT). -So, that's why this function is exported from this module. +Conal Elliott also came across a need for this function while working with the +GHC API, as he was decomposing Core casts. The Core casts use representational +coercions, as they must, but his use case required nominal coercions (he was +building a GADT). So, that's why this function is exported from this module. -One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as appropriate? -I (Richard E.) have decided not to do this, because upgrading a role is bizarre and -a caller should have to ask for this behavior explicitly. --} +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as +appropriate? I (Richard E.) have decided not to do this, because upgrading a +role is bizarre and a caller should have to ask for this behavior explicitly. -mkCoVarCo :: CoVar -> Coercion --- cv :: s ~# t -mkCoVarCo cv - | ty1 `eqType` ty2 = Refl (coVarRole cv) ty1 - | otherwise = CoVarCo cv - where - (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv +Note [mkTransAppCo] +~~~~~~~~~~~~~~~~~~~ +Suppose we have -mkReflCo :: Role -> Type -> Coercion -mkReflCo = Refl + co1 :: a ~R Maybe + co2 :: b ~R Int -mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> Coercion --- mkAxInstCo can legitimately be called over-staturated; --- i.e. with more type arguments than the coercion requires -mkAxInstCo role ax index tys - | arity == n_tys = downgradeRole role ax_role $ AxiomInstCo ax_br index rtys - | otherwise = ASSERT( arity < n_tys ) - downgradeRole role ax_role $ - foldl AppCo (AxiomInstCo ax_br index (take arity rtys)) - (drop arity rtys) - where - n_tys = length tys - ax_br = toBranchedAxiom ax - branch = coAxiomNthBranch ax_br index - arity = length $ coAxBranchTyVars branch - arg_roles = coAxBranchRoles branch - rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys - ax_role = coAxiomRole ax +and we want --- to be used only with unbranched axioms -mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> Coercion -mkUnbranchedAxInstCo role ax tys - = mkAxInstCo role ax 0 tys + co3 :: a b ~R Maybe Int -mkAxInstLHS, mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> Type --- Instantiate the axiom with specified types, --- returning the instantiated RHS --- A companion to mkAxInstCo: --- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) -mkAxInstLHS ax index tys - | CoAxBranch { cab_tvs = tvs, cab_lhs = lhs } <- coAxiomNthBranch ax index - , (tys1, tys2) <- splitAtList tvs tys - = ASSERT( tvs `equalLength` tys1 ) - mkTyConApp (coAxiomTyCon ax) (substTysWith tvs tys1 lhs ++ tys2) +This seems sensible enough. But, we can't let (co3 = co1 co2), because +that's ill-roled! Note that mkAppCo requires a *nominal* second coercion. -mkAxInstRHS ax index tys - | CoAxBranch { cab_tvs = tvs, cab_rhs = rhs } <- coAxiomNthBranch ax index - , (tys1, tys2) <- splitAtList tvs tys - = ASSERT( tvs `equalLength` tys1 ) - mkAppTys (substTyWith tvs tys1 rhs) tys2 +The way around this is to use transitivity: -mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> Type -mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + co3 = (co1 <b>_N) ; (Maybe co2) :: a b ~R Maybe Int --- | Apply a 'Coercion' to another 'Coercion'. --- The second coercion must be Nominal, unless the first is Phantom. --- If the first is Phantom, then the second can be either Phantom or Nominal. -mkAppCo :: Coercion -> Coercion -> Coercion -mkAppCo co1 co2 = mkAppCoFlexible co1 Nominal co2 --- Note, mkAppCo is careful to maintain invariants regarding --- where Refl constructors appear; see the comments in the definition --- of Coercion and the Note [Refl invariant] in types/TypeRep.hs. +Or, it's possible everything is the other way around: --- | Apply a 'Coercion' to another 'Coercion'. --- The second 'Coercion's role is given, making this more flexible than --- 'mkAppCo'. -mkAppCoFlexible :: Coercion -> Role -> Coercion -> Coercion -mkAppCoFlexible (Refl r ty1) _ (Refl _ ty2) - = Refl r (mkAppTy ty1 ty2) -mkAppCoFlexible (Refl r ty1) r2 co2 - | Just (tc, tys) <- splitTyConApp_maybe ty1 - -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102) - = TyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) - where - zip_roles (r1:_) [] = [downgradeRole r1 r2 co2] - zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... -mkAppCoFlexible (TyConAppCo r tc cos) r2 co - = case r of - Nominal -> ASSERT( r2 == Nominal ) - TyConAppCo Nominal tc (cos ++ [co]) - Representational -> TyConAppCo Representational tc (cos ++ [co']) - where new_role = (tyConRolesX Representational tc) !! (length cos) - co' = downgradeRole new_role r2 co - Phantom -> TyConAppCo Phantom tc (cos ++ [mkPhantomCo co]) + co1' :: Maybe ~R a + co2' :: Int ~R b -mkAppCoFlexible co1 _r2 co2 = ASSERT( _r2 == Nominal ) - AppCo co1 co2 +and we want + co3' :: Maybe Int ~R a b --- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCo'. -mkAppCos :: Coercion -> [Coercion] -> Coercion -mkAppCos co1 cos = foldl mkAppCo co1 cos +then + + co3' = (Maybe co2') ; (co1' <b>_N) + +This is exactly what `mkTransAppCo` builds for us. Information for all +the arguments tends to be to hand at call sites, so it's quicker than +using, say, coercionKind. + +-} + +mkReflCo :: Role -> Type -> Coercion +mkReflCo r ty + = Refl r ty + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo = mkReflCo Representational + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = mkReflCo Nominal -- | Apply a type constructor to a list of coercions. It is the -- caller's responsibility to get the roles correct on argument coercions. @@ -1055,10 +551,10 @@ mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion mkTyConAppCo r tc cos -- Expand type synonyms | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos - = mkAppCos (liftCoSubst r tv_co_prs rhs_ty) leftover_cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - | Just tys <- traverse isReflCo_maybe cos - = Refl r (mkTyConApp tc tys) -- See Note [Refl invariant] + | Just tys_roles <- traverse isReflCo_maybe cos + = Refl r (mkTyConApp tc (map fst tys_roles)) -- See Note [Refl invariant] | otherwise = TyConAppCo r tc cos @@ -1066,13 +562,258 @@ mkTyConAppCo r tc cos mkFunCo :: Role -> Coercion -> Coercion -> Coercion mkFunCo r co1 co2 = mkTyConAppCo r funTyCon [co1, co2] --- | Make a 'Coercion' which binds a variable within an inner 'Coercion' -mkForAllCo :: Var -> Coercion -> Coercion --- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) -mkForAllCo tv (Refl r ty) = ASSERT( isTyVar tv ) Refl r (mkForAllTy tv ty) -mkForAllCo tv co = ASSERT( isTyVar tv ) ForAllCo tv co +-- | Make nested function 'Coercion's +mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion +mkFunCos r cos res_co = foldr (mkFunCo r) res_co cos -------------------------------- +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -- ^ :: t1 ~r t2 + -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> Coercion -- ^ :: t1 s1 ~r t2 s2 +mkAppCo (Refl r ty1) arg + | Just (ty2, _) <- isReflCo_maybe arg + = Refl r (mkAppTy ty1 ty2) + + | Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102) + = TyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] + zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... + +mkAppCo (TyConAppCo r tc args) arg + = case r of + Nominal -> TyConAppCo Nominal tc (args ++ [arg]) + Representational -> TyConAppCo Representational tc (args ++ [arg']) + where new_role = (tyConRolesX Representational tc) !! (length args) + arg' = downgradeRole new_role Nominal arg + Phantom -> TyConAppCo Phantom tc (args ++ [toPhantomCo arg]) +mkAppCo co arg = AppCo co arg +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in TyCoRep. + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion + -> [Coercion] + -> Coercion +mkAppCos co1 cos = foldl mkAppCo co1 cos + +-- | Like `mkAppCo`, but allows the second coercion to be other than +-- nominal. See Note [mkTransAppCo]. Role r3 cannot be more stringent +-- than either r1 or r2. +mkTransAppCo :: Role -- ^ r1 + -> Coercion -- ^ co1 :: ty1a ~r1 ty1b + -> Type -- ^ ty1a + -> Type -- ^ ty1b + -> Role -- ^ r2 + -> Coercion -- ^ co2 :: ty2a ~r2 ty2b + -> Type -- ^ ty2a + -> Type -- ^ ty2b + -> Role -- ^ r3 + -> Coercion -- ^ :: ty1a ty2a ~r3 ty1b ty2b +mkTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3 +-- How incredibly fiddly! Is there a better way?? + = case (r1, r2, r3) of + (_, _, Phantom) + -> mkPhantomCo kind_co (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b) + where -- ty1a :: k1a -> k2a + -- ty1b :: k1b -> k2b + -- ty2a :: k1a + -- ty2b :: k1b + -- ty1a ty2a :: k2a + -- ty1b ty2b :: k2b + kind_co1 = mkKindCo co1 -- :: k1a -> k2a ~N k1b -> k2b + kind_co = mkNthCo 1 kind_co1 -- :: k2a ~N k2b + + (_, _, Nominal) + -> ASSERT( r1 == Nominal && r2 == Nominal ) + mkAppCo co1 co2 + (Nominal, Nominal, Representational) + -> mkSubCo (mkAppCo co1 co2) + (_, Nominal, Representational) + -> ASSERT( r1 == Representational ) + mkAppCo co1 co2 + (Nominal, Representational, Representational) + -> go (mkSubCo co1) + (_ , _, Representational) + -> ASSERT( r1 == Representational && r2 == Representational ) + go co1 + where + go co1_repr + | Just (tc1b, tys1b) <- splitTyConApp_maybe ty1b + , nextRole ty1b == r2 + = (mkAppCo co1_repr (mkNomReflCo ty2a)) `mkTransCo` + (mkTyConAppCo Representational tc1b + (zipWith mkReflCo (tyConRolesX Representational tc1b) tys1b + ++ [co2])) + + | Just (tc1a, tys1a) <- splitTyConApp_maybe ty1a + , nextRole ty1a == r2 + = (mkTyConAppCo Representational tc1a + (zipWith mkReflCo (tyConRolesX Representational tc1a) tys1a + ++ [co2])) + `mkTransCo` + (mkAppCo co1_repr (mkNomReflCo ty2b)) + + | otherwise + = pprPanic "mkTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b + , ppr r2, ppr co2, ppr ty2a, ppr ty2b + , ppr r3 ]) + +-- | Make a Coercion from a tyvar, a kind coercion, and a body coercion. +-- The kind of the tyvar should be the left-hand kind of the kind coercion. +mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion +mkForAllCo tv kind_co co + | Refl r ty <- co + , Refl {} <- kind_co + = Refl r (mkNamedForAllTy tv Invisible ty) + | otherwise + = ForAllCo tv kind_co co + +-- | Make nested ForAllCos +mkForAllCos :: [(TyVar, Coercion)] -> Coercion -> Coercion +mkForAllCos bndrs (Refl r ty) + = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in + foldl (flip $ uncurry ForAllCo) + (Refl r $ mkInvForAllTys (reverse (map fst refls_rev'd)) ty) + non_refls_rev'd +mkForAllCos bndrs co = foldr (uncurry ForAllCo) co bndrs + +-- | Make a Coercion quantified over a type variable; +-- the variable has the same type in both sides of the coercion +mkHomoForAllCos :: [TyVar] -> Coercion -> Coercion +mkHomoForAllCos tvs (Refl r ty) + = Refl r (mkInvForAllTys tvs ty) +mkHomoForAllCos tvs ty = mkHomoForAllCos_NoRefl tvs ty + +-- | Like 'mkHomoForAllCos', but doesn't check if the inner coercion +-- is reflexive. +mkHomoForAllCos_NoRefl :: [TyVar] -> Coercion -> Coercion +mkHomoForAllCos_NoRefl tvs orig_co = foldr go orig_co tvs + where + go tv co = ForAllCo tv (mkNomReflCo (tyVarKind tv)) co + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +mkCoVarCo cv + | ty1 `eqType` ty2 = Refl (coVarRole cv) ty1 + | otherwise = CoVarCo cv + where + (ty1, ty2) = coVarTypes cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) +isCoVar_maybe :: Coercion -> Maybe CoVar +isCoVar_maybe (CoVarCo cv) = Just cv +isCoVar_maybe _ = Nothing + +mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] + -> Coercion +-- mkAxInstCo can legitimately be called over-staturated; +-- i.e. with more type arguments than the coercion requires +mkAxInstCo role ax index tys cos + | arity == n_tys = downgradeRole role ax_role $ + mkAxiomInstCo ax_br index (rtys `chkAppend` cos) + | otherwise = ASSERT( arity < n_tys ) + downgradeRole role ax_role $ + mkAppCos (mkAxiomInstCo ax_br index + (ax_args `chkAppend` cos)) + leftover_args + where + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + tvs = coAxBranchTyVars branch + arity = length tvs + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + (ax_args, leftover_args) + = splitAt arity rtys + ax_role = coAxiomRole ax + +-- worker function; just checks to see if it should produce Refl +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkAxiomInstCo ax index args + = ASSERT( coAxiomArity ax index == length args ) + AxiomInstCo ax index args + +-- to be used only with unbranched axioms +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched + -> [Type] -> [Coercion] -> Coercion +mkUnbranchedAxInstCo role ax tys cos + = mkAxInstCo role ax 0 tys cos + +mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstRHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkAppTys rhs' tys2 + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 $ + substTyWithCoVars cvs cos $ + coAxBranchRHS branch + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Return the left-hand type of the axiom, when the axiom is instantiated +-- at the types given. +mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +mkAxInstLHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + lhs_tys = substTysWith tvs tys1 $ + substTysWithCoVars cvs cos $ + coAxBranchLHS branch + fam_tc = coAxiomTyCon ax + +-- | Instantiate the left-hand side of an unbranched axiom +mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 + +-- | Manufacture an unsafe coercion from thin air. +-- Currently (May 14) this is used only to implement the +-- @unsafeCoerce#@ primitive. Optimise by pushing +-- down through type constructors. +mkUnsafeCo :: Role -> Type -> Type -> Coercion +mkUnsafeCo role ty1 ty2 + = mkUnivCo UnsafeCoerceProv role ty1 ty2 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Role + -> Type -> Type -> Coercion +mkHoleCo h r t1 t2 = mkUnivCo (HoleProv h) r t1 t2 + +-- | Make a universal coercion between two arbitrary types. +mkUnivCo :: UnivCoProvenance + -> Role -- ^ role of the built coercion, "r" + -> Type -- ^ t1 :: k1 + -> Type -- ^ t2 :: k2 + -> Coercion -- ^ :: t1 ~r t2 +mkUnivCo prov role ty1 ty2 + | ty1 `eqType` ty2 = Refl role ty1 + | otherwise = UnivCo prov role ty1 ty2 -- | Create a symmetric version of the given 'Coercion' that asserts -- equality between the same types but in the other "direction", so @@ -1081,16 +822,16 @@ mkSymCo :: Coercion -> Coercion -- Do a few simple optimizations, but don't bother pushing occurrences -- of symmetry to the leaves; the optimizer will take care of that. -mkSymCo co@(Refl {}) = co -mkSymCo (UnivCo s r ty1 ty2) = UnivCo s r ty2 ty1 -mkSymCo (SymCo co) = co -mkSymCo co = SymCo co +mkSymCo co@(Refl {}) = co +mkSymCo (SymCo co) = co +mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo co = SymCo co -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. mkTransCo :: Coercion -> Coercion -> Coercion -mkTransCo (Refl {}) co = co -mkTransCo co (Refl {}) = co -mkTransCo co1 co2 = TransCo co1 co2 +mkTransCo co1 (Refl {}) = co1 +mkTransCo (Refl {}) co2 = co2 +mkTransCo co1 co2 = TransCo co1 co2 -- the Role is the desired one. It is the caller's responsibility to make -- sure this request is reasonable @@ -1102,69 +843,99 @@ mkNthCoRole role n co nth_role = coercionRole nth_co mkNthCo :: Int -> Coercion -> Coercion -mkNthCo n (Refl r ty) = ASSERT( ok_tc_app ty n ) - Refl r' (tyConAppArgN n ty) +mkNthCo 0 (Refl _ ty) + | Just (tv, _) <- splitForAllTy_maybe ty + = Refl Nominal (tyVarKind tv) +mkNthCo n (Refl r ty) + = ASSERT( ok_tc_app ty n ) + mkReflCo r' (tyConAppArgN n ty) where tc = tyConAppTyCon ty r' = nthRole r tc n -mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) - NthCo n co - where - Pair _ty1 _ty2 = coercionKind co + ok_tc_app :: Type -> Int -> Bool + ok_tc_app ty n + | Just (_, tys) <- splitTyConApp_maybe ty + = tys `lengthExceeds` n + | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall + = n == 0 + | otherwise + = False + +mkNthCo n (TyConAppCo _ _ cos) = cos `getNth` n +mkNthCo n co = NthCo n co mkLRCo :: LeftOrRight -> Coercion -> Coercion mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty)) mkLRCo lr co = LRCo lr co -ok_tc_app :: Type -> Int -> Bool -ok_tc_app ty n = case splitTyConApp_maybe ty of - Just (_, tys) -> tys `lengthExceeds` n - Nothing -> False - --- | Instantiates a 'Coercion' with a 'Type' argument. -mkInstCo :: Coercion -> Type -> Coercion -mkInstCo co ty = InstCo co ty - --- | Manufacture an unsafe coercion from thin air. --- Currently (May 14) this is used only to implement the --- @unsafeCoerce#@ primitive. Optimise by pushing --- down through type constructors. -mkUnsafeCo :: Type -> Type -> Coercion -mkUnsafeCo = mkUnivCo (fsLit "mkUnsafeCo") Representational - -mkUnivCo :: FastString -> Role -> Type -> Type -> Coercion -mkUnivCo prov role ty1 ty2 - | ty1 `eqType` ty2 = Refl role ty1 - | otherwise = UnivCo prov role ty1 ty2 - -mkAxiomRuleCo :: CoAxiomRule -> [Type] -> [Coercion] -> Coercion -mkAxiomRuleCo = AxiomRuleCo +-- | Instantiates a 'Coercion'. +mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo (ForAllCo tv _kind_co body_co) (Refl _ arg) + = substCoWith [tv] [arg] body_co +mkInstCo co arg = InstCo co arg + +-- This could work harder to produce Refl coercions, but that would be +-- quite inefficient. Seems better not to try. +mkCoherenceCo :: Coercion -> Coercion -> Coercion +mkCoherenceCo co1 (Refl {}) = co1 +mkCoherenceCo (CoherenceCo co1 co2) co3 + = CoherenceCo co1 (co2 `mkTransCo` co3) +mkCoherenceCo co1 co2 = CoherenceCo co1 co2 + +-- | A CoherenceCo c1 c2 applies the coercion c2 to the left-hand type +-- in the kind of c1. This function uses sym to get the coercion on the +-- right-hand type of c1. Thus, if c1 :: s ~ t, then mkCoherenceRightCo c1 c2 +-- has the kind (s ~ (t |> c2)) down through type constructors. +-- The second coercion must be representational. +mkCoherenceRightCo :: Coercion -> Coercion -> Coercion +mkCoherenceRightCo c1 c2 = mkSymCo (mkCoherenceCo (mkSymCo c1) c2) + +-- | An explictly directed synonym of mkCoherenceCo. The second +-- coercion must be representational. +mkCoherenceLeftCo :: Coercion -> Coercion -> Coercion +mkCoherenceLeftCo = mkCoherenceCo + +infixl 5 `mkCoherenceCo` +infixl 5 `mkCoherenceRightCo` +infixl 5 `mkCoherenceLeftCo` + +mkKindCo :: Coercion -> Coercion +mkKindCo (Refl _ ty) = Refl Nominal (typeKind ty) +mkKindCo (UnivCo (PhantomProv h) _ _ _) = h +mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h +mkKindCo co + | Pair ty1 ty2 <- coercionKind co + -- generally, calling coercionKind during coercion creation is a bad idea, + -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, + -- so it's OK here. + , typeKind ty1 `eqType` typeKind ty2 + = Refl Nominal (typeKind ty1) + | otherwise + = KindCo co -- input coercion is Nominal; see also Note [Role twiddling functions] mkSubCo :: Coercion -> Coercion mkSubCo (Refl Nominal ty) = Refl Representational ty mkSubCo (TyConAppCo Nominal tc cos) = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (UnivCo s Nominal ty1 ty2) = UnivCo s Representational ty1 ty2 mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) SubCo co --- only *downgrades* a role. See Note [Role twiddling functions] -downgradeRole_maybe :: Role -- desired role - -> Role -- current role - -> Coercion - -> Maybe Coercion +-- | Changes a role, but only a downgrade. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- ^ desired role + -> Role -- ^ current role + -> Coercion -> Maybe Coercion -- In (downgradeRole_maybe dr cr co) it's a precondition that -- cr = coercionRole co downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) downgradeRole_maybe Nominal Representational _ = Nothing downgradeRole_maybe Phantom Phantom co = Just co -downgradeRole_maybe Phantom _ co = Just (mkPhantomCo co) +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) downgradeRole_maybe _ Phantom _ = Nothing downgradeRole_maybe _ _ co = Just co --- panics if the requested conversion is not a downgrade. --- See also Note [Role twiddling functions] +-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. +-- See Note [Role twiddling functions] downgradeRole :: Role -- desired role -> Role -- current role -> Coercion -> Coercion @@ -1173,49 +944,95 @@ downgradeRole r1 r2 co Just co' -> co' Nothing -> pprPanic "downgradeRole" (ppr co) --- Converts a coercion to be nominal, if possible. --- See also Note [Role twiddling functions] +-- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. +-- Note that the input coercion should always be nominal. +maybeSubCo :: EqRel -> Coercion -> Coercion +maybeSubCo NomEq = id +maybeSubCo ReprEq = mkSubCo + + +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomRuleCo = AxiomRuleCo + +-- | Make a "coercion between coercions". +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" + -> Coercion -- ^ :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Coercion -- ^ :: g1 ~r g2 + +-- if the two coercion prove the same fact, I just don't care what +-- the individual coercions are. +mkProofIrrelCo r (Refl {}) g _ = Refl r (CoercionTy g) +mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r + (mkCoercionTy g1) (mkCoercionTy g2) + +{- +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ +-} + +-- | Converts a coercion to be nominal, if possible. +-- See Note [Role twiddling functions] setNominalRole_maybe :: Coercion -> Maybe Coercion setNominalRole_maybe co | Nominal <- coercionRole co = Just co setNominalRole_maybe (SubCo co) = Just co setNominalRole_maybe (Refl _ ty) = Just $ Refl Nominal ty -setNominalRole_maybe (TyConAppCo Representational tc coes) - = do { cos' <- mapM setNominalRole_maybe coes +setNominalRole_maybe (TyConAppCo Representational tc cos) + = do { cos' <- mapM setNominalRole_maybe cos ; return $ TyConAppCo Nominal tc cos' } -setNominalRole_maybe (UnivCo s Representational ty1 ty2) = Just $ UnivCo s Nominal ty1 ty2 - -- We do *not* promote UnivCo Phantom, as that's unsafe. - -- UnivCo Nominal is no more unsafe than UnivCo Representational +setNominalRole_maybe (SymCo co) + = SymCo <$> setNominalRole_maybe co setNominalRole_maybe (TransCo co1 co2) = TransCo <$> setNominalRole_maybe co1 <*> setNominalRole_maybe co2 setNominalRole_maybe (AppCo co1 co2) = AppCo <$> setNominalRole_maybe co1 <*> pure co2 -setNominalRole_maybe (ForAllCo tv co) - = ForAllCo tv <$> setNominalRole_maybe co +setNominalRole_maybe (ForAllCo tv kind_co co) + = ForAllCo tv kind_co <$> setNominalRole_maybe co setNominalRole_maybe (NthCo n co) = NthCo n <$> setNominalRole_maybe co -setNominalRole_maybe (InstCo co ty) - = InstCo <$> setNominalRole_maybe co <*> pure ty +setNominalRole_maybe (InstCo co arg) + = InstCo <$> setNominalRole_maybe co <*> pure arg +setNominalRole_maybe (CoherenceCo co1 co2) + = CoherenceCo <$> setNominalRole_maybe co1 <*> pure co2 +setNominalRole_maybe (UnivCo prov _ co1 co2) + | case prov of UnsafeCoerceProv -> True -- it's always unsafe + PhantomProv _ -> False -- should always be phantom + ProofIrrelProv _ -> True -- it's always safe + PluginProv _ -> False -- who knows? This choice is conservative. + HoleProv _ -> False -- no no no. + = Just $ UnivCo prov Nominal co1 co2 setNominalRole_maybe _ = Nothing +-- | Make a phantom coercion between two types. The coercion passed +-- in must be a nominal coercion between the kinds of the +-- types. +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkPhantomCo h t1 t2 + = mkUnivCo (PhantomProv h) Phantom t1 t2 + +-- | Make a phantom coercion between two types of the same kind. +mkHomoPhantomCo :: Type -> Type -> Coercion +mkHomoPhantomCo t1 t2 + = ASSERT( k1 `eqType` typeKind t2 ) + mkPhantomCo (mkNomReflCo k1) t1 t2 + where + k1 = typeKind t1 + -- takes any coercion and turns it into a Phantom coercion -mkPhantomCo :: Coercion -> Coercion -mkPhantomCo co - | Just ty <- isReflCo_maybe co = Refl Phantom ty - | Pair ty1 ty2 <- coercionKind co = UnivCo (fsLit "mkPhantomCo") Phantom ty1 ty2 - -- don't optimise here... wait for OptCoercion - --- All input coercions are assumed to be Nominal, --- or, if Role is Phantom, the Coercion can be Phantom, too. -applyRole :: Role -> Coercion -> Coercion -applyRole Nominal = id -applyRole Representational = mkSubCo -applyRole Phantom = mkPhantomCo +toPhantomCo :: Coercion -> Coercion +toPhantomCo co + = mkPhantomCo (mkKindCo co) ty1 ty2 + where Pair ty1 ty2 = coercionKind co -- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational applyRoles :: TyCon -> [Coercion] -> [Coercion] applyRoles tc cos - = zipWith applyRole (tyConRolesX Representational tc) cos + = zipWith (\r -> downgradeRole r Nominal) (tyConRolesX Representational tc) cos -- the Role parameter is the Role of the TyConAppCo -- defined here because this is intimiately concerned with the implementation @@ -1228,7 +1045,7 @@ nthRole :: Role -> TyCon -> Int -> Role nthRole Nominal _ _ = Nominal nthRole Phantom _ _ = Phantom nthRole Representational tc n - = (tyConRolesX Representational tc) !! n + = (tyConRolesX Representational tc) `getNth` n ltRole :: Role -> Role -> Bool -- Is one role "less" than another? @@ -1239,7 +1056,144 @@ ltRole Representational _ = False ltRole Nominal Nominal = False ltRole Nominal _ = True +------------------------------- + +-- | like mkKindCo, but aggressively & recursively optimizes to avoid using +-- a KindCo constructor. The output role is nominal. +promoteCoercion :: Coercion -> Coercion + +-- First cases handles anything that should yield refl. +promoteCoercion co = case co of + + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- no later branch should return refl + -- The ASSERT( False )s throughout + -- are these cases explicitly, but they should never fire. + + Refl _ ty -> ASSERT( False ) + mkNomReflCo (typeKind ty) + + TyConAppCo _ tc args + | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args + -> co' + | otherwise + -> mkKindCo co + + AppCo co1 arg + | Just co' <- instCoercion (coercionKind (mkKindCo co1)) + (promoteCoercion co1) arg + -> co' + | otherwise + -> mkKindCo co + + ForAllCo _ _ g + -> promoteCoercion g + + CoVarCo {} + -> mkKindCo co + + AxiomInstCo {} + -> mkKindCo co + + UnivCo UnsafeCoerceProv _ t1 t2 + -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2) + UnivCo (PhantomProv kco) _ _ _ + -> kco + UnivCo (ProofIrrelProv kco) _ _ _ + -> kco + UnivCo (PluginProv _) _ _ _ + -> mkKindCo co + UnivCo (HoleProv _) _ _ _ + -> mkKindCo co + + SymCo g + -> mkSymCo (promoteCoercion g) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + NthCo n co1 + | Just (_, args) <- splitTyConAppCo_maybe co1 + , n < length args + -> promoteCoercion (args !! n) + + | Just _ <- splitForAllCo_maybe co + , n == 0 + -> ASSERT( False ) mkNomReflCo liftedTypeKind + + | otherwise + -> mkKindCo co + + LRCo lr co1 + | Just (lco, rco) <- splitAppCo_maybe co1 + -> case lr of + CLeft -> promoteCoercion lco + CRight -> promoteCoercion rco + + | otherwise + -> mkKindCo co + + InstCo g _ + -> promoteCoercion g + + CoherenceCo g h + -> mkSymCo h `mkTransCo` promoteCoercion g + + KindCo _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + AxiomRuleCo {} + -> mkKindCo co + + where + Pair ty1 ty2 = coercionKind co + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, +-- where @g' = promoteCoercion (h w)@. +-- fails if this is not possible, if @g@ coerces between a forall and an -> +-- or if second parameter has a representational role and can't be used +-- with an InstCo. The result role matches is representational. +instCoercion :: Pair Type -- type of the first coercion + -> Coercion -- ^ must be nominal + -> Coercion + -> Maybe Coercion +instCoercion (Pair lty rty) g w + | isForAllTy lty && isForAllTy rty + , Just w' <- setNominalRole_maybe w + = Just $ mkInstCo g w' + | isFunTy lty && isFunTy rty + = Just $ mkNthCo 1 g -- extract result type, which is the 2nd argument to (->) + | otherwise -- one forall, one funty... + = Nothing + where + +instCoercions :: Coercion -> [Coercion] -> Maybe Coercion +instCoercions g ws + = let arg_ty_pairs = map coercionKind ws in + snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) + where + go :: (Pair Type, Coercion) -> (Pair Type, Coercion) + -> Maybe (Pair Type, Coercion) + go (g_tys, g) (w_tys, w) + = do { g' <- instCoercion g_tys g w + ; return (piResultTy <$> g_tys <*> w_tys, g') } + +-- | Creates a new coercion with both of its types casted by different casts +-- castCoercionKind g h1 h2, where g :: t1 ~ t2, has type (t1 |> h1) ~ (t2 |> h2) +-- The second and third coercions must be nominal. +castCoercionKind :: Coercion -> Coercion -> Coercion -> Coercion +castCoercionKind g h1 h2 + = g `mkCoherenceLeftCo` h1 `mkCoherenceRightCo` h2 + -- See note [Newtype coercions] in TyCon + -- | Create a coercion constructor (axiom) suitable for the given -- newtype 'TyCon'. The 'Name' should be that of a new coercion -- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and @@ -1253,9 +1207,10 @@ mkNewTypeCo name tycon tvs roles rhs_ty , co_ax_role = Representational , co_ax_tc = tycon , co_ax_branches = unbranched branch } - where branch = CoAxBranch { cab_loc = getSrcSpan name - , cab_tvs = tvs - , cab_lhs = mkTyVarTys tvs + where branch = CoAxBranch { cab_loc = getSrcSpan name + , cab_tvs = tvs + , cab_cvs = [] + , cab_lhs = mkTyVarTys tvs , cab_roles = roles , cab_rhs = rhs_ty , cab_incomps = [] } @@ -1264,28 +1219,32 @@ mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs mkPiCo :: Role -> Var -> Coercion -> Coercion -mkPiCo r v co | isTyVar v = mkForAllCo v co +mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co | otherwise = mkFunCo r (mkReflCo r (varType v)) co --- The first coercion *must* be Nominal. +-- The second coercion is sometimes lifted (~) and sometimes unlifted (~#). +-- So, we have to make sure to supply the right parameter to decomposeCo. +-- mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# s2) ~# (t1 ~# t2)) :: s2 ~# t2 +-- Both coercions *must* have the same role. mkCoCast :: Coercion -> Coercion -> Coercion --- (mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# t1) ~# (s2 ~# t2) mkCoCast c g = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 where -- g :: (s1 ~# s2) ~# (t1 ~# t2) -- g1 :: s1 ~# t1 -- g2 :: s2 ~# t2 - [_reflk, g1, g2] = decomposeCo 3 g - -- Remember, (~#) :: forall k. k -> k -> * - -- so it takes *three* arguments, not two + (_, args) = splitTyConApp (pFst $ coercionKind g) + n_args = length args + co_list = decomposeCo n_args g + g1 = co_list `getNth` (n_args - 2) + g2 = co_list `getNth` (n_args - 1) {- -************************************************************************ -* * +%************************************************************************ +%* * Newtypes -* * -************************************************************************ +%* * +%************************************************************************ -} -- | If @co :: T ts ~ rep_ty@ then: @@ -1297,8 +1256,7 @@ instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) instNewTyCon_maybe tc tys | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype , tvs `leLength` tys -- Check saturated enough - = Just ( applyTysX tvs ty tys - , mkUnbranchedAxInstCo Representational co_tc tys) + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) | otherwise = Nothing @@ -1330,8 +1288,8 @@ modifyStepResultCo :: (Coercion -> Coercion) modifyStepResultCo f (NS_Step rec_nts ty co) = NS_Step rec_nts ty (f co) modifyStepResultCo _ result = result --- | Try one stepper and then try the next, --- if the first doesn't make progress. +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. -- So if it returns NS_Done, it means that both steppers are satisfied composeSteppers :: NormaliseStepper -> NormaliseStepper -> NormaliseStepper @@ -1383,9 +1341,9 @@ topNormaliseTypeX_maybe stepper topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) -- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. -- This function strips off @newtype@ layers enough to reveal something that isn't --- a @newtype@, or responds False to ok_tc. Specifically, here's the invariant: +-- a @newtype@. Specifically, here's the invariant: -- --- > topNormaliseNewType_maybe ty = Just (co, ty') +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') -- -- then (a) @co : ty0 ~ ty'@. -- (b) ty' is not a newtype. @@ -1397,242 +1355,32 @@ topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) -- the type family environment. If you do have that at hand, consider to use -- topNormaliseType_maybe, which should be a drop-in replacement for -- topNormaliseNewType_maybe --- topNormaliseNewType_maybe ty = topNormaliseTypeX_maybe unwrapNewTypeStepper ty {- -************************************************************************ -* * - Equality of coercions -* * -************************************************************************ +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ -} --- | Determines syntactic equality of coercions -coreEqCoercion :: Coercion -> Coercion -> Bool -coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2 - where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2)) - -coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool -coreEqCoercion2 env (Refl eq1 ty1) (Refl eq2 ty2) = eq1 == eq2 && eqTypeX env ty1 ty2 -coreEqCoercion2 env (TyConAppCo eq1 tc1 cos1) (TyConAppCo eq2 tc2 cos2) - = eq1 == eq2 && tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2 - -coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22) - = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 - -coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2) - = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2 - -coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2) - = rnOccL env cv1 == rnOccR env cv2 - -coreEqCoercion2 env (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) - = con1 == con2 - && ind1 == ind2 - && all2 (coreEqCoercion2 env) cos1 cos2 - --- the provenance string is just a note, so don't use in comparisons -coreEqCoercion2 env (UnivCo _ r1 ty11 ty12) (UnivCo _ r2 ty21 ty22) - = r1 == r2 && eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22 - -coreEqCoercion2 env (SymCo co1) (SymCo co2) - = coreEqCoercion2 env co1 co2 - -coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22) - = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 - -coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2) - = d1 == d2 && coreEqCoercion2 env co1 co2 -coreEqCoercion2 env (LRCo d1 co1) (LRCo d2 co2) - = d1 == d2 && coreEqCoercion2 env co1 co2 - -coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) - = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 - -coreEqCoercion2 env (SubCo co1) (SubCo co2) - = coreEqCoercion2 env co1 co2 - -coreEqCoercion2 env (AxiomRuleCo a1 ts1 cs1) (AxiomRuleCo a2 ts2 cs2) - = a1 == a2 && all2 (eqTypeX env) ts1 ts2 && all2 (coreEqCoercion2 env) cs1 cs2 - -coreEqCoercion2 _ _ _ = False - -{- -************************************************************************ -* * - Substitution of coercions -* * -************************************************************************ --} - --- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when --- doing a \"lifting\" substitution) -type CvSubstEnv = VarEnv Coercion - -emptyCvSubstEnv :: CvSubstEnv -emptyCvSubstEnv = emptyVarEnv - -data CvSubst - = CvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- Substitution of types - CvSubstEnv -- Substitution of coercions - -instance Outputable CvSubst where - ppr (CvSubst ins tenv cenv) - = brackets $ sep[ ptext (sLit "CvSubst"), - nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Type env:") <+> ppr tenv), - nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ] - -emptyCvSubst :: CvSubst -emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv - -isEmptyCvSubst :: CvSubst -> Bool -isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv - -getCvInScope :: CvSubst -> InScopeSet -getCvInScope (CvSubst in_scope _ _) = in_scope - -zapCvSubstEnv :: CvSubst -> CvSubst -zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv - -cvTvSubst :: CvSubst -> TvSubst -cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs - -tvCvSubst :: TvSubst -> CvSubst -tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv - -extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst -extendTvSubst (CvSubst in_scope tenv cenv) tv ty - = CvSubst in_scope (extendVarEnv tenv tv ty) cenv - -extendTvSubstAndInScope :: CvSubst -> TyVar -> Type -> CvSubst -extendTvSubstAndInScope (CvSubst in_scope tenv cenv) tv ty - = CvSubst (in_scope `extendInScopeSetSet` tyVarsOfType ty) - (extendVarEnv tenv tv ty) - cenv - -extendCvSubstAndInScope :: CvSubst -> CoVar -> Coercion -> CvSubst --- Also extends the in-scope set -extendCvSubstAndInScope (CvSubst in_scope tenv cenv) cv co - = CvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfCo co) - tenv - (extendVarEnv cenv cv co) +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType -substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar) -substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var - = ASSERT( isCoVar old_var ) - (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) - where - -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t) - -- In that case, mkCoVarCo will return a ReflCoercion, and - -- we want to substitute that (not new_var) for old_var - new_co = mkCoVarCo new_var - no_change = new_var == old_var && not (isReflCo new_co) - - new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var new_co - - new_var = uniqAway in_scope subst_old_var - subst_old_var = mkCoVar (varName old_var) (substTy subst (varType old_var)) - -- It's important to do the substitution for coercions, - -- because they can have free type variables - -substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) -substTyVarBndr (CvSubst in_scope tenv cenv) old_var - = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of - (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var) - -mkCvSubst :: InScopeSet -> [(Var,Coercion)] -> CvSubst -mkCvSubst in_scope prs = CvSubst in_scope Type.emptyTvSubstEnv (mkVarEnv prs) - -zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst -zipOpenCvSubst vs cos - | debugIsOn && (length vs /= length cos) - = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst - | otherwise - = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos) - -substCoWithTy :: InScopeSet -> TyVar -> Type -> Coercion -> Coercion -substCoWithTy in_scope tv ty = substCoWithTys in_scope [tv] [ty] - -substCoWithTys :: InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithTys in_scope tvs tys co - | debugIsOn && (length tvs /= length tys) - = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co - | otherwise - = ASSERT( length tvs == length tys ) - substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co - --- | Substitute within a 'Coercion' -substCo :: CvSubst -> Coercion -> Coercion -substCo subst co | isEmptyCvSubst subst = co - | otherwise = subst_co subst co - --- | Substitute within several 'Coercion's -substCos :: CvSubst -> [Coercion] -> [Coercion] -substCos subst cos | isEmptyCvSubst subst = cos - | otherwise = map (substCo subst) cos - -substTy :: CvSubst -> Type -> Type -substTy subst = Type.substTy (cvTvSubst subst) - -subst_co :: CvSubst -> Coercion -> Coercion -subst_co subst co - = go co - where - go_ty :: Type -> Type - go_ty = Coercion.substTy subst - - go :: Coercion -> Coercion - go (Refl eq ty) = Refl eq $! go_ty ty - go (TyConAppCo eq tc cos) = let args = map go cos - in args `seqList` TyConAppCo eq tc args - go (AppCo co1 co2) = mkAppCo (go co1) $! go co2 - go (ForAllCo tv co) = case substTyVarBndr subst tv of - (subst', tv') -> - ForAllCo tv' $! subst_co subst' co - go (CoVarCo cv) = substCoVar subst cv - go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! map go cos - go (UnivCo s r ty1 ty2) = (UnivCo s r $! go_ty ty1) $! go_ty ty2 - go (SymCo co) = mkSymCo (go co) - go (TransCo co1 co2) = mkTransCo (go co1) (go co2) - go (NthCo d co) = mkNthCo d (go co) - go (LRCo lr co) = mkLRCo lr (go co) - go (InstCo co ty) = mkInstCo (go co) $! go_ty ty - go (SubCo co) = mkSubCo (go co) - go (AxiomRuleCo co ts cs) = let ts1 = map go_ty ts - cs1 = map go cs - in ts1 `seqList` cs1 `seqList` - AxiomRuleCo co ts1 cs1 - - - -substCoVar :: CvSubst -> CoVar -> Coercion -substCoVar (CvSubst in_scope _ cenv) cv - | Just co <- lookupVarEnv cenv cv = co - | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 - | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope) - ASSERT( isCoVar cv ) CoVarCo cv - -substCoVars :: CvSubst -> [CoVar] -> [Coercion] -substCoVars subst cvs = map (substCoVar subst) cvs - -lookupTyVar :: CvSubst -> TyVar -> Maybe Type -lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv - -lookupCoVar :: CvSubst -> Var -> Maybe Coercion -lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType {- -************************************************************************ -* * +%************************************************************************ +%* * "Lifting" substitution - [(TyVar,Coercion)] -> Type -> Coercion -* * -************************************************************************ + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ Note [Lifting coercions over types: liftCoSubst] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1657,265 +1405,286 @@ The crucial operation is that we * and substitute g' for a thus giving *coercion*. This is what liftCoSubst does. -Note [Substituting kinds in liftCoSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to take care with kind polymorphism. Suppose - K :: forall k (a:k). (forall b:k. a -> b) -> T k a - -Now given (K @kk1 @ty1 v) |> g) where - g :: T kk1 ty1 ~ T kk2 ty2 -we want to compute - (forall b:k a->b) [ Nth 0 g/k, Nth 1 g/a ] -Notice that we MUST substitute for 'k'; this happens in -liftCoSubstTyVarBndr. But what should we substitute? -We need to take b's kind 'k' and return a Kind, not a Coercion! - -Happily we can do this because we know that all kind coercions -((Nth 0 g) in this case) are Refl. So we need a special purpose - subst_kind: LiftCoSubst -> Kind -> Kind -that expects a Refl coercion (or something equivalent to Refl) -when it looks up a kind variable. +In the presence of kind coercions, this is a bit +of a hairy operation. So, we refer you to the paper introducing kind coercions, +available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf -} -- ---------------------------------------------------- -- See Note [Lifting coercions over types: liftCoSubst] -- ---------------------------------------------------- -data LiftCoSubst = LCS InScopeSet LiftCoEnv +data LiftingContext = LC TCvSubst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in OptCoercion + -- We thus propagate the substitution from OptCoercion here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) type LiftCoEnv = VarEnv Coercion - -- Maps *type variables* to *coercions* + -- Maps *type variables* to *coercions*. -- That's the whole point of this function! -liftCoSubstWith :: Role -> [TyVar] -> [Coercion] -> Type -> Coercion +-- like liftCoSubstWith, but allows for existentially-bound types as well +liftCoSubstWithEx :: Role -- desired role for output coercion + -> [TyVar] -- universally quantified tyvars + -> [Coercion] -- coercions to substitute for those + -> [TyVar] -- existentially quantified tyvars + -> [Type] -- types to be bound to ex vars + -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) +liftCoSubstWithEx role univs omegas exs rhos + = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) + psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) + in (ty_co_subst psi role, substTyVars (lcSubstRight psi) exs) + +liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion +-- NB: This really can be called with CoVars, when optimising axioms. liftCoSubstWith r tvs cos ty - = liftCoSubst r (zipEqual "liftCoSubstWith" tvs cos) ty - -liftCoSubst :: Role -> [(TyVar,Coercion)] -> Type -> Coercion -liftCoSubst r prs ty - | null prs = Refl r ty - | otherwise = ty_co_subst (LCS (mkInScopeSet (tyCoVarsOfCos (map snd prs))) - (mkVarEnv prs)) r ty + = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty + +-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) +-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where +-- @lc_left@ is a substitution mapping type variables to the left-hand +-- types of the mapped coercions in @lc@, and similar for @lc_right@. +liftCoSubst :: Role -> LiftingContext -> Type -> Coercion +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = Refl r (substTy subst ty) + | otherwise = ty_co_subst lc r ty + +emptyLiftingContext :: InScopeSet -> LiftingContext +emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv + +mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext +mkLiftingContext pairs + = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + (mkVarEnv pairs) + +mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext subst = LC subst emptyVarEnv + +-- | Extend a lifting context with a new /type/ mapping. +extendLiftingContext :: LiftingContext -- ^ original LC + -> TyVar -- ^ new variable to map... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext +extendLiftingContext (LC subst env) tv arg + = ASSERT( isTyVar tv ) + LC subst (extendVarEnv env tv arg) + +-- | Extend a lifting context with existential-variable bindings. +-- This follows the lifting context extension definition in the +-- "FC with Explicit Kind Equality" paper. +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyVar,Type)] -- ^ ex. var / value pairs + -> LiftingContext +-- Note that this is more involved than extendLiftingContext. That function +-- takes a coercion to extend with, so it's assumed that the caller has taken +-- into account any of the kind-changing stuff worried about here. +extendLiftingContextEx lc [] = lc +extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) +-- This function adds bindings for *Nominal* coercions. Why? Because it +-- works with existentially bound variables, which are considered to have +-- nominal roles. + = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v (mkSymCo $ mkCoherenceCo + (mkNomReflCo ty) + (ty_co_subst lc Nominal (tyVarKind v)))) + in extendLiftingContextEx lc' rest + +-- | Erase the environments in a lifting context +zapLiftingContext :: LiftingContext -> LiftingContext +zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv + +-- | Like 'substForAllCoBndr', but works on a lifting context +substForAllCoBndrCallbackLC :: Bool + -> (Coercion -> Coercion) + -> LiftingContext -> TyVar -> Coercion + -> (LiftingContext, TyVar, Coercion) +substForAllCoBndrCallbackLC sym sco (LC subst lc_env) tv co + = (LC subst' lc_env, tv', co') + where + (subst', tv', co') = substForAllCoBndrCallback sym sco subst tv co -- | The \"lifting\" operation which substitutes coercions for type -- variables in a type to produce a coercion. -- -- For the inverse operation, see 'liftCoMatch' - --- The Role parameter is the _desired_ role -ty_co_subst :: LiftCoSubst -> Role -> Type -> Coercion -ty_co_subst subst role ty +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst lc role ty = go role ty where - go Phantom ty = lift_phantom ty - go role (TyVarTy tv) = liftCoSubstTyVar subst role tv - `orElse` Refl role (TyVarTy tv) - -- A type variable from a non-cloned forall - -- won't be in the substitution - go role (AppTy ty1 ty2) = mkAppCo (go role ty1) (go Nominal ty2) - go role (TyConApp tc tys) = mkTyConAppCo role tc - (zipWith go (tyConRolesX role tc) tys) - -- IA0_NOTE: Do we need to do anything - -- about kind instantiations? I don't think - -- so. see Note [Kind coercions] - go role (FunTy ty1 ty2) = mkFunCo role (go role ty1) (go role ty2) - go role (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' role ty) - where - (subst', v') = liftCoSubstTyVarBndr subst v - go role ty@(LitTy {}) = ASSERT( role == Nominal ) - mkReflCo role ty - - lift_phantom ty = mkUnivCo (fsLit "lift_phantom") - Phantom (liftCoSubstLeft subst ty) - (liftCoSubstRight subst ty) + go :: Role -> Type -> Coercion + go Phantom ty = lift_phantom ty + go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ + liftCoSubstTyVar lc r tv + go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) + go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) + go r (ForAllTy (Anon ty1) ty2) + = mkFunCo r (go r ty1) (go r ty2) + go r (ForAllTy (Named v _) ty) + = let (lc', v', h) = liftCoSubstVarBndr lc v in + mkForAllCo v' h $! ty_co_subst lc' r ty + go r ty@(LitTy {}) = ASSERT( r == Nominal ) + mkReflCo r ty + go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co) + (substRightCo lc co) + go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) + (substRightCo lc co) + where kco = go Nominal (coercionType co) + + lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) + (substTy (lcSubstLeft lc) ty) + (substTy (lcSubstRight lc) ty) {- Note [liftCoSubstTyVar] -~~~~~~~~~~~~~~~~~~~~~~~ -This function can fail (i.e., return Nothing) for two separate reasons: - 1) The variable is not in the substutition - 2) The coercion found is of too low a role +~~~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail if a coercion in the environment is of too low a role. liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting -lemma guarantees that the roles work out. If we fail for reason 2) in this +lemma guarantees that the roles work out. If we fail in this case, we really should panic -- something is deeply wrong. But, in matchAxiom, -failing for reason 2) is fine. matchAxiom is trying to find a set of coercions -that match, but it may fail, and this is healthy behavior. Bottom line: if -you find that liftCoSubst is doing weird things (like leaving out-of-scope -variables lying around), disable coercion optimization (bypassing matchAxiom) -and use downgradeRole instead of downgradeRole_maybe. The panic will then happen, -and you may learn something useful. +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. -} -liftCoSubstTyVar :: LiftCoSubst -> Role -> TyVar -> Maybe Coercion -liftCoSubstTyVar (LCS _ cenv) r tv - = do { co <- lookupVarEnv cenv tv - ; let co_role = coercionRole co -- could theoretically take this as - -- a parameter, but painful - ; downgradeRole_maybe r co_role co } -- see Note [liftCoSubstTyVar] +-- See Note [liftCoSubstTyVar] +liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LC subst env) r v + | Just co_arg <- lookupVarEnv env v + = downgradeRole_maybe r (coercionRole co_arg) co_arg -liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar) -liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var - = (LCS (in_scope `extendInScopeSet` new_var) new_cenv, new_var) + | otherwise + = Just $ Refl r (substTyVar subst v) + +liftCoSubstVarBndr :: LiftingContext -> TyVar + -> (LiftingContext, TyVar, Coercion) +liftCoSubstVarBndr lc tv + = let (lc', tv', h, _) = liftCoSubstVarBndrCallback callback lc tv in + (lc', tv', h) + where + callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrCallback :: (LiftingContext -> Type -> (Coercion, a)) + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, Coercion, a) +liftCoSubstVarBndrCallback fun lc@(LC subst cenv) old_var + = ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, eta, stuff ) where - new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var (Refl Nominal (TyVarTy new_var)) + old_kind = tyVarKind old_var + (eta, stuff) = fun lc old_kind + Pair k1 _ = coercionKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - no_change = no_kind_change && (new_var == old_var) + lifted = Refl Nominal (TyVarTy new_var) + new_cenv = extendVarEnv cenv old_var lifted - new_var1 = uniqAway in_scope old_var +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env - old_ki = tyVarKind old_var - no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) - new_var | no_kind_change = new_var1 - | otherwise = setTyVarKind new_var1 (subst_kind subst old_ki) +-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 +-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 +substLeftCo :: LiftingContext -> Coercion -> Coercion +substLeftCo lc co + = substCo (lcSubstLeft lc) co --- map every variable to the type on the *left* of its mapped coercion -liftCoSubstLeft :: LiftCoSubst -> Type -> Type -liftCoSubstLeft (LCS in_scope cenv) ty - = Type.substTy (mkTvSubst in_scope (mapVarEnv (pFst . coercionKind) cenv)) ty +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co --- same, but to the type on the right -liftCoSubstRight :: LiftCoSubst -> Type -> Type -liftCoSubstRight (LCS in_scope cenv) ty - = Type.substTy (mkTvSubst in_scope (mapVarEnv (pSnd . coercionKind) cenv)) ty +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo -subst_kind :: LiftCoSubst -> Kind -> Kind --- See Note [Substituting kinds in liftCoSubst] -subst_kind subst@(LCS _ cenv) kind - = go kind - where - go (LitTy n) = n `seq` LitTy n - go (TyVarTy kv) = subst_kv kv - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - go (ForAllTy tv ty) = case liftCoSubstTyVarBndr subst tv of - (subst', tv') -> - ForAllTy tv' $! (subst_kind subst' ty) - - subst_kv kv - | Just co <- lookupVarEnv cenv kv - , let co_kind = coercionKind co - = ASSERT2( pFst co_kind `eqKind` pSnd co_kind, ppr kv $$ ppr co ) - pFst co_kind - | otherwise - = TyVarTy kv - --- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if --- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@. --- That is, it matches a type against a coercion of the same --- "shape", and returns a lifting substitution which could have been --- used to produce the given coercion from the given type. -liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe LiftCoSubst -liftCoMatch tmpls ty co - = case ty_co_match menv emptyVarEnv ty co of - Just cenv -> Just (LCS in_scope cenv) - Nothing -> Nothing - where - menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } - in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) - -- Like tcMatchTy, assume all the interesting variables - -- in ty are in tmpls - --- | 'ty_co_match' does all the actual work for 'liftCoMatch'. -ty_co_match :: MatchEnv -> LiftCoEnv -> Type -> Coercion -> Maybe LiftCoEnv -ty_co_match menv subst ty co - | Just ty' <- coreView ty = ty_co_match menv subst ty' co - - -- Match a type variable against a non-refl coercion -ty_co_match menv cenv (TyVarTy tv1) co - | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1 - = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co - then Just cenv - else Nothing -- no match since tv1 matches two different coercions - - | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var - = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co)) - then Nothing -- occurs check failed - else return (extendVarEnv cenv tv1' co) - -- BAY: I don't think we need to do any kind matching here yet - -- (compare 'match'), but we probably will when moving to SHE. - - | otherwise -- tv1 is not a template ty var, so the only thing it - -- can match is a reflexivity coercion for itself. - -- But that case is dealt with already - = Nothing +lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env - where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - -ty_co_match menv subst (AppTy ty1 ty2) co - | Just (co1, co2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy - = do { subst' <- ty_co_match menv subst ty1 co1 - ; ty_co_match menv subst' ty2 co2 } +lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env -ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) - | tc1 == tc2 = ty_co_matches menv subst tys cos +liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft = liftEnvSubst pFst -ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo _ tc cos) - | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos +liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight = liftEnvSubst pSnd -ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) - = ty_co_match menv' subst ty co +liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst selector subst lc_env + = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst where - menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } - -ty_co_match menv subst ty co - | Just co' <- pushRefl co = ty_co_match menv subst ty co' - | otherwise = Nothing + pairs = varEnvToList lc_env + (tpairs, cpairs) = partitionWith ty_or_co pairs + tenv = mkVarEnv_Directly tpairs + cenv = mkVarEnv_Directly cpairs + + ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) + ty_or_co (u, co) + | Just equality_co <- isCoercionTy_maybe equality_ty + = Right (u, equality_co) + | otherwise + = Left (u, equality_ty) + where + equality_ty = selector (coercionKind co) -ty_co_matches :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEnv -ty_co_matches menv = matchList (ty_co_match menv) +-- | Extract the underlying substitution from the LiftingContext +lcTCvSubst :: LiftingContext -> TCvSubst +lcTCvSubst (LC subst _) = subst -pushRefl :: Coercion -> Maybe Coercion -pushRefl (Refl Nominal (AppTy ty1 ty2)) - = Just (AppCo (Refl Nominal ty1) (Refl Nominal ty2)) -pushRefl (Refl r (FunTy ty1 ty2)) - = Just (TyConAppCo r funTyCon [Refl r ty1, Refl r ty2]) -pushRefl (Refl r (TyConApp tc tys)) - = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) -pushRefl (Refl r (ForAllTy tv ty)) = Just (ForAllCo tv (Refl r ty)) -pushRefl _ = Nothing +-- | Get the 'InScopeSet' from a 'LiftingContext' +lcInScopeSet :: LiftingContext -> InScopeSet +lcInScopeSet (LC subst _) = getTCvInScope subst {- -************************************************************************ -* * +%************************************************************************ +%* * Sequencing on coercions -* * -************************************************************************ +%* * +%************************************************************************ -} seqCo :: Coercion -> () -seqCo (Refl eq ty) = eq `seq` seqType ty -seqCo (TyConAppCo eq tc cos) = eq `seq` tc `seq` seqCos cos +seqCo (Refl r ty) = r `seq` seqType ty +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv co) = seqType (tyVarKind tv) `seq` seqCo co +seqCo (ForAllCo tv k co) = seqType (tyVarKind tv) `seq` seqCo k + `seq` seqCo co seqCo (CoVarCo cv) = cv `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnivCo s r ty1 ty2) = s `seq` r `seq` seqType ty1 `seq` seqType ty2 +seqCo (UnivCo p r t1 t2) + = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 seqCo (SymCo co) = seqCo co seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (NthCo n co) = n `seq` seqCo co seqCo (LRCo lr co) = lr `seq` seqCo co -seqCo (InstCo co ty) = seqCo co `seq` seqType ty +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (CoherenceCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (KindCo co) = seqCo co seqCo (SubCo co) = seqCo co -seqCo (AxiomRuleCo _ ts cs) = seqTypes ts `seq` seqCos cs +seqCo (AxiomRuleCo _ cs) = seqCos cs + +seqProv :: UnivCoProvenance -> () +seqProv UnsafeCoerceProv = () +seqProv (PhantomProv co) = seqCo co +seqProv (ProofIrrelProv co) = seqCo co +seqProv (PluginProv _) = () +seqProv (HoleProv _) = () seqCos :: [Coercion] -> () seqCos [] = () seqCos (co:cos) = seqCo co `seq` seqCos cos {- -************************************************************************ -* * +%************************************************************************ +%* * The kind of a type, and of a coercion -* * -************************************************************************ +%* * +%************************************************************************ Note [Computing a coercion kind and role] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1933,7 +1702,7 @@ the kind is all you want. coercionType :: Coercion -> Type coercionType co = case coercionKindRole co of - (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 ------------------ -- | If it is the case that @@ -1945,35 +1714,63 @@ coercionType co = case coercionKindRole co of coercionKind :: Coercion -> Pair Type coercionKind co = go co where - go (Refl _ ty) = Pair ty ty - go (TyConAppCo _ tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos) - go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 - go (ForAllCo tv co) = mkForAllTy tv <$> go co - go (CoVarCo cv) = toPair $ coVarKind cv + go (Refl _ ty) = Pair ty ty + go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) + go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 + go (ForAllCo tv1 k_co co) + = let Pair _ k2 = go k_co + tv2 = setTyVarKind tv1 k2 + Pair ty1 ty2 = go co + ty2' = substTyWith [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo k_co] ty2 in + mkNamedForAllTy <$> Pair tv1 tv2 <*> pure Invisible <*> Pair ty1 ty2' + go (CoVarCo cv) = toPair $ coVarTypes cv go (AxiomInstCo ax ind cos) - | CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind - , Pair tys1 tys2 <- sequenceA (map go cos) - = ASSERT( cos `equalLength` tvs ) -- Invariant of AxiomInstCo: cos should - -- exactly saturate the axiom branch - Pair (substTyWith tvs tys1 (mkTyConApp (coAxiomTyCon ax) lhs)) - (substTyWith tvs tys2 rhs) - go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 - go (SymCo co) = swap $ go co - go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) - go (NthCo d co) = tyConAppArgN d <$> go co - go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co - go (InstCo aco ty) = go_app aco [ty] - go (SubCo co) = go co - go (AxiomRuleCo ax tys cos) = - case coaxrProves ax tys (map go cos) of - Just res -> res - Nothing -> panic "coercionKind: Malformed coercion" - - go_app :: Coercion -> [Type] -> Pair Type + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind + , let Pair tycos1 tycos2 = sequenceA (map go cos) + (tys1, cotys1) = splitAtList tvs tycos1 + (tys2, cotys2) = splitAtList tvs tycos2 + cos1 = map stripCoercionTy cotys1 + cos2 = map stripCoercionTy cotys2 + = ASSERT( cos `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + Pair (substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + mkTyConApp (coAxiomTyCon ax) lhs) + (substTyWith tvs tys2 $ + substTyWithCoVars cvs cos2 rhs) + go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 + go (SymCo co) = swap $ go co + go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) + go g@(NthCo d co) + | Just argss <- traverse tyConAppArgs_maybe tys + = ASSERT( and $ ((d <) . length) <$> argss ) + (`getNth` d) <$> argss + + | d == 0 + , Just splits <- traverse splitForAllTy_maybe tys + = (tyVarKind . fst) <$> splits + + | otherwise + = pprPanic "coercionKind" (ppr g) + where + tys = go co + go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co + go (InstCo aco arg) = go_app aco [arg] + go (CoherenceCo g h) + = let Pair ty1 ty2 = go g in + Pair (mkCastTy ty1 h) ty2 + go (KindCo co) = typeKind <$> go co + go (SubCo co) = go co + go (AxiomRuleCo ax cos) = expectJust "coercionKind" $ + coaxrProves ax (map go cos) + + go_app :: Coercion -> [Coercion] -> Pair Type -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] - go_app (InstCo co ty) tys = go_app co (ty:tys) - go_app co tys = (`applyTys` tys) <$> go co + go_app (InstCo co arg) args = go_app co (arg:args) + go_app co args = applyTys <$> go co <*> (sequenceA $ map go args) -- | Apply 'coercionKind' to multiple 'Coercion's coercionKinds :: [Coercion] -> Pair [Type] @@ -1990,35 +1787,50 @@ coercionKindRole = go go (AppCo co1 co2) = let (tys1, r1) = go co1 in (mkAppTy <$> tys1 <*> coercionKind co2, r1) - go (ForAllCo tv co) - = let (tys, r) = go co in - (mkForAllTy tv <$> tys, r) - go (CoVarCo cv) = (toPair $ coVarKind cv, coVarRole cv) + go (ForAllCo tv1 k_co co) + = let Pair _ k2 = coercionKind k_co + tv2 = setTyVarKind tv1 k2 + (Pair ty1 ty2, r) = go co + ty2' = substTyWith [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo k_co] ty2 in + (mkNamedForAllTy <$> Pair tv1 tv2 <*> pure Invisible <*> Pair ty1 ty2', r) + go (CoVarCo cv) = (toPair $ coVarTypes cv, coVarRole cv) go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax) - go (UnivCo _ r ty1 ty2) = (Pair ty1 ty2, r) + go (UnivCo _ r ty1 ty2) = (Pair ty1 ty2, r) go (SymCo co) = first swap $ go co go (TransCo co1 co2) = let (tys1, r) = go co1 in (Pair (pFst tys1) (pSnd $ coercionKind co2), r) go (NthCo d co) - = let (Pair t1 t2, r) = go co - (tc1, args1) = splitTyConApp t1 - (_tc2, args2) = splitTyConApp t2 + | Just (tv1, _) <- splitForAllTy_maybe ty1 + = ASSERT( d == 0 ) + let (tv2, _) = splitForAllTy ty2 in + (tyVarKind <$> Pair tv1 tv2, Nominal) + + | otherwise + = let (tc1, args1) = splitTyConApp ty1 + (_tc2, args2) = splitTyConApp ty2 in ASSERT( tc1 == _tc2 ) ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d) + + where + (Pair ty1 ty2, r) = go co go co@(LRCo {}) = (coercionKind co, Nominal) - go (InstCo co ty) = go_app co [ty] + go (InstCo co arg) = go_app co [arg] + go (CoherenceCo co1 co2) + = let (Pair t1 t2, r) = go co1 in + (Pair (t1 `mkCastTy` co2) t2, r) + go co@(KindCo {}) = (coercionKind co, Nominal) go (SubCo co) = (coercionKind co, Representational) - go co@(AxiomRuleCo ax _ _) = (coercionKind co, coaxrRole ax) + go co@(AxiomRuleCo ax _) = (coercionKind co, coaxrRole ax) - go_app :: Coercion -> [Type] -> (Pair Type, Role) + go_app :: Coercion -> [Coercion] -> (Pair Type, Role) -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] - go_app (InstCo co ty) tys = go_app co (ty:tys) - go_app co tys + go_app (InstCo co arg) args = go_app co (arg:args) + go_app co args = let (pair, r) = go co in - ((`applyTys` tys) <$> pair, r) + (applyTys <$> pair <*> (sequenceA $ map coercionKind args), r) -- | Retrieve the role from a coercion. coercionRole :: Coercion -> Role @@ -2042,18 +1854,5 @@ But this is a *quadratic* algorithm, and the blew up Trac #5631. So it's very important to do the substitution simultaneously. cf Type.applyTys (which in fact we call here) --} -applyCo :: Type -> Coercion -> Type --- Gives the type of (e co) where e :: (a~b) => ty -applyCo ty co | Just ty' <- coreView ty = applyCo ty' co -applyCo (FunTy _ ty) _ = ty -applyCo _ _ = panic "applyCo" - -{- -Note [Kind coercions] -~~~~~~~~~~~~~~~~~~~~~ -Kind coercions are only of the form: Refl kind. They are only used to -instantiate kind polymorphic type constructors in TyConAppCo. Remember -that kind instantiation only happens with TyConApp, not AppTy. -} diff --git a/compiler/types/Coercion.hs-boot b/compiler/types/Coercion.hs-boot new file mode 100644 index 0000000000..29f814a628 --- /dev/null +++ b/compiler/types/Coercion.hs-boot @@ -0,0 +1,46 @@ +module Coercion where + +import {-# SOURCE #-} TyCoRep +import {-# SOURCE #-} TyCon + +import CoAxiom +import Var +import Outputable +import Pair + +mkReflCo :: Role -> Type -> Coercion +mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion +mkAppCo :: Coercion -> Coercion -> Coercion +mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion +mkCoVarCo :: CoVar -> Coercion +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkUnsafeCo :: Role -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkSymCo :: Coercion -> Coercion +mkTransCo :: Coercion -> Coercion -> Coercion +mkNthCo :: Int -> Coercion -> Coercion +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkInstCo :: Coercion -> Coercion -> Coercion +mkCoherenceCo :: Coercion -> Coercion -> Coercion +mkKindCo :: Coercion -> Coercion +mkSubCo :: Coercion -> Coercion +mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion + +mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion + +isReflCo :: Coercion -> Bool +coVarKindsTypesRole :: CoVar -> (Kind, Kind, Type, Type, Role) +coVarRole :: CoVar -> Role + +mkCoercionType :: Role -> Type -> Type -> Type + +data LiftingContext +liftCoSubst :: Role -> LiftingContext -> Type -> Coercion +coercionSize :: Coercion -> Int +seqCo :: Coercion -> () + +coercionKind :: Coercion -> Pair Type +coercionType :: Coercion -> Type + +pprCo :: Coercion -> SDoc diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index a60b1c231c..b5d3c21d0a 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -30,7 +30,7 @@ module FamInstEnv ( -- Normalisation topNormaliseType, topNormaliseType_maybe, normaliseType, normaliseTcApp, - reduceTyFamApp_maybe, chooseBranch, + reduceTyFamApp_maybe, -- Flattening flattenTys @@ -42,13 +42,14 @@ import InstEnv import Unify import Type import TcType ( orphNamesOfTypes ) -import TypeRep +import TyCoRep import TyCon import Coercion import CoAxiom import VarSet import VarEnv import Name +import PrelNames ( eqPrimTyConKey ) import UniqFM import Outputable import Maybes @@ -60,6 +61,8 @@ import Pair import SrcLoc import NameSet import FastString +import MonadUtils +import Control.Monad import Data.Function ( on ) {- @@ -107,8 +110,11 @@ data FamInst -- See Note [FamInsts and CoAxioms] -- See Note [Template tyvars are fresh] in InstEnv -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom - , fi_tys :: [Type] -- The LHS type patterns - -- May be eta-reduced; see Note [Eta reduction for data families] + , fi_cvs :: [CoVar] -- Template covars for full match + + , fi_tys :: [Type] -- The LHS type patterns + -- May be eta-reduced; see Note [Eta reduction for data families] + , fi_rhs :: Type -- the RHS, with its freshened vars } @@ -285,6 +291,7 @@ mkImportedFamInst fam mb_tcs axiom fi_fam = fam, fi_tcs = mb_tcs, fi_tvs = tvs, + fi_cvs = cvs, fi_tys = tys, fi_rhs = rhs, fi_axiom = axiom, @@ -293,6 +300,7 @@ mkImportedFamInst fam mb_tcs axiom -- See Note [Lazy axiom match] ~(CoAxBranch { cab_lhs = tys , cab_tvs = tvs + , cab_cvs = cvs , cab_rhs = rhs }) = coAxiomSingleBranch axiom -- Derive the flavor for an imported FamInst rather disgustingly @@ -593,19 +601,22 @@ Instead we must tidy those kind variables. See Trac #7524. -- all axiom roles are Nominal, as this is only used with type families mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [CoVar] -- possibly stale covars -> [Type] -- LHS patterns -> Type -- RHS -> SrcSpan -> CoAxBranch -mkCoAxBranch tvs lhs rhs loc +mkCoAxBranch tvs cvs lhs rhs loc = CoAxBranch { cab_tvs = tvs1 + , cab_cvs = cvs1 , cab_lhs = tidyTypes env lhs , cab_roles = map (const Nominal) tvs1 , cab_rhs = tidyType env rhs , cab_loc = loc , cab_incomps = placeHolderIncomps } where - (env, tvs1) = tidyTyVarBndrs emptyTidyEnv tvs + (env1, tvs1) = tidyTyCoVarBndrs emptyTidyEnv tvs + (env, cvs1) = tidyTyCoVarBndrs env1 cvs -- See Note [Tidy axioms when we build them] -- all of the following code is here to avoid mutual dependencies with @@ -630,12 +641,12 @@ mkUnbranchedCoAxiom ax_name fam_tc branch , co_ax_branches = unbranched (branch { cab_incomps = [] }) } mkSingleCoAxiom :: Role -> Name - -> [TyVar] -> TyCon -> [Type] -> Type + -> [TyVar] -> [CoVar] -> TyCon -> [Type] -> Type -> CoAxiom Unbranched -- Make a single-branch CoAxiom, incluidng making the branch itself -- Used for both type family (Nominal) and data family (Representational) -- axioms, hence passing in the Role -mkSingleCoAxiom role ax_name tvs fam_tc lhs_tys rhs_ty +mkSingleCoAxiom role ax_name tvs cvs fam_tc lhs_tys rhs_ty = CoAxiom { co_ax_unique = nameUnique ax_name , co_ax_name = ax_name , co_ax_tc = fam_tc @@ -643,7 +654,7 @@ mkSingleCoAxiom role ax_name tvs fam_tc lhs_tys rhs_ty , co_ax_implicit = False , co_ax_branches = unbranched (branch { cab_incomps = [] }) } where - branch = mkCoAxBranch tvs lhs_tys rhs_ty (getSrcSpan ax_name) + branch = mkCoAxBranch tvs cvs lhs_tys rhs_ty (getSrcSpan ax_name) {- ************************************************************************ @@ -674,13 +685,15 @@ we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. -- and the list of types the axiom should be applied to data FamInstMatch = FamInstMatch { fim_instance :: FamInst , fim_tys :: [Type] + , fim_cos :: [Coercion] } -- See Note [Over-saturated matches] instance Outputable FamInstMatch where ppr (FamInstMatch { fim_instance = inst - , fim_tys = tys }) - = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys + , fim_tys = tys + , fim_cos = cos }) + = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys <+> ppr cos lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc @@ -719,7 +732,7 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) -- In example above, fam tys' = F [b] my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ - = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, (ppr fam <+> ppr tys) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap @@ -880,7 +893,7 @@ Note [Family instance overlap conflicts] type MatchFun = FamInst -- The FamInst template -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst -> [Type] -- Target to match against - -> Maybe TvSubst + -> Maybe TCvSubst lookup_fam_inst_env' -- The worker, local to this module :: MatchFun @@ -895,8 +908,8 @@ lookup_fam_inst_env' match_fun ie fam match_tys where find [] = [] - find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, - fi_tys = tpl_tys }) : rest) + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) : rest) -- Fast check for no match, uses the "rough match" fields | instanceCantMatch rough_tcs mb_tcs = find rest @@ -904,7 +917,10 @@ lookup_fam_inst_env' match_fun ie fam match_tys -- Proper check | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 = (FamInstMatch { fim_instance = item - , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 }) + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 + , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + substCoVars subst tpl_cvs + }) : find rest -- No match => try next @@ -1012,68 +1028,76 @@ reduceTyFamApp_maybe :: FamInstEnvs -- -- The TyCon can be oversaturated. -- Works on both open and closed families - +-- +-- Always returns a *homogeneous* coercion -- type family reductions are always +-- homogeneous reduceTyFamApp_maybe envs role tc tys | Phantom <- role = Nothing | case role of - Representational -> isOpenFamilyTyCon tc - _ -> isOpenTypeFamilyTyCon tc + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc -- If we seek a representational coercion -- (e.g. the call in topNormaliseType_maybe) then we can -- unwrap data families as well as type-synonym families; -- otherwise only type-synonym families - , FamInstMatch { fim_instance = fam_inst - , fim_tys = inst_tys } : _ <- lookupFamInstEnv envs tc tys + , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } + , fim_tys = inst_tys + , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys -- NB: Allow multiple matches because of compatible overlap - = let ax = famInstAxiom fam_inst - co = mkUnbranchedAxInstCo role ax inst_tys - ty = pSnd (coercionKind co) + + = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos + ty = pSnd (coercionKind co) in Just (co, ty) | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc - , Just (ind, inst_tys) <- chooseBranch ax tys - = let co = mkAxInstCo role ax ind inst_tys - ty = pSnd (coercionKind co) + , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys inst_cos + ty = pSnd (coercionKind co) in Just (co, ty) | Just ax <- isBuiltInSynFamTyCon_maybe tc , Just (coax,ts,ty) <- sfMatchFam ax tys - = let co = mkAxiomRuleCo coax ts [] + = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) in Just (co, ty) | otherwise = Nothing -- The axiom can be oversaturated. (Closed families only.) -chooseBranch :: CoAxiom Branched -> [Type] -> Maybe (BranchIndex, [Type]) +chooseBranch :: CoAxiom Branched -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args chooseBranch axiom tys = do { let num_pats = coAxiomNumPats axiom (target_tys, extra_tys) = splitAt num_pats tys branches = coAxiomBranches axiom - ; (ind, inst_tys) <- findBranch (fromBranches branches) target_tys - ; return (ind, inst_tys ++ extra_tys) } + ; (ind, inst_tys, inst_cos) + <- findBranch (fromBranches branches) target_tys + ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } -- The axiom must *not* be oversaturated findBranch :: [CoAxBranch] -- branches to check -> [Type] -- target types - -> Maybe (BranchIndex, [Type]) + -> Maybe (BranchIndex, [Type], [Coercion]) + -- coercions relate requested types to returned axiom LHS at role N findBranch branches target_tys = go 0 branches where - go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_lhs = tpl_lhs + go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs + , cab_lhs = tpl_lhs , cab_incomps = incomps }) : rest) = let in_scope = mkInScopeSet (unionVarSets $ - map (tyVarsOfTypes . coAxBranchLHS) incomps) + map (tyCoVarsOfTypes . coAxBranchLHS) incomps) -- See Note [Flattening] below flattened_target = flattenTys in_scope target_tys - in case tcMatchTys (mkVarSet tpl_tvs) tpl_lhs target_tys of + in case tcMatchTys (mkVarSet (tpl_tvs ++ tpl_cvs)) tpl_lhs target_tys of Just subst -- matching worked. now, check for apartness. | apartnessCheck flattened_target branch -> -- matching worked & we're apart from all incompatible branches. -- success - Just (ind, substTyVars subst tpl_tvs) + ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + Just (ind, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) -- failure. keep looking _ -> go (ind+1) rest @@ -1106,6 +1130,46 @@ apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) Looking up a family instance * * ************************************************************************ + +Note [Normalising types] +~~~~~~~~~~~~~~~~~~~~~~~~ +The topNormaliseType function removes all occurrences of type families +and newtypes from the top-level structure of a type. normaliseTcApp does +the type family lookup and is fairly straightforward. normaliseType is +a little more involved. + +The complication comes from the fact that a type family might be used in the +kind of a variable bound in a forall. We wish to remove this type family +application, but that means coming up with a fresh variable (with the new +kind). Thus, we need a substitution to be built up as we recur through the +type. However, an ordinary TCvSubst just won't do: when we hit a type variable +whose kind has changed during normalisation, we need both the new type +variable *and* the coercion. We could conjure up a new VarEnv with just this +property, but a usable substitution environment already exists: +LiftingContexts from the liftCoSubst family of functions, defined in Coercion. +A LiftingContext maps a type variable to a coercion and a coercion variable to +a pair of coercions. Let's ignore coercion variables for now. Because the +coercion a type variable maps to contains the destination type (via +coercionKind), we don't need to store that destination type separately. Thus, +a LiftingContext has what we need: a map from type variables to (Coercion, +Type) pairs. + +We also benefit because we can piggyback on the liftCoSubstVarBndr function to +deal with binders. However, I had to modify that function to work with this +application. Thus, we now have liftCoSubstVarBndrCallback, which takes +a function used to process the kind of the binder. We don't wish +to lift the kind, but instead normalise it. So, we pass in a callback function +that processes the kind of the binder. + +After that brilliant explanation of all this, I'm sure you've forgotten the +dangling reference to coercion variables. What do we do with those? Nothing at +all. The point of normalising types is to remove type family applications, but +there's no sense in removing these from coercions. We would just get back a +new coercion witnessing the equality between the same types as the original +coercion. Because coercions are irrelevant anyway, there is no point in doing +this. So, whenever we encounter a coercion, we just say that it won't change. +That's what the CoercionTy case is doing within normalise_type. + -} topNormaliseType :: FamInstEnvs -> Type -> Type @@ -1137,70 +1201,179 @@ topNormaliseType_maybe env ty tyFamStepper rec_nts tc tys -- Try to step a type/data familiy = let (args_co, ntys) = normaliseTcArgs env Representational tc tys in + -- NB: It's OK to use normaliseTcArgs here instead of + -- normalise_tc_args (which takes the LiftingContext described + -- in Note [Normalising types]) because the reduceTyFamApp below + -- works only at top level. We'll never recur in this function + -- after reducing the kind of a bound tyvar. + case reduceTyFamApp_maybe env Representational tc ntys of Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co) - Nothing -> NS_Done + _ -> NS_Done --------------- normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) -- See comments on normaliseType for the arguments of this function normaliseTcApp env role tc tys - | isTypeSynonymTyCon tc - , Just (tenv, rhs, ntys') <- expandSynTyCon_maybe tc ntys - , (co2, ninst_rhs) <- normaliseType env role (Type.substTy (mkTopTvSubst tenv) rhs) - = if isReflCo co2 then (args_co, mkTyConApp tc ntys) - else (args_co `mkTransCo` co2, mkAppTys ninst_rhs ntys') - - | Just (first_co, ty') <- reduceTyFamApp_maybe env role tc ntys - , (rest_co,nty) <- normaliseType env role ty' - = (args_co `mkTransCo` first_co `mkTransCo` rest_co, nty) - - | otherwise -- No unique matching family instance exists; + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_app tc tys + +-- See Note [Normalising types] about the LiftingContext +normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) +normalise_tc_app tc tys + = do { (args_co, ntys) <- normalise_tc_args tc tys + ; case expandSynTyCon_maybe tc ntys of + { Just (tenv, rhs, ntys') -> + do { (co2, ninst_rhs) + <- normalise_type (substTy (mkTopTCvSubst tenv) rhs) + ; return $ + if isReflCo co2 + then (args_co, mkTyConApp tc ntys) + else (args_co `mkTransCo` co2, mkAppTys ninst_rhs ntys') } + ; Nothing -> + do { env <- getEnv + ; role <- getRole + ; case reduceTyFamApp_maybe env role tc ntys of + Just (first_co, ty') + -> do { (rest_co,nty) <- normalise_type ty' + ; return ( args_co `mkTransCo` first_co `mkTransCo` rest_co + , nty ) } + _ -> -- No unique matching family instance exists; -- we do not do anything - = (args_co, mkTyConApp tc ntys) - - where - (args_co, ntys) = normaliseTcArgs env role tc tys - + return (args_co, mkTyConApp tc ntys) }}} --------------- -normaliseTcArgs :: FamInstEnvs -- environment with family instances - -> Role -- desired role of output coercion - -> TyCon -> [Type] -- tc tys - -> (Coercion, [Type]) -- (co, new_tys), where - -- co :: tc tys ~ tc new_tys +-- | Normalise arguments to a tycon +normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances + -> Role -- ^ desired role of output coercion + -> TyCon -- ^ tc + -> [Type] -- ^ tys + -> (Coercion, [Type]) -- ^ co :: tc tys ~ tc new_tys normaliseTcArgs env role tc tys - = (mkTyConAppCo role tc cois, ntys) + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_args tc tys + +normalise_tc_args :: TyCon -> [Type] -- tc tys + -> NormM (Coercion, [Type]) -- (co, new_tys), where + -- co :: tc tys ~ tc new_tys +normalise_tc_args tc tys + = do { role <- getRole + ; (cois, ntys) <- zipWithAndUnzipM normalise_type_role + tys (tyConRolesX role tc) + ; return (mkTyConAppCo role tc cois, ntys) } where - (cois, ntys) = zipWithAndUnzip (normaliseType env) (tyConRolesX role tc) tys + normalise_type_role ty r = withRole r $ normalise_type ty --------------- -normaliseType :: FamInstEnvs -- environment with family instances - -> Role -- desired role of output coercion - -> Type -- old type - -> (Coercion, Type) -- (coercion,new type), where - -- co :: old-type ~ new_type +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> (Coercion, Type) +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +normalise_type :: Type -- old type + -> NormM (Coercion, Type) -- (coercion,new type), where + -- co :: old-type ~ new_type -- Normalise the input type, by eliminating *all* type-function redexes -- but *not* newtypes (which are visible to the programmer) -- Returns with Refl if nothing happens +-- Does nothing to newtypes +-- The returned coercion *must* be *homogeneous* +-- See Note [Normalising types] -- Try to not to disturb type synonyms if possible -normaliseType env role (TyConApp tc tys) - = normaliseTcApp env role tc tys -normaliseType _env role ty@(LitTy {}) = (mkReflCo role ty, ty) -normaliseType env role (AppTy ty1 ty2) - = let (coi1,nty1) = normaliseType env role ty1 - (coi2,nty2) = normaliseType env Nominal ty2 - in (mkAppCo coi1 coi2, mkAppTy nty1 nty2) -normaliseType env role (FunTy ty1 ty2) - = let (coi1,nty1) = normaliseType env role ty1 - (coi2,nty2) = normaliseType env role ty2 - in (mkFunCo role coi1 coi2, mkFunTy nty1 nty2) -normaliseType env role (ForAllTy tyvar ty1) - = let (coi,nty1) = normaliseType env role ty1 - in (mkForAllCo tyvar coi, ForAllTy tyvar nty1) -normaliseType _ role ty@(TyVarTy _) - = (mkReflCo role ty,ty) +normalise_type + = go + where + go (TyConApp tc tys) = normalise_tc_app tc tys + go ty@(LitTy {}) = do { r <- getRole + ; return (mkReflCo r ty, ty) } + go (AppTy ty1 ty2) + = do { (co, nty1) <- go ty1 + ; (arg, nty2) <- withRole Nominal $ go ty2 + ; return (mkAppCo co arg, mkAppTy nty1 nty2) } + go (ForAllTy (Anon ty1) ty2) + = do { (co1, nty1) <- go ty1 + ; (co2, nty2) <- go ty2 + ; r <- getRole + ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) } + go (ForAllTy (Named tyvar vis) ty) + = do { (lc', tv', h, ki') <- normalise_tyvar_bndr tyvar + ; (co, nty) <- withLC lc' $ normalise_type ty + ; let tv2 = setTyVarKind tv' ki' + ; return (mkForAllCo tv' h co, mkNamedForAllTy tv2 vis nty) } + go (TyVarTy tv) = normalise_tyvar tv + go (CastTy ty co) + = do { (nco, nty) <- go ty + ; lc <- getLC + ; let co' = substRightCo lc co + ; return (castCoercionKind nco co co', mkCastTy nty co') } + go (CoercionTy co) + = do { lc <- getLC + ; r <- getRole + ; let right_co = substRightCo lc co + ; return ( mkProofIrrelCo r + (liftCoSubst Nominal lc (coercionType co)) + co right_co + , mkCoercionTy right_co ) } + +normalise_tyvar :: TyVar -> NormM (Coercion, Type) +normalise_tyvar tv + = ASSERT( isTyVar tv ) + do { lc <- getLC + ; r <- getRole + ; return $ case liftCoSubstTyVar lc r tv of + Just co -> (co, pSnd $ coercionKind co) + Nothing -> (mkReflCo r ty, ty) } + where ty = mkTyVarTy tv + +normalise_tyvar_bndr :: TyVar -> NormM (LiftingContext, TyVar, Coercion, Kind) +normalise_tyvar_bndr tv + = do { lc1 <- getLC + ; env <- getEnv + ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal + ; return $ liftCoSubstVarBndrCallback callback lc1 tv } + +-- | a monad for the normalisation functions, reading 'FamInstEnvs', +-- a 'LiftingContext', and a 'Role'. +newtype NormM a = NormM { runNormM :: + FamInstEnvs -> LiftingContext -> Role -> a } + +initNormM :: FamInstEnvs -> Role + -> TyCoVarSet -- the in-scope variables + -> NormM a -> a +initNormM env role vars (NormM thing_inside) + = thing_inside env lc role + where + in_scope = mkInScopeSet vars + lc = emptyLiftingContext in_scope + +getRole :: NormM Role +getRole = NormM (\ _ _ r -> r) + +getLC :: NormM LiftingContext +getLC = NormM (\ _ lc _ -> lc) + +getEnv :: NormM FamInstEnvs +getEnv = NormM (\ env _ _ -> env) + +withRole :: Role -> NormM a -> NormM a +withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r + +withLC :: LiftingContext -> NormM a -> NormM a +withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r + +instance Monad NormM where + return = pure + ma >>= fmb = NormM $ \env lc r -> + let a = runNormM ma env lc r in + runNormM (fmb a) env lc r + +instance Functor NormM where + fmap = liftM +instance Applicative NormM where + pure x = NormM $ \ _ _ _ -> x + (<*>) = ap {- ************************************************************************ @@ -1242,11 +1415,20 @@ is! Flattening as done below ensures this. flattenTys is defined here because of module dependencies. -} -type FlattenMap = TypeMap TyVar +data FlattenEnv = FlattenEnv { fe_type_map :: TypeMap TyVar + , fe_in_scope :: InScopeSet + , fe_subst :: TCvSubst } + +emptyFlattenEnv :: InScopeSet -> FlattenEnv +emptyFlattenEnv in_scope + = FlattenEnv { fe_type_map = emptyTypeMap + , fe_in_scope = in_scope + , fe_subst = mkTCvSubst in_scope ( emptyTvSubstEnv + , emptyCvSubstEnv ) } -- See Note [Flattening] flattenTys :: InScopeSet -> [Type] -> [Type] -flattenTys in_scope tys = snd $ coreFlattenTys all_in_scope emptyTypeMap tys +flattenTys in_scope tys = snd $ coreFlattenTys env tys where -- when we hit a type function, we replace it with a fresh variable -- but, we need to make sure that this fresh variable isn't mentioned @@ -1254,75 +1436,158 @@ flattenTys in_scope tys = snd $ coreFlattenTys all_in_scope emptyTypeMap tys -- a forall. That way, we can ensure consistency both within and outside -- of that forall. all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys + env = emptyFlattenEnv all_in_scope -coreFlattenTys :: InScopeSet -> FlattenMap -> [Type] -> (FlattenMap, [Type]) -coreFlattenTys in_scope = go [] +coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type]) +coreFlattenTys = go [] where - go rtys m [] = (m, reverse rtys) - go rtys m (ty : tys) - = let (m', ty') = coreFlattenTy in_scope m ty in - go (ty' : rtys) m' tys + go rtys env [] = (env, reverse rtys) + go rtys env (ty : tys) + = let (env', ty') = coreFlattenTy env ty in + go (ty' : rtys) env' tys -coreFlattenTy :: InScopeSet -> FlattenMap -> Type -> (FlattenMap, Type) -coreFlattenTy in_scope = go +coreFlattenTy :: FlattenEnv -> Type -> (FlattenEnv, Type) +coreFlattenTy = go where - go m ty | Just ty' <- coreView ty = go m ty' + go env ty | Just ty' <- coreView ty = go env ty' - go m ty@(TyVarTy {}) = (m, ty) - go m (AppTy ty1 ty2) = let (m1, ty1') = go m ty1 - (m2, ty2') = go m1 ty2 in - (m2, AppTy ty1' ty2') - go m (TyConApp tc tys) + go env (TyVarTy tv) = (env, substTyVar (fe_subst env) tv) + go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, AppTy ty1' ty2') + go env (TyConApp tc tys) -- NB: Don't just check if isFamilyTyCon: this catches *data* families, -- which are generative and thus can be preserved during flattening | not (isGenerativeTyCon tc Nominal) - = let (m', tv) = coreFlattenTyFamApp in_scope m tc tys in - (m', mkTyVarTy tv) + = let (env', tv) = coreFlattenTyFamApp env tc tys in + (env', mkTyVarTy tv) | otherwise - = let (m', tys') = coreFlattenTys in_scope m tys in - (m', mkTyConApp tc tys') + = let (env', tys') = coreFlattenTys env tys in + (env', mkTyConApp tc tys') - go m (FunTy ty1 ty2) = let (m1, ty1') = go m ty1 - (m2, ty2') = go m1 ty2 in - (m2, FunTy ty1' ty2') + go env (ForAllTy (Anon ty1) ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, mkFunTy ty1' ty2') - -- Note to RAE: this will have to be changed with kind families - go m (ForAllTy tv ty) = let (m', ty') = go m ty in - (m', ForAllTy tv ty') + go env (ForAllTy (Named tv vis) ty) + = let (env1, tv') = coreFlattenVarBndr env tv + (env2, ty') = go env1 ty in + (env2, mkNamedForAllTy tv' vis ty') - go m ty@(LitTy {}) = (m, ty) + go env ty@(LitTy {}) = (env, ty) -coreFlattenTyFamApp :: InScopeSet -> FlattenMap + go env (CastTy ty co) = let (env1, ty') = go env ty + (env2, co') = coreFlattenCo env1 co in + (env2, CastTy ty' co') + + go env (CoercionTy co) = let (env', co') = coreFlattenCo env co in + (env', CoercionTy co') + +-- when flattening, we don't care about the contents of coercions. +-- so, just return a fresh variable of the right (flattened) type +coreFlattenCo :: FlattenEnv -> Coercion -> (FlattenEnv, Coercion) +coreFlattenCo env co + = (env2, mkCoVarCo covar) + where + (env1, kind') = coreFlattenTy env (coercionType co) + fresh_name = mkFlattenFreshCoName + in_scope = fe_in_scope env1 + covar = uniqAway in_scope $ mkCoVar fresh_name kind' + env2 = env1 { fe_in_scope = in_scope `extendInScopeSet` covar } + +coreFlattenVarBndr :: FlattenEnv -> TyVar -> (FlattenEnv, TyVar) +coreFlattenVarBndr env tv + | kind' `eqType` kind + = ( env { fe_subst = extendTCvSubst old_subst tv (mkTyVarTy tv) } + -- override any previous binding for tv + , tv) + | otherwise + = let new_tv = uniqAway (fe_in_scope env) (setTyVarKind tv kind') + new_subst = extendTCvSubst old_subst tv (mkTyVarTy new_tv) + new_is = extendInScopeSet old_in_scope new_tv + in + (env' { fe_in_scope = new_is + , fe_subst = new_subst }, new_tv) + where + kind = tyVarKind tv + (env', kind') = coreFlattenTy env kind + old_subst = fe_subst env + old_in_scope = fe_in_scope env + +coreFlattenTyFamApp :: FlattenEnv -> TyCon -- type family tycon -> [Type] -- args - -> (FlattenMap, TyVar) -coreFlattenTyFamApp in_scope m fam_tc fam_args - = case lookupTypeMap m fam_ty of - Just tv -> (m, tv) + -> (FlattenEnv, TyVar) +coreFlattenTyFamApp env fam_tc fam_args + = case lookupTypeMap type_map fam_ty of + Just tv -> (env, tv) -- we need fresh variables here, but this is called far from -- any good source of uniques. So, we just use the fam_tc's unique -- and trust uniqAway to avoid clashes. Recall that the in_scope set -- contains *all* tyvars, even locally bound ones elsewhere in the -- overall type, so this really is fresh. - Nothing -> let tyvar_name = mkSysTvName (getUnique fam_tc) (fsLit "fl") - tv = uniqAway in_scope $ mkTyVar tyvar_name (typeKind fam_ty) - m' = extendTypeMap m fam_ty tv in - (m', tv) - where fam_ty = TyConApp fam_tc fam_args - + Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc + tv = uniqAway in_scope $ mkTyVar tyvar_name + (typeKind fam_ty) + env' = env { fe_type_map = extendTypeMap type_map fam_ty tv + , fe_in_scope = extendInScopeSet in_scope tv } + in (env', tv) + where fam_ty = mkTyConApp fam_tc fam_args + FlattenEnv { fe_type_map = type_map + , fe_in_scope = in_scope } = env + +-- | Get the set of all type variables mentioned anywhere in the list +-- of types. These variables are not necessarily free. allTyVarsInTys :: [Type] -> VarSet allTyVarsInTys [] = emptyVarSet allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys +-- | Get the set of all type variables mentioned anywhere in a type. allTyVarsInTy :: Type -> VarSet allTyVarsInTy = go where go (TyVarTy tv) = unitVarSet tv go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) go (TyConApp _ tys) = allTyVarsInTys tys - go (FunTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) - go (ForAllTy tv ty) = (go (tyVarKind tv)) `unionVarSet` - unitVarSet tv `unionVarSet` - (go ty) -- don't remove tv + go (ForAllTy bndr ty) = + caseBinder bndr (\tv -> unitVarSet tv) (const emptyVarSet) + `unionVarSet` go (binderType bndr) `unionVarSet` go ty + -- don't remove the tv from the set! go (LitTy {}) = emptyVarSet + go (CastTy ty co) = go ty `unionVarSet` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl _ ty) = go ty + go_co (TyConAppCo _ _ args) = go_cos args + 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 (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 + go_co (SymCo co) = go_co co + go_co (TransCo c1 c2) = go_co c1 `unionVarSet` go_co c2 + go_co (NthCo _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionVarSet` go_co arg + go_co (CoherenceCo c1 c2) = go_co c1 `unionVarSet` go_co c2 + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_cos = foldr (unionVarSet . go_co) emptyVarSet + + go_prov UnsafeCoerceProv = emptyVarSet + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyVarSet + go_prov (HoleProv _) = emptyVarSet + +mkFlattenFreshTyName :: Uniquable a => a -> Name +mkFlattenFreshTyName unq + = mkSysTvName (getUnique unq) (fsLit "flt") + +mkFlattenFreshCoName :: Name +mkFlattenFreshCoName + = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc") diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index b0ee31e0cb..c3cd916051 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -21,7 +21,7 @@ module InstEnv ( InstEnvs(..), VisibleOrphanModules, InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalClsInstHead, - extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, memberInstEnv, instIsVisible, classInstances, orphNamesOfClsInst, instanceBindFun, instanceCantMatch, roughMatchTcs @@ -261,9 +261,10 @@ mkImportedInstance cls_nm mb_tcs dfun oflag orphan roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs tys = map rough tys where - rough ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> Just (tyConName tc) - Nothing -> Nothing + rough ty + | Just (ty', _) <- tcSplitCastTy_maybe ty = rough ty' + | Just (tc,_) <- tcSplitTyConApp_maybe ty = Just (tyConName tc) + | otherwise = Nothing instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot @@ -676,7 +677,6 @@ where the 'Nothing' indicates that 'b' can be freely instantiated. -- |Look up an instance in the given instance environment. The given class application must match exactly -- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, -- yield 'Left errorMessage'. --- lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either MsgDoc (ClsInst, [Type]) @@ -711,6 +711,7 @@ lookupInstEnv' ie vis_mods cls tys where rough_tcs = roughMatchTcs tys all_tvs = all isNothing rough_tcs + -------------- lookup env = case lookupUFM env cls of Nothing -> ([],[]) -- No instances for this class @@ -728,7 +729,7 @@ lookupInstEnv' ie vis_mods cls tys = find ms us rest | Just subst <- tcMatchTys tpl_tv_set tpl_tys tys - = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest + = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] and Note [Incoherent instances] @@ -736,7 +737,7 @@ lookupInstEnv' ie vis_mods cls tys = find ms us rest | otherwise - = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tv_set, + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, (ppr cls <+> ppr tys <+> ppr all_tvs) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) @@ -749,13 +750,6 @@ lookupInstEnv' ie vis_mods cls tys where tpl_tv_set = mkVarSet tpl_tvs - ---------------- - lookup_tv :: TvSubst -> TyVar -> DFunInstType - -- See Note [DFunInstType: instantiating types] - lookup_tv subst tv = case lookupTyVar subst tv of - Just ty -> Just ty - Nothing -> Nothing - --------------- -- This is the common way to call this function. lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions @@ -936,7 +930,7 @@ incoherent instances as long as there are others. ************************************************************************ -} -instanceBindFun :: TyVar -> BindFlag +instanceBindFun :: TyCoVar -> BindFlag instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem | otherwise = BindMe -- Note [Binding when looking up instances] diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index 342cab503c..1ce0bbf0ed 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -3,57 +3,30 @@ {-# LANGUAGE CPP #-} module Kind ( -- * Main data type - SuperKind, Kind, typeKind, - - -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, - mkArrowKind, mkArrowKinds, - - -- Kind constructors... - anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, - unliftedTypeKindTyCon, constraintKindTyCon, - - -- Super Kinds - superKind, superKindTyCon, - - pprKind, pprParendKind, - - -- ** Deconstructing Kinds - kindAppResult, tyConResKind, - splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, + Kind, typeKind, -- ** Predicates on Kinds - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isConstraintKind, isConstraintOrLiftedKind, returnsConstraintKind, - isKind, isKindVar, - isSuperKind, isSuperKindTyCon, - isLiftedTypeKindCon, isConstraintKindCon, - isAnyKind, isAnyKindCon, + isLiftedTypeKind, isUnliftedTypeKind, + isConstraintKind, + returnsTyCon, returnsConstraintKind, + isConstraintKindCon, okArrowArgKind, okArrowResultKind, - isSubOpenTypeKind, isSubOpenTypeKindKey, - isSubKind, isSubKindCon, - tcIsSubKind, tcIsSubKindCon, - defaultKind, defaultKind_maybe, - - -- ** Functions on variables - kiVarsOfKind, kiVarsOfKinds - + classifiesTypeWithValues, + isStarKind, isStarKindSynonymTyCon, + isLevityPolymorphic, isLevityPolymorphic_maybe ) where #include "HsVersions.h" -import {-# SOURCE #-} Type ( typeKind, substKiWith, eqKind ) +import {-# SOURCE #-} Type ( typeKind, coreViewOneStarKind ) -import TypeRep -import TysPrim +import TyCoRep import TyCon -import VarSet +import Var import PrelNames -import Outputable -import Maybes( orElse ) -import Util -import FastString +import Data.Maybe +import Util ( (<&&>) ) {- ************************************************************************ @@ -84,219 +57,73 @@ See Trac #7451. Bottom line: although '*' and 'Constraint' are distinct TyCons, with distinct uniques, they are treated as equal at all times except -during type inference. Hence cmpTc treats them as equal. +during type inference. -} --- | Essentially 'funResultTy' on kinds handling pi-types too -kindFunResult :: SDoc -> Kind -> KindOrType -> Kind -kindFunResult _ (FunTy _ res) _ = res -kindFunResult _ (ForAllTy kv res) arg = substKiWith [kv] [arg] res -#ifdef DEBUG -kindFunResult doc k _ = pprPanic "kindFunResult" (ppr k $$ doc) -#else --- Without DEBUG, doc becomes an unsed arg, and will be optimised away -kindFunResult _ _ _ = panic "kindFunResult" -#endif - -kindAppResult :: SDoc -> Kind -> [Type] -> Kind -kindAppResult _ k [] = k -kindAppResult doc k (a:as) = kindAppResult doc (kindFunResult doc k a) as - --- | Essentially 'splitFunTys' on kinds -splitKindFunTys :: Kind -> ([Kind],Kind) -splitKindFunTys (FunTy a r) = case splitKindFunTys r of - (as, k) -> (a:as, k) -splitKindFunTys k = ([], k) - -splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) -splitKindFunTy_maybe (FunTy a r) = Just (a,r) -splitKindFunTy_maybe _ = Nothing +isConstraintKind :: Kind -> Bool +isConstraintKindCon :: TyCon -> Bool --- | Essentially 'splitFunTysN' on kinds -splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) -splitKindFunTysN 0 k = ([], k) -splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of - (as, k) -> (a:as, k) -splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) - --- | Find the result 'Kind' of a type synonym or a type family, --- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, --- but they'd always return '*', so we never need to ask -tyConResKind :: TyCon -> Kind -tyConResKind tycon = - kindAppResult (ptext (sLit "tyConResKind") <+> ppr tycon) - (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) - --- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isOpenTypeKind, isUnliftedTypeKind, - isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool - -isOpenTypeKindCon, isUnliftedTypeKindCon, - isSubOpenTypeKindCon, isConstraintKindCon, - isLiftedTypeKindCon, isAnyKindCon, isSuperKindTyCon :: TyCon -> Bool - - -isLiftedTypeKindCon tc = tyConUnique tc == liftedTypeKindTyConKey -isAnyKindCon tc = tyConUnique tc == anyKindTyConKey -isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey -isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey -isSuperKindTyCon tc = tyConUnique tc == superKindTyConKey - -isAnyKind (TyConApp tc _) = isAnyKindCon tc -isAnyKind _ = False - -isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc -isOpenTypeKind _ = False - -isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc -isUnliftedTypeKind _ = False isConstraintKind (TyConApp tc _) = isConstraintKindCon tc isConstraintKind _ = False -isConstraintOrLiftedKind (TyConApp tc _) - = isConstraintKindCon tc || isLiftedTypeKindCon tc -isConstraintOrLiftedKind _ = False +-- | Does the given type "end" in the given tycon? For example @k -> [a] -> *@ +-- ends in @*@ and @Maybe a -> [a]@ ends in @[]@. +returnsTyCon :: Unique -> Type -> Bool +returnsTyCon tc_u (ForAllTy _ ty) = returnsTyCon tc_u ty +returnsTyCon tc_u (TyConApp tc' _) = tc' `hasKey` tc_u +returnsTyCon _ _ = False returnsConstraintKind :: Kind -> Bool -returnsConstraintKind (ForAllTy _ k) = returnsConstraintKind k -returnsConstraintKind (FunTy _ k) = returnsConstraintKind k -returnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc -returnsConstraintKind _ = False +returnsConstraintKind = returnsTyCon constraintKindTyConKey + +-- | Tests whether the given type looks like "TYPE v", where v is a variable. +isLevityPolymorphic :: Kind -> Bool +isLevityPolymorphic = isJust . isLevityPolymorphic_maybe + +-- | Retrieves a levity variable in the given kind, if the kind is of the +-- form "TYPE v". +isLevityPolymorphic_maybe :: Kind -> Maybe TyVar +isLevityPolymorphic_maybe k + | Just k' <- coreViewOneStarKind k = isLevityPolymorphic_maybe k' +isLevityPolymorphic_maybe (TyConApp tc [TyVarTy v]) + | tc `hasKey` tYPETyConKey + = Just v +isLevityPolymorphic_maybe _ = Nothing -------------------------------------------- -- Kinding for arrow (->) -- Says when a kind is acceptable on lhs or rhs of an arrow -- arg -> res -okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool -okArrowArgKindCon = isSubOpenTypeKindCon -okArrowResultKindCon = isSubOpenTypeKindCon - okArrowArgKind, okArrowResultKind :: Kind -> Bool -okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc -okArrowArgKind _ = False - -okArrowResultKind (TyConApp kc []) = okArrowResultKindCon kc -okArrowResultKind _ = False +okArrowArgKind = classifiesTypeWithValues <&&> (not . isLevityPolymorphic) +okArrowResultKind = classifiesTypeWithValues ----------------------------------------- -- Subkinding --- The tc variants are used during type-checking, where we don't want the --- Constraint kind to be a subkind of anything --- After type-checking (in core), Constraint is a subkind of openTypeKind - -isSubOpenTypeKind :: Kind -> Bool +-- The tc variants are used during type-checking, where ConstraintKind +-- is distinct from all other kinds +-- After type-checking (in core), Constraint and liftedTypeKind are +-- indistinguishable + +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, #, TYPE Lifted, TYPE v, Constraint. +classifiesTypeWithValues :: Kind -> Bool -- ^ True of any sub-kind of OpenTypeKind -isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc -isSubOpenTypeKind _ = False - -isSubOpenTypeKindCon kc = isSubOpenTypeKindKey (tyConUnique kc) - -isSubOpenTypeKindKey :: Unique -> Bool -isSubOpenTypeKindKey uniq - = uniq == openTypeKindTyConKey - || uniq == unliftedTypeKindTyConKey - || uniq == liftedTypeKindTyConKey - || uniq == constraintKindTyConKey -- Needed for error (Num a) "blah" - -- and so that (Ord a -> Eq a) is well-kinded - -- and so that (# Eq a, Ord b #) is well-kinded - -- See Note [Kind Constraint and kind *] - --- | Is this a kind (i.e. a type-of-types)? -isKind :: Kind -> Bool -isKind k = isSuperKind (typeKind k) - -isSubKind :: Kind -> Kind -> Bool --- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ --- Sub-kinding is extremely simple and does not look --- under arrrows or type constructors - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) - | isPromotedTyCon kc1 || isPromotedTyCon kc2 - -- handles promoted kinds (List *, Nat, etc.) - = eqKind k1 k2 - - | otherwise -- handles usual kinds (*, #, (#), etc.) - = ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) - kc1 `isSubKindCon` kc2 - -isSubKind k1 k2 = eqKind k1 k2 - -isSubKindCon :: TyCon -> TyCon -> Bool --- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -isSubKindCon kc1 kc2 - | kc1 == kc2 = True - | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 - | isConstraintKindCon kc1 = isLiftedTypeKindCon kc2 - | isLiftedTypeKindCon kc1 = isConstraintKindCon kc2 - -- See Note [Kind Constraint and kind *] - | otherwise = False - -------------------------- --- Hack alert: we need a tiny variant for the typechecker --- Reason: f :: Int -> (a~b) --- g :: forall (c::Constraint). Int -> c --- h :: Int => Int --- We want to reject these, even though Constraint is --- a sub-kind of OpenTypeKind. It must be a sub-kind of OpenTypeKind --- *after* the typechecker --- a) So that (Ord a -> Eq a) is a legal type --- b) So that the simplifer can generate (error (Eq a) "urk") --- Moreover, after the type checker, Constraint and * --- are identical; see Note [Kind Constraint and kind *] --- --- Easiest way to reject is simply to make Constraint a compliete --- below OpenTypeKind when type checking - -tcIsSubKind :: Kind -> Kind -> Bool -tcIsSubKind k1 k2 - | isConstraintKind k1 = isConstraintKind k2 - | isConstraintKind k2 = isConstraintKind k1 - | otherwise = isSubKind k1 k2 - -tcIsSubKindCon :: TyCon -> TyCon -> Bool -tcIsSubKindCon kc1 kc2 - | isConstraintKindCon kc1 = isConstraintKindCon kc2 - | isConstraintKindCon kc2 = isConstraintKindCon kc1 - | otherwise = isSubKindCon kc1 kc2 - -------------------------- -defaultKind :: Kind -> Kind -defaultKind_maybe :: Kind -> Maybe Kind --- ^ Used when generalising: default OpenKind and ArgKind to *. --- See "Type#kind_subtyping" for more information on what that means - --- When we generalise, we make generic type variables whose kind is --- simple (* or *->* etc). So generic type variables (other than --- built-in constants like 'error') always have simple kinds. This is important; --- consider --- f x = True --- We want f to get type --- f :: forall (a::*). a -> Bool --- Not --- f :: forall (a::ArgKind). a -> Bool --- because that would allow a call like (f 3#) as well as (f True), --- and the calling conventions differ. --- This defaulting is done in TcMType.zonkTcTyVarBndr. --- --- The test is really whether the kind is strictly above '*' -defaultKind_maybe (TyConApp kc _args) - | isOpenTypeKindCon kc = ASSERT( null _args ) Just liftedTypeKind -defaultKind_maybe _ = Nothing - -defaultKind k = defaultKind_maybe k `orElse` k - --- Returns the free kind variables in a kind -kiVarsOfKind :: Kind -> VarSet -kiVarsOfKind = tyVarsOfType - -kiVarsOfKinds :: [Kind] -> VarSet -kiVarsOfKinds = tyVarsOfTypes +classifiesTypeWithValues t | Just t' <- coreViewOneStarKind t = classifiesTypeWithValues t' +classifiesTypeWithValues (TyConApp tc [_]) = tc `hasKey` tYPETyConKey +classifiesTypeWithValues _ = False + +-- | Is this kind equivalent to *? +isStarKind :: Kind -> Bool +isStarKind k | Just k' <- coreViewOneStarKind k = isStarKind k' +isStarKind (TyConApp tc [TyConApp l []]) = tc `hasKey` tYPETyConKey + && l `hasKey` liftedDataConKey +isStarKind _ = False + -- See Note [Kind Constraint and kind *] + +-- | Is the tycon @Constraint@? +isStarKindSynonymTyCon :: TyCon -> Bool +isStarKindSynonymTyCon tc = tc `hasKey` constraintKindTyConKey diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index e112a20bf2..f68bc8cb04 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -1,53 +1,40 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns -fno-warn-incomplete-patterns #-} + -- Inexplicably, this module takes 10GB of memory to compile with the new + -- (Nov '15) pattern-match check. This needs to be fixed. But we need + -- to be able to compile in the meantime. module OptCoercion ( optCoercion, checkAxInstCo ) where #include "HsVersions.h" +import TyCoRep import Coercion -import Type hiding( substTyVarBndr, substTy, extendTvSubst ) -import TcType ( exactTyVarsOfType ) +import Type hiding( substTyVarBndr, substTy, extendTCvSubst ) +import TcType ( exactTyCoVarsOfType ) import TyCon import CoAxiom -import Var import VarSet -import FamInstEnv ( flattenTys ) import VarEnv import StaticFlags ( opt_NoOptCoercion ) import Outputable +import FamInstEnv ( flattenTys ) import Pair +import ListSetOps ( getNth ) import FastString import Util import Unify -import ListSetOps import InstEnv import Control.Monad ( zipWithM ) {- -************************************************************************ -* * +%************************************************************************ +%* * Optimising coercions -* * -************************************************************************ - -Note [Subtle shadowing in coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose we optimising a coercion - optCoercion (forall (co_X5:t1~t2). ...co_B1...) -The co_X5 is a wild-card; the bound variable of a coercion for-all -should never appear in the body of the forall. Indeed we often -write it like this - optCoercion ( (t1~t2) => ...co_B1... ) - -Just because it's a wild-card doesn't mean we are free to choose -whatever variable we like. For example it'd be wrong for optCoercion -to return - forall (co_B1:t1~t2). ...co_B1... -because now the co_B1 (which is really free) has been captured, and -subsequent substitutions will go wrong. That's why we can't use -mkCoPredTy in the ForAll case, where this note appears. +%* * +%************************************************************************ Note [Optimising coercion optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -64,21 +51,66 @@ checks that opt_co4 can avoid. This is a big win because Phantom coercions rarely appear within non-phantom coercions -- only in some TyConAppCos and some AxiomInstCos. We handle these cases specially by calling opt_co2. + +Note [Optimising InstCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. + +Let's look at the typing rules. + +h : k1 ~ k2 +tv:k1 |- g : t1 ~ t2 +----------------------------- +ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) + +g1 : (all tv:k1.t1') ~ (all tv:k2.t2') +g2 : s1 ~ s2 +-------------------- +InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] + +We thus want some coercion proving this: + + (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) + +If we substitute the *type* tv for the *coercion* +(g2 `mkCoherenceRightCo` sym h) in g, we'll get this result exactly. +This is bizarre, +though, because we're substituting a type variable with a coercion. However, +this operation already exists: it's called *lifting*, and defined in Coercion. +We just need to enhance the lifting operation to be able to deal with +an ambient substitution, which is why a LiftingContext stores a TCvSubst. + -} -optCoercion :: CvSubst -> Coercion -> NormalCo +optCoercion :: TCvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size optCoercion env co | opt_NoOptCoercion = substCo env co - | otherwise = opt_co1 env False co + | debugIsOn = let out_co = opt_co1 lc False co + Pair in_ty1 in_ty2 = coercionKind co + Pair out_ty1 out_ty2 = coercionKind out_co + in + ASSERT2( substTy env in_ty1 `eqType` out_ty1 && + substTy env in_ty2 `eqType` out_ty2 + , text "optCoercion changed types!" + $$ hang (text "in_co:") 2 (ppr co) + $$ hang (text "in_ty1:") 2 (ppr in_ty1) + $$ hang (text "in_ty2:") 2 (ppr in_ty2) + $$ hang (text "out_co:") 2 (ppr out_co) + $$ hang (text "out_ty1:") 2 (ppr out_ty1) + $$ hang (text "out_ty2:") 2 (ppr out_ty2) + $$ hang (text "subst:") 2 (ppr env) ) + out_co + | otherwise = opt_co1 lc False co + where + lc = mkSubstLiftingContext env -type NormalCo = Coercion +type NormalCo = Coercion -- Invariants: -- * The substitution has been fully applied -- * For trans coercions (co1 `trans` co2) -- co1 is not a trans, and neither co1 nor co2 is identity - -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) type NormalNonIdCo = NormalCo -- Extra invariant: not the identity @@ -88,39 +120,16 @@ type SymFlag = Bool -- | Do we force the result to be representational? type ReprFlag = Bool --- | Optimize a coercion, making no assumptions. -opt_co1 :: CvSubst +-- | Optimize a coercion, making no assumptions. All coercions in +-- the lifting context are already optimized (and sym'd if nec'y) +opt_co1 :: LiftingContext -> SymFlag -> Coercion -> NormalCo opt_co1 env sym co = opt_co2 env sym (coercionRole co) co -{- -opt_co env sym co - = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ - co1 `seq` - pprTrace "opt_co done }" (ppr co1) $ - (WARN( not same_co_kind, ppr co <+> dcolon <+> ppr (coercionType co) - $$ ppr co1 <+> dcolon <+> ppr (coercionType co1) ) - WARN( not (coreEqCoercion co1 simple_result), - (text "env=" <+> ppr env) $$ - (text "input=" <+> ppr co) $$ - (text "simple=" <+> ppr simple_result) $$ - (text "opt=" <+> ppr co1) ) - co1) - where - co1 = opt_co' env sym co - same_co_kind = s1 `eqType` s2 && t1 `eqType` t2 - Pair s t = coercionKind (substCo env co) - (s1,t1) | sym = (t,s) - | otherwise = (s,t) - Pair s2 t2 = coercionKind co1 - - simple_result | sym = mkSymCo (substCo env co) - | otherwise = substCo env co --} -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's role. No other assumptions. -opt_co2 :: CvSubst +opt_co2 :: LiftingContext -> SymFlag -> Role -- ^ The role of the input coercion -> Coercion -> NormalCo @@ -129,22 +138,41 @@ opt_co2 env sym r co = opt_co3 env sym Nothing r co -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's non-Phantom role. -opt_co3 :: CvSubst -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo -opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co -opt_co3 env sym (Just Representational) r co = opt_co4 env sym True r co +opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore -opt_co3 env sym _ r co = opt_co4 env sym False r co - +opt_co3 env sym _ r co = opt_co4_wrap env sym False r co -- See Note [Optimising coercion optimisation] -- | Optimize a non-phantom coercion. -opt_co4 :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4_wrap = opt_co4 +{- +opt_co4_wrap env sym rep r co + = pprTrace "opt_co4_wrap {" + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co ]) $ + ASSERT( r == coercionRole co ) + let result = opt_co4 env sym rep r co in + pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ + result +-} opt_co4 env _ rep r (Refl _r ty) - = ASSERT( r == _r ) - Refl (chooseRole rep r) (substTy env ty) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty -opt_co4 env sym rep r (SymCo co) = opt_co4 env (not sym) rep r co +opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co + -- surprisingly, we don't have to do anything to the env here. This is + -- because any "lifting" substitutions in the env are tied to ForAllCos, + -- which treat their left and right sides differently. We don't want to + -- exchange them. opt_co4 env sym rep r g@(TyConAppCo _r tc cos) = ASSERT( r == _r ) @@ -156,7 +184,7 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos) (repeat Nominal) cos) (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos) + mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) (_, Representational) -> -- must use opt_co2 here, because some roles may be P -- See Note [Optimising coercion optimisation] @@ -165,18 +193,21 @@ opt_co4 env sym rep r g@(TyConAppCo _r tc cos) cos) (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) -opt_co4 env sym rep r (AppCo co1 co2) = mkAppCo (opt_co4 env sym rep r co1) - (opt_co4 env sym False Nominal co2) -opt_co4 env sym rep r (ForAllCo tv co) - = case substTyVarBndr env tv of - (env', tv') -> mkForAllCo tv' (opt_co4 env' sym rep r co) +opt_co4 env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4_wrap env sym rep r co1) + (opt_co4_wrap env sym False Nominal co2) + +opt_co4 env sym rep r (ForAllCo tv k_co co) + = case optForAllCoBndr env sym tv k_co of + (env', tv', k_co') -> mkForAllCo tv' k_co' $ + opt_co4_wrap env' sym rep r co -- Use the "mk" functions to check for nested Refls opt_co4 env sym rep r (CoVarCo cv) - | Just co <- lookupCoVar env cv - = opt_co4 (zapCvSubstEnv env) sym rep r co + | Just co <- lookupCoVar (lcTCvSubst env) cv + = opt_co4_wrap (zapLiftingContext env) sym rep r co - | Just cv1 <- lookupInScope (getCvInScope env) cv + | Just cv1 <- lookupInScope (lcInScopeSet env) cv = ASSERT( isCoVar cv1 ) wrapRole rep r $ wrapSym sym (CoVarCo cv1) -- cv1 might have a substituted kind! @@ -199,109 +230,167 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos) cos) -- Note that the_co does *not* have sym pushed into it -opt_co4 env sym rep r (UnivCo s _r oty1 oty2) +opt_co4 env sym _ r (UnivCo prov _r t1 t2) = ASSERT( r == _r ) - opt_univ env s (chooseRole rep r) a b - where - (a,b) = if sym then (oty2,oty1) else (oty1,oty2) + opt_univ env sym prov r t1 t2 opt_co4 env sym rep r (TransCo co1 co2) -- sym (g `o` h) = sym h `o` sym g | sym = opt_trans in_scope co2' co1' | otherwise = opt_trans in_scope co1' co2' where - co1' = opt_co4 env sym rep r co1 - co2' = opt_co4 env sym rep r co2 - in_scope = getCvInScope env + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + in_scope = lcInScopeSet env + opt_co4 env sym rep r co@(NthCo {}) = opt_nth_co env sym rep r co opt_co4 env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co = ASSERT( r == Nominal ) - opt_co4 env sym rep Nominal (pickLR lr pr_co) + opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) | Just pr_co <- splitAppCo_maybe co' = ASSERT( r == Nominal ) if rep - then opt_co4 (zapCvSubstEnv env) False True Nominal (pickLR lr pr_co) - else pickLR lr pr_co + then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) + else pick_lr lr pr_co | otherwise = wrapRole rep Nominal $ LRCo lr co' where - co' = opt_co4 env sym False Nominal co + co' = opt_co4_wrap env sym False Nominal co -opt_co4 env sym rep r (InstCo co ty) - -- See if the first arg is already a forall - -- ...then we can just extend the current substitution - | Just (tv, co_body) <- splitForAllCo_maybe co - = opt_co4 (extendTvSubst env tv ty') sym rep r co_body + pick_lr CLeft (l, _) = l + pick_lr CRight (_, r) = r - -- See if it is a forall after optimization - -- If so, do an inefficient one-variable substitution - | Just (tv, co'_body) <- splitForAllCo_maybe co' - = substCoWithTy (getCvInScope env) tv ty' co'_body +-- See Note [Optimising InstCo] +opt_co4 env sym rep r (InstCo co1 arg) + -- forall over type... + | Just (tv, kind_co, co_body) <- splitForAllCo_maybe co1 + = opt_co4_wrap (extendLiftingContext env tv + (arg' `mkCoherenceRightCo` mkSymCo kind_co)) + sym rep r co_body - | otherwise = InstCo co' ty' + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution, then re-optimize + + -- forall over type... + | Just (tv', kind_co', co_body') <- splitForAllCo_maybe co1' + = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' + (arg' `mkCoherenceRightCo` mkSymCo kind_co')) + False False r' co_body' + + | otherwise = InstCo co1' arg' where - co' = opt_co4 env sym rep r co - ty' = substTy env ty + co1' = opt_co4_wrap env sym rep r co1 + r' = chooseRole rep r + arg' = opt_co4_wrap env sym False Nominal arg + +opt_co4 env sym rep r (CoherenceCo co1 co2) + | TransCo col1 cor1 <- co1 + = opt_co4_wrap env sym rep r (mkTransCo (mkCoherenceCo col1 co2) cor1) + + | TransCo col1' cor1' <- co1' + = if sym then opt_trans in_scope col1' + (optCoercion (zapTCvSubst (lcTCvSubst env)) + (mkCoherenceRightCo cor1' co2')) + else opt_trans in_scope (mkCoherenceCo col1' co2') cor1' + + | otherwise + = wrapSym sym $ CoherenceCo (opt_co4_wrap env False rep r co1) co2' + where co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env False False Nominal co2 + in_scope = lcInScopeSet env + +opt_co4 env sym _rep r (KindCo co) + = ASSERT( r == Nominal ) + let kco' = promoteCoercion co in + case kco' of + KindCo co' -> promoteCoercion (opt_co1 env sym co') + _ -> opt_co4_wrap env sym False Nominal kco' + -- This might be able to be optimized more to do the promotion + -- and substitution/optimization at the same time opt_co4 env sym _ r (SubCo co) = ASSERT( r == Representational ) - opt_co4 env sym True Nominal co + opt_co4_wrap env sym True Nominal co --- XXX: We could add another field to CoAxiomRule that --- would allow us to do custom simplifications. -opt_co4 env sym rep r (AxiomRuleCo co ts cs) +-- This could perhaps be optimized more. +opt_co4 env sym rep r (AxiomRuleCo co cs) = ASSERT( r == coaxrRole co ) wrapRole rep r $ wrapSym sym $ - AxiomRuleCo co (map (substTy env) ts) - (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) - + AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) ------------- -- | Optimize a phantom coercion. The input coercion may not necessarily -- be a phantom, but the output sure will be. -opt_phantom :: CvSubst -> SymFlag -> Coercion -> NormalCo +opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo opt_phantom env sym co - = if sym - then opt_univ env (fsLit "opt_phantom") Phantom ty2 ty1 - else opt_univ env (fsLit "opt_phantom") Phantom ty1 ty2 + = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 where Pair ty1 ty2 = coercionKind co -opt_univ :: CvSubst -> FastString -> Role -> Type -> Type -> Coercion -opt_univ env prov role oty1 oty2 +opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role + -> Type -> Type -> Coercion +opt_univ env sym (PhantomProv h) _r ty1 ty2 + | sym = mkPhantomCo h' ty2' ty1' + | otherwise = mkPhantomCo h' ty1' ty2' + where + h' = opt_co4 env sym False Nominal h + ty1' = substTy (lcSubstLeft env) ty1 + ty2' = substTy (lcSubstRight env) ty2 + +opt_univ env sym prov role oty1 oty2 | Just (tc1, tys1) <- splitTyConApp_maybe oty1 , Just (tc2, tys2) <- splitTyConApp_maybe oty2 , tc1 == tc2 - = mkTyConAppCo role tc1 (zipWith3 (opt_univ env prov) (tyConRolesX role tc1) tys1 tys2) + -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); + -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps + = let roles = tyConRolesX role tc1 + arg_cos = zipWith3 (mkUnivCo prov) roles tys1 tys2 + arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos + in + mkTyConAppCo role tc1 arg_cos' - | Just (l1, r1) <- splitAppTy_maybe oty1 - , Just (l2, r2) <- splitAppTy_maybe oty2 - , typeKind l1 `eqType` typeKind l2 -- kind(r1) == kind(r2) by consequence - = let role' = if role == Phantom then Phantom else Nominal in - -- role' is to comform to mkAppCo's precondition - mkAppCo (opt_univ env prov role l1 l2) (opt_univ env prov role' r1 r2) + -- can't optimize the AppTy case because we can't build the kind coercions. | Just (tv1, ty1) <- splitForAllTy_maybe oty1 , Just (tv2, ty2) <- splitForAllTy_maybe oty2 - , tyVarKind tv1 `eqType` tyVarKind tv2 -- rule out a weird unsafeCo - = case substTyVarBndr2 env tv1 tv2 of { (env1, env2, tv') -> - let ty1' = substTy env1 ty1 - ty2' = substTy env2 ty2 in - mkForAllCo tv' (opt_univ (zapCvSubstEnv2 env1 env2) prov role ty1' ty2') } + -- NB: prov isn't interesting here either + = let k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + eta = mkUnivCo prov Nominal k1 k2 + -- eta gets opt'ed soon, but not yet. + ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 + + (env', tv1', eta') = optForAllCoBndr env sym tv1 eta + in + mkForAllCo tv1' eta' (opt_univ env' sym prov role ty1 ty2') | otherwise - = mkUnivCo prov role (substTy env oty1) (substTy env oty2) + = let ty1 = substTy (lcSubstLeft env) oty1 + ty2 = substTy (lcSubstRight env) oty2 + (a, b) | sym = (ty2, ty1) + | otherwise = (ty1, ty2) + in + mkUnivCo prov' role a b + + where + prov' = case prov of + UnsafeCoerceProv -> prov + PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco + ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco + PluginProv _ -> prov + HoleProv h -> pprPanic "opt_univ fell into a hole" (ppr h) + ------------- -- NthCo must be handled separately, because it's the one case where we can't -- tell quickly what the component coercion's role is from the containing -- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2, -- we just look for nested NthCo's, which can happen in practice. -opt_nth_co :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +opt_nth_co :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo opt_nth_co env sym rep r = go [] where go ns (NthCo n co) = go (n:ns) co @@ -311,9 +400,24 @@ opt_nth_co env sym rep r = go [] go ns co = opt_nths ns co + -- try to resolve 1 Nth + push_nth n (Refl r1 ty) + | Just (tc, args) <- splitTyConApp_maybe ty + = Just (Refl (nthRole r1 tc n) (args `getNth` n)) + | n == 0 + , Just (tv, _) <- splitForAllTy_maybe ty + = Just (Refl Nominal (tyVarKind tv)) + push_nth n (TyConAppCo _ _ cos) + = Just (cos `getNth` n) + push_nth 0 (ForAllCo _ eta _) + = Just eta + push_nth _ _ = Nothing + -- input coercion is *not* yet sym'd or opt'd - opt_nths [] co = opt_co4 env sym rep r co - opt_nths (n:ns) (TyConAppCo _ _ cos) = opt_nths ns (cos `getNth` n) + opt_nths [] co = opt_co4_wrap env sym rep r co + opt_nths (n:ns) co + | Just co' <- push_nth n co + = opt_nths ns co' -- here, the co isn't a TyConAppCo, so we opt it, hoping to get -- a TyConAppCo as output. We don't know the role, so we use @@ -327,9 +431,11 @@ opt_nth_co env sym rep r = go [] opt_nths' [] co = if rep && (r == Nominal) -- propagate the SubCo: - then opt_co4 (zapCvSubstEnv env) False True r co + then opt_co4_wrap (zapLiftingContext env) False True r co else co - opt_nths' (n:ns) (TyConAppCo _ _ cos) = opt_nths' ns (cos `getNth` n) + opt_nths' (n:ns) co + | Just co' <- push_nth n co + = opt_nths' ns co' opt_nths' ns co = wrapRole rep r (mk_nths ns co) mk_nths [] co = co @@ -388,60 +494,81 @@ opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) -- Push transitivity inside instantiation opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) - | ty1 `eqType` ty2 + | ty1 `eqCoercion` ty2 , co1 `compatible_co` co2 = fireTransRule "TrPushInst" in_co1 in_co2 $ mkInstCo (opt_trans is co1 co2) ty1 +opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) + in_co2@(UnivCo p2 r2 _tyl2 tyr2) + | Just prov' <- opt_trans_prov p1 p2 + = ASSERT( r1 == r2 ) + fireTransRule "UnivCo" in_co1 in_co2 $ + mkUnivCo prov' r1 tyl1 tyr2 + where + -- if the provenances are different, opt'ing will be very confusing + opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv + opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) + = Just $ PhantomProv $ opt_trans is kco1 kco2 + opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) + = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 + opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 + opt_trans_prov _ _ = Nothing + -- Push transitivity down through matching top-level constructors. opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) | tc1 == tc2 = ASSERT( r1 == r2 ) fireTransRule "PushTyConApp" in_co1 in_co2 $ - TyConAppCo r1 tc1 (opt_transList is cos1 cos2) + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) = fireTransRule "TrPushApp" in_co1 in_co2 $ - mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkAppCo (opt_trans is co1a co2a) + (opt_trans is co1b co2b) -- Eta rules opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompL" co1 co2 $ - TyConAppCo r tc (opt_transList is cos1 cos2) + mkTyConAppCo r tc (opt_transList is cos1 cos2) opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) | Just cos1 <- etaTyConAppCo_maybe tc co1 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompR" co1 co2 $ - TyConAppCo r tc (opt_transList is cos1 cos2) + mkTyConAppCo r tc (opt_transList is cos1 cos2) opt_trans_rule is co1@(AppCo co1a co1b) co2 | Just (co2a,co2b) <- etaAppCo_maybe co2 = fireTransRule "EtaAppL" co1 co2 $ - mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkAppCo (opt_trans is co1a co2a) + (opt_trans is co1b co2b) opt_trans_rule is co1 co2@(AppCo co2a co2b) | Just (co1a,co1b) <- etaAppCo_maybe co1 = fireTransRule "EtaAppR" co1 co2 $ - mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + mkAppCo (opt_trans is co1a co2a) + (opt_trans is co1b co2b) -- Push transitivity inside forall opt_trans_rule is co1 co2 - | Just (tv1,r1) <- splitForAllCo_maybe co1 - , Just (tv2,r2) <- etaForAllCo_maybe co2 - , let r2' = substCoWithTy is' tv2 (mkTyVarTy tv1) r2 - is' = is `extendInScopeSet` tv1 - = fireTransRule "EtaAllL" co1 co2 $ - mkForAllCo tv1 (opt_trans2 is' r1 r2') - - | Just (tv2,r2) <- splitForAllCo_maybe co2 - , Just (tv1,r1) <- etaForAllCo_maybe co1 - , let r1' = substCoWithTy is' tv1 (mkTyVarTy tv2) r1 - is' = is `extendInScopeSet` tv2 - = fireTransRule "EtaAllR" co1 co2 $ - mkForAllCo tv1 (opt_trans2 is' r1' r2) + | ForAllCo tv1 eta1 r1 <- co1 + , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + | ForAllCo tv2 eta2 r2 <- co2 + , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + where + push_trans tv1 eta1 r1 tv2 eta2 r2 + = fireTransRule "EtaAllTy" co1 co2 $ + mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` tv1 + r2' = substCoWith [tv2] [TyVarTy tv1] r2 -- Push transitivity inside axioms opt_trans_rule is co1 co2 @@ -449,32 +576,32 @@ opt_trans_rule is co1 co2 -- See Note [Why call checkAxInstCo during optimisation] -- TrPushSymAxR | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , Just cos2 <- matchAxiom sym con ind co2 , True <- sym + , Just cos2 <- matchAxiom sym con ind co2 , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst -- TrPushAxR | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , Just cos2 <- matchAxiom sym con ind co2 , False <- sym + , Just cos2 <- matchAxiom sym con ind co2 , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushAxR" co1 co2 newAxInst -- TrPushSymAxL | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , Just cos1 <- matchAxiom (not sym) con ind co1 , True <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst -- TrPushAxL | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , Just cos1 <- matchAxiom (not sym) con ind co1 , False <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) , Nothing <- checkAxInstCo newAxInst = fireTransRule "TrPushAxL" co1 co2 newAxInst @@ -486,20 +613,28 @@ opt_trans_rule is co1 co2 , ind1 == ind2 , sym1 == not sym2 , let branch = coAxiomNthBranch con1 ind1 - qtvs = coAxBranchTyVars branch + qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch lhs = coAxNthLHS con1 ind1 rhs = coAxBranchRHS branch - pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs) + pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) , all (`elemVarSet` pivot_tvs) qtvs = fireTransRule "TrPushAxSym" co1 co2 $ if sym2 - then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym - else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx + -- TrPushAxSym + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs where co1_is_axiom_maybe = isAxiom_maybe co1 co2_is_axiom_maybe = isAxiom_maybe co2 role = coercionRole co1 -- should be the same as coercionRole co2! +opt_trans_rule is co1 co2 + | Just (lco, lh) <- isCohRight_maybe co1 + , Just (rco, rh) <- isCohLeft_maybe co2 + , (coercionType lh) `eqType` (coercionType rh) + = opt_trans_rule is lco rco + opt_trans_rule _ co1 co2 -- Identity rule | (Pair ty1 _, r) <- coercionKindRole co1 , Pair _ ty2 <- coercionKind co2 @@ -524,9 +659,9 @@ type instance where Equal a a = True Equal a b = False -- -Equal :: forall k::BOX. k -> k -> Bool -axEqual :: { forall k::BOX. forall a::k. Equal k a a ~ True - ; forall k::BOX. forall a::k. forall b::k. Equal k a b ~ False } +Equal :: forall k::*. k -> k -> Bool +axEqual :: { forall k::*. forall a::k. Equal k a a ~ True + ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } We wish to disallow (axEqual[1] <*> <Int> <Int). (Recall that the index is 0-based, so this is the second branch of the axiom.) The problem is that, on @@ -579,14 +714,17 @@ checkAxInstCo :: Coercion -> Maybe CoAxBranch -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] in CoreLint checkAxInstCo (AxiomInstCo ax ind cos) - = let branch = coAxiomNthBranch ax ind - tvs = coAxBranchTyVars branch - incomps = coAxBranchIncomps branch - tys = map (pFst . coercionKind) cos - subst = zipOpenTvSubst tvs tys + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos) + co_args = map stripCoercionTy cotys + subst = zipOpenTCvSubst tvs tys `composeTCvSubst` + zipOpenTCvSubstCoVars cvs co_args target = Type.substTys subst (coAxBranchLHS branch) in_scope = mkInScopeSet $ - unionVarSets (map (tyVarsOfTypes . coAxBranchLHS) incomps) + unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) flattened_target = flattenTys in_scope target in check_no_conflict flattened_target incomps where @@ -600,6 +738,7 @@ checkAxInstCo (AxiomInstCo ax ind cos) = Just b checkAxInstCo _ = Nothing + ----------- wrapSym :: SymFlag -> Coercion -> Coercion wrapSym sym co | sym = SymCo co @@ -619,18 +758,7 @@ chooseRole :: ReprFlag -> Role chooseRole True _ = Representational chooseRole _ r = r ------------ --- takes two tyvars and builds env'ts to map them to the same tyvar -substTyVarBndr2 :: CvSubst -> TyVar -> TyVar - -> (CvSubst, CvSubst, TyVar) -substTyVarBndr2 env tv1 tv2 - = case substTyVarBndr env tv1 of - (env1, tv1') -> (env1, extendTvSubstAndInScope env tv2 (mkTyVarTy tv1'), tv1') - -zapCvSubstEnv2 :: CvSubst -> CvSubst -> CvSubst -zapCvSubstEnv2 env1 env2 = mkCvSubst (is1 `unionInScope` is2) [] - where is1 = getCvInScope env1 - is2 = getCvInScope env2 + ----------- isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) isAxiom_maybe (SymCo co) @@ -642,16 +770,32 @@ isAxiom_maybe _ = Nothing matchAxiom :: Bool -- True = match LHS, False = match RHS -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] --- If we succeed in matching, then *all the quantified type variables are bound* --- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co - = let (CoAxBranch { cab_tvs = qtvs - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs }) = coAxiomNthBranch ax ind in - case liftCoMatch (mkVarSet qtvs) (if sym then (mkTyConApp tc lhs) else rhs) co of - Nothing -> Nothing - Just subst -> zipWithM (liftCoSubstTyVar subst) roles qtvs + | CoAxBranch { cab_tvs = qtvs + , cab_cvs = [] -- can't infer these, so fail if there are any + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , Just subst <- liftCoMatch (mkVarSet qtvs) + (if sym then (mkTyConApp tc lhs) else rhs) + co + , all (`isMappedByLC` subst) qtvs + = zipWithM (liftCoSubstTyVar subst) roles qtvs + + | otherwise + = Nothing + +------------- +-- destruct a CoherenceCo +isCohLeft_maybe :: Coercion -> Maybe (Coercion, Coercion) +isCohLeft_maybe (CoherenceCo co1 co2) = Just (co1, co2) +isCohLeft_maybe _ = Nothing + +-- destruct a (sym (co1 |> co2)). +-- if isCohRight_maybe co = Just (co1, co2), then (sym co1) `mkCohRightCo` co2 = co +isCohRight_maybe :: Coercion -> Maybe (Coercion, Coercion) +isCohRight_maybe (SymCo (CoherenceCo co1 co2)) = Just (mkSymCo co1, co2) +isCohRight_maybe _ = Nothing ------------- compatible_co :: Coercion -> Coercion -> Bool @@ -663,17 +807,43 @@ compatible_co co1 co2 Pair x2 _ = coercionKind co2 ------------- -etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) --- Try to make the coercion be of form (forall tv. co) +{- +etaForAllCo_maybe +~~~~~~~~~~~~~~~~~ +Suppose we have + + g : all a1:k1.t1 ~ all a2:k2.t2 + +but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: + + g' = all a1:(ForAllKindCo g).(InstCo g (a1 `mkCoherenceRightCo` ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h2)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h2)][a1 |-> a1 |> sym h2]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. +-} +etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall tv:kind_co. co) etaForAllCo_maybe co - | Just (tv, r) <- splitForAllCo_maybe co - = Just (tv, r) + | ForAllCo tv kind_co r <- co + = Just (tv, kind_co, r) | Pair ty1 ty2 <- coercionKind co , Just (tv1, _) <- splitForAllTy_maybe ty1 - , Just (tv2, _) <- splitForAllTy_maybe ty2 - , tyVarKind tv1 `eqKind` tyVarKind tv2 - = Just (tv1, mkInstCo co (mkTyVarTy tv1)) + , isForAllTy ty2 + , let kind_co = mkNthCo 0 co + = Just ( tv1, kind_co + , mkInstCo co (mkNomReflCo (TyVarTy tv1) `mkCoherenceRightCo` kind_co) ) | otherwise = Nothing @@ -688,7 +858,9 @@ etaAppCo_maybe co | (Pair ty1 ty2, Nominal) <- coercionKindRole co , Just (_,t1) <- splitAppTy_maybe ty1 , Just (_,t2) <- splitAppTy_maybe ty2 - , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 = Just (LRCo CLeft co, LRCo CRight co) | otherwise = Nothing @@ -738,4 +910,10 @@ because if g is well-kinded then kind (s1 t2) = kind (s2 t2) and these two imply kind s1 = kind s2 + -} + +optForAllCoBndr :: LiftingContext -> Bool + -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion) +optForAllCoBndr env sym + = substForAllCoBndrCallbackLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs new file mode 100644 index 0000000000..c25bd11d94 --- /dev/null +++ b/compiler/types/TyCoRep.hs @@ -0,0 +1,2496 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +\section[TyCoRep]{Type and Coercion - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Class + CoAxiom + TyCon imports Class, CoAxiom + TyCoRep imports Class, CoAxiom, TyCon + TysPrim imports TyCoRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type +-} + +-- We expose the relevant stuff from this module via the Type module +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable, MultiWayIf #-} + +module TyCoRep ( + TyThing(..), + Type(..), + TyBinder(..), + TyLit(..), + KindOrType, Kind, + PredType, ThetaType, -- Synonyms + VisibilityFlag(..), + + -- Coercions + Coercion(..), LeftOrRight(..), + UnivCoProvenance(..), CoercionHole(..), + + -- Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkFunTy, mkFunTys, + isLiftedTypeKind, isUnliftedTypeKind, + isCoercionType, isLevityTy, isLevityVar, + + -- Functions over binders + binderType, delBinderVar, + + -- Functions over coercions + pickLR, + + -- Pretty-printing + pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, + pprTyThing, pprTyThingCategory, pprSigmaType, + pprTheta, pprForAll, pprForAllImplicit, pprUserForAll, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + TyPrec(..), maybeParen, pprTcAppCo, pprTcAppTy, + pprPrefixApp, pprArrowChain, ppr_type, + pprDataCons, + + -- Free variables + tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, + tyCoVarsOfTypeAcc, tyCoVarsOfTypeList, + tyCoVarsOfTypesAcc, tyCoVarsOfTypesList, + closeOverKindsDSet, closeOverKindsAcc, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, + tyCoVarsOfCoDSet, + tyCoVarsOfCoAcc, tyCoVarsOfCosAcc, + tyCoVarsOfCoList, tyCoVarsOfProv, + closeOverKinds, + tyCoVarsOfTelescope, + + -- Substitutions + TCvSubst(..), TvSubstEnv, CvSubstEnv, + emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, + emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, mkTCvSubst, getTvSubstEnv, + getCvSubstEnv, getTCvInScope, isInScope, notElemTCvSubst, + setTvSubstEnv, setCvSubstEnv, zapTCvSubst, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendTCvSubstAndInScope, extendTCvSubstList, + extendTCvSubstBinder, + unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, + mkOpenTCvSubst, zipOpenTCvSubst, zipOpenTCvSubstCoVars, + zipOpenTCvSubstBinders, + mkTopTCvSubst, zipTopTCvSubst, + + substTelescope, + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, + substTyWithBinders, + substTys, substTheta, + lookupTyVar, substTyVarBndr, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + substCoVarBndr, cloneTyVarBndr, cloneTyVarBndrs, + substTyVar, substTyVars, + substForAllCoBndr, + substTyVarBndrCallback, substForAllCoBndrCallback, + substCoVarBndrCallback, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyVarOcc, + tidyTopType, + tidyKind, + tidyCo, tidyCos + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DataCon( dataConTyCon, dataConFullSig + , DataCon, eqSpecTyVar ) +import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy + , partitionInvisibles ) + -- Transitively pulls in a LOT of stuff, better to break the loop + +import {-# SOURCE #-} Coercion +import {-# SOURCE #-} ConLike ( ConLike(..) ) + +-- friends: +import Var +import VarEnv +import VarSet +import Name hiding ( varName ) +import BasicTypes +import TyCon +import Class +import CoAxiom +import FV + +-- others +import PrelNames +import Binary +import Outputable +import DynFlags +import StaticFlags ( opt_PprStyle_Debug ) +import FastString +import Pair +import UniqSupply +import ListSetOps +import Util + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.List +import Data.IORef ( IORef ) -- for CoercionHole + +{- +%************************************************************************ +%* * +\subsection{The data type} +%* * +%************************************************************************ +-} + +-- | The key representation of types within the compiler + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy -- See Note [AppTy rep] + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp', + -- must be another 'AppTy', or 'TyVarTy' + -- + -- 2) Argument type + + | TyConApp -- See Note [AppTy rep] + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated applications of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | ForAllTy + TyBinder + Type -- ^ A Π type. + -- This includes arrow types, constructed with + -- @ForAllTy (Anon ...)@. + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + Coercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never refl. + -- INVARIANT: The cast is "pushed down" as far as it + -- can go. See Note [Pushing down casts] + + | CoercionTy + Coercion -- ^ Injection of a Coercion into a type + -- This should only ever be used in the RHS of an AppTy, + -- in the list of a TyConApp, when applying a promoted + -- GADT data constructor + + deriving (Data.Data, Data.Typeable) + + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data, Data.Typeable) + +-- | A 'TyBinder' represents an argument to a function. TyBinders can be dependent +-- ('Named') or nondependent ('Anon'). They may also be visible or not. +data TyBinder + = Named TyVar VisibilityFlag + | Anon Type -- visibility is determined by the type (Constraint vs. *) + deriving (Data.Typeable, Data.Data) + +-- | Is something required to appear in source Haskell ('Visible') or +-- prohibited from appearing in source Haskell ('Invisible')? +data VisibilityFlag = Visible | Invisible + deriving (Eq, Data.Typeable, Data.Data) + +instance Binary VisibilityFlag where + put_ bh Visible = putByte bh 0 + put_ bh Invisible = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return Visible + _ -> return Invisible + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +{- +Note [The kind invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The kinds + # UnliftedTypeKind + OpenKind super-kind of *, # + +can never appear under an arrow or type constructor in a kind; they +can only be at the top level of a kind. It follows that primitive TyCons, +which have a naughty pseudo-kind + State# :: * -> # +must always be saturated, so that we can never get a type whose kind +has a UnliftedTypeKind or ArgTypeKind underneath an arrow. + +Nor can we abstract over a type variable with any of these kinds. + + k :: = kk | # | ArgKind | (#) | OpenKind + kk :: = * | kk -> kk | T kk1 ... kkn + +So a type variable can only be abstracted kk. + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + +Note [Pushing down casts] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (a :: k1 -> *), (b :: k1), and (co :: * ~ q). +The type (a b |> co) is `eqType` to ((a |> co') b), where +co' = (->) <k1> co. Thus, to make this visible to functions +that inspect types, we always push down coercions, preferring +the second form. Note that this also applies to TyConApps! + +Note [Non-trivial definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is Int |> <*> the same as Int? YES! In order to reduce headaches, +we decide that any reflexive casts in types are just ignored. More +generally, the `eqType` function, which defines Core's type equality +relation, ignores casts and coercion arguments, as long as the +two types have the same kind. This allows us to be a little sloppier +in keeping track of coercions, which is a good thing. It also means +that eqType does not depend on eqCoercion, which is also a good thing. + +------------------------------------- + Note [PredTy] +-} + +-- | A type of the form @p@ of kind @Constraint@ represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to have +-- this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + +%************************************************************************ +%* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type +-} + +-- named with "Only" to prevent naive use of mkTyVarTy +mkTyVarTy :: TyVar -> Type +mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) + TyVarTy v + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +infixr 3 `mkFunTy` -- Associates to the right +-- | Make an arrow type +mkFunTy :: Type -> Type -> Type +mkFunTy arg res + = ForAllTy (Anon arg) res + +-- | Make nested arrow types +mkFunTys :: [Type] -> Type -> Type +mkFunTys tys ty = foldr mkFunTy ty tys + +-- | Does this type classify a core Coercion? +isCoercionType :: Type -> Bool +isCoercionType (TyConApp tc tys) + | (tc `hasKey` eqPrimTyConKey) || (tc `hasKey` eqReprPrimTyConKey) + , length tys == 4 + = True +isCoercionType _ = False + +binderType :: TyBinder -> Type +binderType (Named v _) = varType v +binderType (Anon ty) = ty + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyBinder -> VarSet +delBinderVar vars (Named tv _) = vars `delVarSet` tv +delBinderVar vars (Anon {}) = vars + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVarFV :: TyBinder -> FV -> FV +delBinderVarFV (Named tv _) vars fv_cand in_scope acc = delFV tv vars fv_cand in_scope acc +delBinderVarFV (Anon {}) vars fv_cand in_scope acc = vars fv_cand in_scope acc + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +{- +Some basic functions, put here to break loops eg with the pretty printer +-} + +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindTyConName (tyConName tc) +isLiftedTypeKind (TyConApp tc [TyConApp lev []]) + = tc `hasKey` tYPETyConKey && lev `hasKey` liftedDataConKey +isLiftedTypeKind _ = False + +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind (TyConApp tc []) = tc `hasKey` unliftedTypeKindTyConKey +isUnliftedTypeKind (TyConApp tc [TyConApp lev []]) + = tc `hasKey` tYPETyConKey && lev `hasKey` unliftedDataConKey +isUnliftedTypeKind _ = False + +-- | Is this the type 'Levity'? +isLevityTy :: Type -> Bool +isLevityTy (TyConApp tc []) = tc `hasKey` levityTyConKey +isLevityTy _ = False + +-- | Is a tyvar of type 'Levity'? +isLevityVar :: TyVar -> Bool +isLevityVar = isLevityTy . tyVarKind + +{- +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. P, N, and R stand for coercions of the + -- given role. e stands for a coercion of a specific unknown role (think + -- "role polymorphism"). "e" stands for an explicit role parameter + -- indicating role e. _ stands for a parameter that is not a Role or + -- Coercion. + + -- These ones mirror the shape of types + = -- Refl :: "e" -> _ -> e + Refl Role Type -- See Note [Refl invariant] + -- Invariant: applications of (Refl T) to a bunch of identity coercions + -- always show up as Refl. + -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). + + -- Applications of (Refl T) to some coercions, at least one of + -- which is NOT the identity, show up as TyConAppCo. + -- (They may not be fully saturated however.) + -- ConAppCo coercions (like all coercions other than Refl) + -- are NEVER the identity. + + -- Use (Refl Representational _), not (SubCo (Refl Nominal _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + + | AppCo Coercion Coercion -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyVar Coercion Coercion + -- ForAllCo :: _ -> N -> e -> e + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> [N] -> e + | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] + -- See also [CoAxiom index] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. + -- See [Coercion axioms applied to coercions] + + | UnivCo UnivCoProvenance Role Type Type + -- :: _ -> "e" -> _ -> _ -> e + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + | AxiomRuleCo CoAxiomRule [Coercion] + + | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- Using NthCo on a ForAllCo gives an N coercion always + -- See Note [NthCo and newtypes] + + | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion Coercion + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Coherence applies a coercion to the left-hand type of another coercion + -- See Note [Coherence] + | CoherenceCo Coercion Coercion + -- :: e -> N -> e + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo Coercion -- Turns a ~N into a ~R + -- :: N -> R + + deriving (Data.Data, Data.Typeable) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data LeftOrRight = CLeft | CRight + deriving( Eq, Data.Data, Data.Typeable ) + +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +{- +%************************************************************************ +%* * + UnivCo Provenance +%* * +%************************************************************************ + +Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~ +During typechecking, we emit constraints for kind coercions, to be used +to cast a type's kind. These coercions then must be used in types. Because +they might appear in a top-level type, there is no place to bind these +(unlifted) coercions in the usual way. So, instead of creating a coercion +variable and then solving for the variable, we use a coercion hole, which +is just an unnamed mutable cell. During type-checking, the holes are filled +in. The Unique carried with a coercion hole is used solely for debugging. +Coercion holes can be compared for equality only like other coercions: +only by looking at the types coerced. + +Holes should never appear in Core. If, one day, we use type-level information +to separate out forms that can appear during type-checking vs forms that can +appear in core proper, holes in Core will be ruled out. (This is quite like +the fact that Type can, technically, store TcTyVars but never do.) + +Note that we don't use holes for other evidence because other evidence wants +to be shared. But coercions are entirely erased, so there's little benefit +to sharing. + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIreelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~ Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG co1 a1) ~ ('MkG co2 a2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) + where + co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) + co5 = TyConAppCo Nominal (~) [<*>, <*>, co4, <Bool>] + +-} + +-- | For simplicity, we have just one UnivCo that represents a coercion from +-- some type to some other type, with (in general) no restrictions on the +-- type. To make better sense of these, we tag a UnivCo with a +-- UnivCoProvenance. This provenance is rarely consulted and is more +-- for debugging info than anything else. +-- An important exception to this rule is that we also use a UnivCo +-- for coercion holes. See Note [Coercion holes]. +data UnivCoProvenance + = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. + | PhantomProv Coercion -- ^ From the need to create a phantom coercion; + -- the UnivCo must be Phantom. The Coercion stored is + -- the (nominal) kind coercion between the types + | ProofIrrelProv Coercion -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv] + | PluginProv String -- ^ From a plugin, which asserts that this coercion + -- is sound. The string is for the use of the plugin. + | HoleProv CoercionHole -- ^ See Note [Coercion holes] + deriving (Data.Data, Data.Typeable) + +instance Outputable UnivCoProvenance where + ppr UnsafeCoerceProv = text "(unsafeCoerce#)" + ppr (PhantomProv _) = text "(phantom)" + ppr (ProofIrrelProv _) = text "(proof irrel.)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + ppr (HoleProv hole) = parens (text "hole" <> ppr hole) + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { chUnique :: Unique -- ^ used only for debugging + , chCoercion :: (IORef (Maybe Coercion)) + } + deriving (Data.Typeable) + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole u _) = braces (ppr u) + +{- +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: + +Coercions have the following invariant + Refl is always lifted as far as possible. + +You might think that a consequencs is: + Every identity coercions has Refl at the root + +But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int +etc. So the consequence is only true of coercions that +have no coercion variables. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [CoAxiom index] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) + +The Int in the AxiomInstCo constructor is the 0-indexed number +of the chosen branch. + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky, +because the kinds of the bound tyvars can be different. + +The typing rule is: + + + kind_co : k1 ~ k2 + tv1:k1 |- co : t1 ~ t2 + ------------------------------------------------------------------- + ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ + all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) + +First, the TyVar stored in a ForAllCo is really an optimisation: this field +should be a Name, as its kind is redundant. Thinking of the field as a Name +is helpful in understanding what a ForAllCo means. + +The idea is that kind_co gives the two kinds of the tyvar. See how, in the +conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + +Of course, a type variable can't have different kinds at the same time. So, +we arbitrarily prefer the first kind when using tv1 in the inner coercion +co, which shows that t1 equals t2. + +The last wrinkle is that we need to fix the kinds in the conclusion. In +t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of +the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with +(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it +mentions the same name with different kinds, but it *is* well-kinded, noting +that `(tv1:k2) |> sym kind_co` has kind k1. + +This all really would work storing just a Name in the ForAllCo. But we can't +add Names to, e.g., VarSets, and there generally is just an impedence mismatch +in a bunch of places. So we use tv1. When we need tv2, we can use +setTyVarKind. + +Note [Coherence] +~~~~~~~~~~~~~~~~ +The Coherence typing rule is thus: + + g1 : s ~ t s : k1 g2 : k1 ~ k2 + ------------------------------------ + CoherenceCo g1 g2 : (s |> g2) ~ t + +While this looks (and is) unsymmetric, a combination of other coercion +combinators can make the symmetric version. + +For role information, see Note [Roles and kind coercions]. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + + type instance F Int = Bool -- Axiom axF : F Int ~N Bool + newtype Age = MkAge Int -- Axiom axAge : Age ~R Int + data Foo a = MkFoo a -- Role on Foo's parameter is Representational + +TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool + For (TyConAppCo Nominal) all arguments must have role Nominal. Why? + So that Foo Age ~N Foo Int does *not* hold. + +TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool +TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int + For (TyConAppCo Representational), all arguments must have the roles + corresponding to the result of tyConRoles on the TyCon. This is the + whole point of having roles on the TyCon to begin with. So, we can + have Foo Age ~R Foo Int, if Foo's parameter has role R. + + If a Representational TyConAppCo is over-saturated (which is otherwise fine), + the spill-over arguments must all be at Nominal. This corresponds to the + behavior for AppCo. + +TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool + All arguments must have role Phantom. This one isn't strictly + necessary for soundness, but this choice removes ambiguity. + +The rules here dictate the roles of the parameters to mkTyConAppCo +(should be checked by Lint). + +Note [NthCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +NthCo, we'll get out a representational coercion. That is: + + NthCo 0 co :: forall a b. a ~R b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +NthCo to be used on newtypes if the internal coercion is representational. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +Note [InstCo roles] +~~~~~~~~~~~~~~~~~~~ +Here is (essentially) the typing rule for InstCo: + +g :: (forall a. t1) ~r (forall a. t2) +w :: s1 ~N s2 +------------------------------- InstCo +InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) + +Note that the Coercion w *must* be nominal. This is necessary +because the variable a might be used in a "nominal position" +(that is, a place where role inference would require a nominal +role) in t1 or t2. If we allowed w to be representational, we +could get bogus equalities. + +A more nuanced treatment might be able to relax this condition +somewhat, by checking if t1 and/or t2 use their bound variables +in nominal ways. If not, having w be representational is OK. + +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +-- | Returns free variables of a type, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfType :: Type -> TyCoVarSet +tyCoVarsOfType ty = runFVSet $ tyCoVarsOfTypeAcc ty + +-- | `tyVarsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet +tyCoVarsOfTypeDSet ty = runFVDSet $ tyCoVarsOfTypeAcc ty + +-- | `tyVarsOfType` that returns free variables of a type in deterministic +-- order. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeList :: Type -> [TyCoVar] +tyCoVarsOfTypeList ty = runFVList $ tyCoVarsOfTypeAcc ty + +-- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`. +-- The previous implementation used `unionVarSet` which is O(n+m) and can +-- make the function quadratic. +-- It's exported, so that it can be composed with other functions that compute +-- free variables. +-- See Note [FV naming conventions] in FV. +tyCoVarsOfTypeAcc :: Type -> FV +tyCoVarsOfTypeAcc (TyVarTy v) fv_cand in_scope acc = (oneVar v `unionFV` tyCoVarsOfTypeAcc (tyVarKind v)) fv_cand in_scope acc +tyCoVarsOfTypeAcc (TyConApp _ tys) fv_cand in_scope acc = tyCoVarsOfTypesAcc tys fv_cand in_scope acc +tyCoVarsOfTypeAcc (LitTy {}) fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfTypeAcc (AppTy fun arg) fv_cand in_scope acc = (tyCoVarsOfTypeAcc fun `unionFV` tyCoVarsOfTypeAcc arg) fv_cand in_scope acc +tyCoVarsOfTypeAcc (ForAllTy bndr ty) fv_cand in_scope acc + = (delBinderVarFV bndr (tyCoVarsOfTypeAcc ty) + `unionFV` tyCoVarsOfTypeAcc (binderType bndr)) fv_cand in_scope acc +tyCoVarsOfTypeAcc (CastTy ty co) fv_cand in_scope acc = (tyCoVarsOfTypeAcc ty `unionFV` tyCoVarsOfCoAcc co) fv_cand in_scope acc +tyCoVarsOfTypeAcc (CoercionTy co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +tyCoVarsOfTypes tys = runFVSet $ tyCoVarsOfTypesAcc tys + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +tyCoVarsOfTypesDSet tys = runFVDSet $ tyCoVarsOfTypesAcc tys + +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesList :: [Type] -> [TyCoVar] +tyCoVarsOfTypesList tys = runFVList $ tyCoVarsOfTypesAcc tys + +tyCoVarsOfTypesAcc :: [Type] -> FV +tyCoVarsOfTypesAcc (ty:tys) fv_cand in_scope acc = (tyCoVarsOfTypeAcc ty `unionFV` tyCoVarsOfTypesAcc tys) fv_cand in_scope acc +tyCoVarsOfTypesAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +tyCoVarsOfCo co = runFVSet $ tyCoVarsOfCoAcc co + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +tyCoVarsOfCoDSet co = runFVDSet $ tyCoVarsOfCoAcc co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +tyCoVarsOfCoList co = runFVList $ tyCoVarsOfCoAcc co + +tyCoVarsOfCoAcc :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +tyCoVarsOfCoAcc (Refl _ ty) fv_cand in_scope acc = tyCoVarsOfTypeAcc ty fv_cand in_scope acc +tyCoVarsOfCoAcc (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoVarsOfCosAcc cos fv_cand in_scope acc +tyCoVarsOfCoAcc (AppCo co arg) fv_cand in_scope acc + = (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCoAcc arg) fv_cand in_scope acc +tyCoVarsOfCoAcc (ForAllCo tv kind_co co) fv_cand in_scope acc + = (delFV tv (tyCoVarsOfCoAcc co) `unionFV` tyCoVarsOfCoAcc kind_co) fv_cand in_scope acc +tyCoVarsOfCoAcc (CoVarCo v) fv_cand in_scope acc + = (oneVar v `unionFV` tyCoVarsOfTypeAcc (varType v)) fv_cand in_scope acc +tyCoVarsOfCoAcc (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoVarsOfCosAcc cos fv_cand in_scope acc +tyCoVarsOfCoAcc (UnivCo p _ t1 t2) fv_cand in_scope acc + = (tyCoVarsOfProvAcc p `unionFV` tyCoVarsOfTypeAcc t1 + `unionFV` tyCoVarsOfTypeAcc t2) fv_cand in_scope acc +tyCoVarsOfCoAcc (SymCo co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (TransCo co1 co2) fv_cand in_scope acc = (tyCoVarsOfCoAcc co1 `unionFV` tyCoVarsOfCoAcc co2) fv_cand in_scope acc +tyCoVarsOfCoAcc (NthCo _ co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (LRCo _ co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (InstCo co arg) fv_cand in_scope acc = (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCoAcc arg) fv_cand in_scope acc +tyCoVarsOfCoAcc (CoherenceCo c1 c2) fv_cand in_scope acc = (tyCoVarsOfCoAcc c1 `unionFV` tyCoVarsOfCoAcc c2) fv_cand in_scope acc +tyCoVarsOfCoAcc (KindCo co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (SubCo co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfCoAcc (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoVarsOfCosAcc cs fv_cand in_scope acc + +tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet +tyCoVarsOfProv prov = runFVSet $ tyCoVarsOfProvAcc prov + +tyCoVarsOfProvAcc :: UnivCoProvenance -> FV +tyCoVarsOfProvAcc UnsafeCoerceProv fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfProvAcc (PhantomProv co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfProvAcc (ProofIrrelProv co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc +tyCoVarsOfProvAcc (PluginProv _) fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfProvAcc (HoleProv _) fv_cand in_scope acc = noVars fv_cand in_scope acc + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = runFVSet $ tyCoVarsOfCosAcc cos + +tyCoVarsOfCosAcc :: [Coercion] -> FV +tyCoVarsOfCosAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc +tyCoVarsOfCosAcc (co:cos) fv_cand in_scope acc = (tyCoVarsOfCoAcc co `unionFV` tyCoVarsOfCosAcc cos) fv_cand in_scope acc + +coVarsOfType :: Type -> CoVarSet +coVarsOfType (TyVarTy v) = coVarsOfType (tyVarKind v) +coVarsOfType (TyConApp _ tys) = coVarsOfTypes tys +coVarsOfType (LitTy {}) = emptyVarSet +coVarsOfType (AppTy fun arg) = coVarsOfType fun `unionVarSet` coVarsOfType arg +coVarsOfType (ForAllTy bndr ty) + = coVarsOfType ty `delBinderVar` bndr + `unionVarSet` coVarsOfType (binderType bndr) +coVarsOfType (CastTy ty co) = coVarsOfType ty `unionVarSet` coVarsOfCo co +coVarsOfType (CoercionTy co) = coVarsOfCo co + +coVarsOfTypes :: [Type] -> TyCoVarSet +coVarsOfTypes tys = mapUnionVarSet coVarsOfType tys + +coVarsOfCo :: Coercion -> CoVarSet +-- Extract *coercion* variables only. Tiresome to repeat the code, but easy. +coVarsOfCo (Refl _ ty) = coVarsOfType ty +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 (CoVarCo v) = unitVarSet v `unionVarSet` coVarsOfType (varType v) +coVarsOfCo (AxiomInstCo _ _ args) = coVarsOfCos args +coVarsOfCo (UnivCo p _ t1 t2) = coVarsOfProv p `unionVarSet` coVarsOfTypes [t1, t2] +coVarsOfCo (SymCo co) = coVarsOfCo co +coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (LRCo _ co) = coVarsOfCo co +coVarsOfCo (InstCo co arg) = coVarsOfCo co `unionVarSet` coVarsOfCo arg +coVarsOfCo (CoherenceCo c1 c2) = coVarsOfCos [c1, c2] +coVarsOfCo (KindCo co) = coVarsOfCo co +coVarsOfCo (SubCo co) = coVarsOfCo co +coVarsOfCo (AxiomRuleCo _ cs) = coVarsOfCos cs + +coVarsOfProv :: UnivCoProvenance -> CoVarSet +coVarsOfProv UnsafeCoerceProv = emptyVarSet +coVarsOfProv (PhantomProv co) = coVarsOfCo co +coVarsOfProv (ProofIrrelProv co) = coVarsOfCo co +coVarsOfProv (PluginProv _) = emptyVarSet +coVarsOfProv (HoleProv _) = emptyVarSet + +coVarsOfCos :: [Coercion] -> CoVarSet +coVarsOfCos cos = mapUnionVarSet coVarsOfCo cos + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyVarSet -> TyVarSet +closeOverKinds = runFVSet . closeOverKindsAcc . varSetElems + +-- | Given a list of tyvars returns a deterministic FV computation that +-- returns the given tyvars with the kind variables free in the kinds of the +-- given tyvars. +closeOverKindsAcc :: [TyVar] -> FV +closeOverKindsAcc tvs = + mapUnionFV (tyCoVarsOfTypeAcc . tyVarKind) tvs `unionFV` someVars tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = runFVDSet . closeOverKindsAcc . dVarSetElems + +-- | Gets the free vars of a telescope, scoped over a given free var set. +tyCoVarsOfTelescope :: [Var] -> TyCoVarSet -> TyCoVarSet +tyCoVarsOfTelescope [] fvs = fvs +tyCoVarsOfTelescope (v:vs) fvs = tyCoVarsOfTelescope vs fvs + `delVarSet` v + `unionVarSet` tyCoVarsOfType (varType v) +{- +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See 'TcEnv' for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + deriving (Eq, Ord) + +instance Outputable TyThing where + ppr = pprTyThing + +pprTyThing :: TyThing -> SDoc +pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory (ATyCon tc) + | isClassTyCon tc = ptext (sLit "Class") + | otherwise = ptext (sLit "Type constructor") +pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") +pprTyThingCategory (AnId _) = ptext (sLit "Identifier") +pprTyThingCategory (AConLike (RealDataCon _)) = ptext (sLit "Data constructor") +pprTyThingCategory (AConLike (PatSynCon _)) = ptext (sLit "Pattern synonym") + + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = getName cl + +{- +%************************************************************************ +%* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +%* * +%************************************************************************ +-} + +-- | Type & coercion substitution +-- +-- #tcvsubst_invariant# +-- The following invariants must hold of a 'TCvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substitution is only applied ONCE! This is because +-- in general such application will not reach a fixed point. +data TCvSubst + = TCvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables + CvSubstEnv -- Substitutes coercion variables + -- See Note [Apply Once] + -- and Note [Extending the TvSubstEnv] + -- and Note [Substituting types and coercions] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- A TvSubstEnv is used both inside a TCvSubst (with the apply-once + -- invariant discussed in Note [Apply Once]), and also independently + -- in the middle of matching, and unification (see Types.Unify) + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +-- | A substitution of 'Coercion's for 'CoVar's +type CvSubstEnv = CoVarEnv Coercion + +{- +Note [Apply Once] +~~~~~~~~~~~~~~~~~ +We use TCvSubsts to instantiate things, and we might instantiate + forall a b. ty +\with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + **************************************************** + *** So a TCvSubst must be applied precisely once *** + **************************************************** + +A TCvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tcvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the subst envs are empty: +if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) +holds --- then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substTyVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + +Note [Substituting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types and coercions are mutually recursive, and either may have variables +"belonging" to the other. Thus, every time we wish to substitute in a +type, we may also need to substitute in a coercion, and vice versa. +However, the constructor used to create type variables is distinct from +that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note +that it would be possible to use the CoercionTy constructor to combine +these environments, but that seems like a false economy. + +Note that the TvSubstEnv should *never* map a CoVar (built with the Id +constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, +the range of the TvSubstEnv should *never* include a type headed with +CoercionTy. +-} + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +composeTCvSubstEnv :: InScopeSet + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ +composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) + = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 + , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TCvSubst in_scope tenv1 cenv1 + +-- | Composes two substitutions, applying the second one provided first, +-- like in function composition. +composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) + = TCvSubst is3 tenv3 cenv3 + where + is3 = is1 `unionInScope` is2 + (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + +emptyTCvSubst :: TCvSubst +emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + +mkEmptyTCvSubst :: InScopeSet -> TCvSubst +mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv + +isEmptyTCvSubst :: TCvSubst -> Bool + -- See Note [Extending the TvSubstEnv] +isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst +mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv + +getTvSubstEnv :: TCvSubst -> TvSubstEnv +getTvSubstEnv (TCvSubst _ env _) = env + +getCvSubstEnv :: TCvSubst -> CvSubstEnv +getCvSubstEnv (TCvSubst _ _ env) = env + +getTCvInScope :: TCvSubst -> InScopeSet +getTCvInScope (TCvSubst in_scope _ _) = in_scope + +isInScope :: Var -> TCvSubst -> Bool +isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope + +notElemTCvSubst :: Var -> TCvSubst -> Bool +notElemTCvSubst v (TCvSubst _ tenv cenv) + | isTyVar v + = not (v `elemVarEnv` tenv) + | otherwise + = not (v `elemVarEnv` cenv) + +setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst +setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + +setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst +setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv + +zapTCvSubst :: TCvSubst -> TCvSubst +zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv + +extendTCvInScope :: TCvSubst -> Var -> TCvSubst +extendTCvInScope (TCvSubst in_scope tenv cenv) var + = TCvSubst (extendInScopeSet in_scope var) tenv cenv + +extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst +extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv + +extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst +extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv + +extendSubstEnvs :: (TvSubstEnv, CvSubstEnv) -> Var -> Type + -> (TvSubstEnv, CvSubstEnv) +extendSubstEnvs (tenv, cenv) v ty + | isTyVar v + = ASSERT( not $ isCoercionTy ty ) + (extendVarEnv tenv v ty, cenv) + + -- NB: v might *not* be a proper covar, because it might be lifted. + -- This happens in tcCoercionToCoercion + | CoercionTy co <- ty + = (tenv, extendVarEnv cenv v co) + | otherwise + = pprPanic "extendSubstEnvs" (ppr v <+> ptext (sLit "|->") <+> ppr ty) + +extendTCvSubst :: TCvSubst -> Var -> Type -> TCvSubst +extendTCvSubst (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst in_scope tenv' cenv' + where (tenv', cenv') = extendSubstEnvs (tenv, cenv) tv ty + +extendTCvSubstAndInScope :: TCvSubst -> TyCoVar -> Type -> TCvSubst +-- Also extends the in-scope set +extendTCvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + tenv' cenv' + where (tenv', cenv') = extendSubstEnvs (tenv, cenv) tv ty + +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +extendTCvSubstBinder :: TCvSubst -> TyBinder -> Type -> TCvSubst +extendTCvSubstBinder env (Anon {}) _ = env +extendTCvSubstBinder env (Named tv _) ty = extendTCvSubst env tv ty + +unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +-- Works when the ranges are disjoint +unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) + && not (cenv1 `intersectsVarEnv` cenv2) ) + TCvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- mkOpenTCvSubst and zipOpenTCvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +-- Note [Generating the in-scope set for a substitution] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we want to substitute [a -> ty1, b -> ty2] I used to +-- think it was enough to generate an in-scope set that includes +-- fv(ty1,ty2). But that's not enough; we really should also take the +-- free vars of the type we are substituting into! Example: +-- (forall b. (a,b,x)) [a -> List b] +-- Then if we use the in-scope set {b}, there is a danger we will rename +-- the forall'd variable to 'x' by mistake, getting this: +-- (forall x. (List b, x, x)) +-- Urk! This means looking at all the calls to mkOpenTCvSubst.... + + +-- | Generates an in-scope set from the free variables in a list of types +-- and a list of coercions +mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet +mkTyCoInScopeSet tys cos + = mkInScopeSet (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment, hence "open" +mkOpenTCvSubst :: TvSubstEnv -> CvSubstEnv -> TCvSubst +mkOpenTCvSubst tenv cenv + = TCvSubst (mkTyCoInScopeSet (varEnvElts tenv) (varEnvElts cenv)) tenv cenv + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment, hence "open". No CoVars, please! +zipOpenTCvSubst :: [TyVar] -> [Type] -> TCvSubst +zipOpenTCvSubst tyvars tys + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipOpenTCvSubst" (ppr tyvars $$ ppr tys) emptyTCvSubst + | otherwise + = TCvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv emptyCvSubstEnv + where tenv = zipTyEnv tyvars tys + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment, hence "open". +zipOpenTCvSubstCoVars :: [CoVar] -> [Coercion] -> TCvSubst +zipOpenTCvSubstCoVars cvs cos + | debugIsOn && (length cvs /= length cos) + = pprTrace "zipOpenTCvSubstCoVars" (ppr cvs $$ ppr cos) emptyTCvSubst + | otherwise + = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv + where cenv = zipCoEnv cvs cos + + +-- | Create an open TCvSubst combining the binders and types provided. +-- NB: It is OK if the lists are of different lengths. +zipOpenTCvSubstBinders :: [TyBinder] -> [Type] -> TCvSubst +zipOpenTCvSubstBinders bndrs tys + = TCvSubst is tenv emptyCvSubstEnv + where + is = mkInScopeSet (tyCoVarsOfTypes tys) + (tvs, tys') = unzip [ (tv, ty) | (Named tv _, ty) <- zip bndrs tys ] + tenv = zipTyEnv tvs tys' + +-- | Called when doing top-level substitutions. Here we expect that the +-- free vars of the range of the substitution will be empty. +mkTopTCvSubst :: [(TyCoVar, Type)] -> TCvSubst +mkTopTCvSubst prs = TCvSubst emptyInScopeSet tenv cenv + where (tenv, cenv) = foldl extend (emptyTvSubstEnv, emptyCvSubstEnv) prs + extend envs (v, ty) = extendSubstEnvs envs v ty + +-- | Makes a subst with an empty in-scope-set. No CoVars, please! +zipTopTCvSubst :: [TyVar] -> [Type] -> TCvSubst +zipTopTCvSubst tyvars tys + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipTopTCvSubst" (ppr tyvars $$ ppr tys) emptyTCvSubst + | otherwise + = TCvSubst emptyInScopeSet tenv emptyCvSubstEnv + where tenv = zipTyEnv tyvars tys + +zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + = ASSERT( all (not . isCoercionTy) tys ) + mkVarEnv (zipEqual "zipTyEnv" tyvars tys) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + +instance Outputable TCvSubst where + ppr (TCvSubst ins tenv cenv) + = brackets $ sep[ ptext (sLit "TCvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Type env:") <+> ppr tenv), + nest 2 (ptext (sLit "Co env:") <+> ppr cenv) ] + +{- +%************************************************************************ +%* * + Performing type or kind substitutions +%* * +%************************************************************************ + +Note [Sym and ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~ +In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, +how do we push sym into a ForAllCo? It's a little ugly. + +Here is the typing rule: + +h : k1 ~# k2 +(tv : k1) |- g : ty1 ~# ty2 +---------------------------- +ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# + (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) + +Here is what we want: + +ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# + (ForAllTy (tv : k1) ty1) + + +Because the kinds of the type variables to the right of the colon are the kinds +coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). + +Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want + +ForAllCo tv h' g' : + (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# + (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) + +We thus see that we want + +g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] + +and thus g' = sym (g[tv |-> tv |> h']). + +Putting it all together, we get this: + +sym (ForAllCo tv h g) +==> +ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) + +-} + +-- | Create a substitution from tyvars to types, but later types may depend +-- on earlier ones. Return the substed types and the built substitution. +substTelescope :: [TyCoVar] -> [Type] -> ([Type], TCvSubst) +substTelescope = go_subst emptyTCvSubst + where + go_subst :: TCvSubst -> [TyCoVar] -> [Type] -> ([Type], TCvSubst) + go_subst subst [] [] = ([], subst) + go_subst subst (tv:tvs) (k:ks) + = let k' = substTy subst k in + liftFst (k' :) $ go_subst (extendTCvSubst subst tv k') tvs ks + go_subst _ _ _ = panic "substTelescope" + + +-- | Type substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substTyWith :: [TyVar] -> [Type] -> Type -> Type +substTyWith tvs tys = ASSERT( length tvs == length tys ) + substTy (zipOpenTCvSubst tvs tys) + +-- | Coercion substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substCoWith :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = ASSERT( length tvs == length tys ) + substCo (zipOpenTCvSubst tvs tys) + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipOpenTCvSubstCoVars cvs cos) + +-- | Type substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( length tvs == length tys ) + substTys (zipOpenTCvSubst tvs tys) + +-- | Type substitution making use of an 'TCvSubst' that +-- is assumed to be open, see 'zipOpenTCvSubst' +substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = ASSERT( length cvs == length cos ) + substTys (zipOpenTCvSubstCoVars cvs cos) + +-- | Type substitution using 'Binder's. Anonymous binders +-- simply ignore their matching type. +substTyWithBinders :: [TyBinder] -> [Type] -> Type -> Type +substTyWithBinders bndrs tys = ASSERT( length bndrs == length tys ) + substTy (zipOpenTCvSubstBinders bndrs tys) + +-- | Substitute within a 'Type' +substTy :: TCvSubst -> Type -> Type +substTy subst ty | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +-- | Substitute within several 'Type's +substTys :: TCvSubst -> [Type] -> [Type] +substTys subst tys | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +-- | Substitute within a 'ThetaType' +substTheta :: TCvSubst -> ThetaType -> ThetaType +substTheta = substTys + +subst_ty :: TCvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (TyVarTy tv) = substTyVar subst tv + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + go (ForAllTy (Anon arg) res) + = (ForAllTy $! (Anon $! go arg)) $! go res + go (ForAllTy (Named tv vis) ty) + = case substTyVarBndr subst tv of + (subst', tv') -> + (ForAllTy $! ((Named $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (CastTy $! (go ty)) $! (subst_co subst co) + go (CoercionTy co) = CoercionTy $! (subst_co subst co) + +substTyVar :: TCvSubst -> TyVar -> Type +substTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + +substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVars subst = map $ substTyVar subst + +lookupTyVar :: TCvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TCvSubst] +lookupTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +substCo :: TCvSubst -> Coercion -> Coercion +substCo subst co | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +substCos :: TCvSubst -> [Coercion] -> [Coercion] +substCos subst cos | isEmptyTCvSubst subst = cos + | otherwise = map (substCo subst) cos + +subst_co :: TCvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go :: Coercion -> Coercion + go (Refl r ty) = mkReflCo r $! go_ty ty + go (TyConAppCo r tc args)= let args' = map go args + in args' `seqList` mkTyConAppCo r tc args' + go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (ForAllCo tv kind_co co) + = case substForAllCoBndr subst tv kind_co of { (subst', tv', kind_co') -> + ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co } + 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) $! + (go_ty t1)) $! (go_ty t2) + go (SymCo co) = mkSymCo $! (go co) + go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) + go (NthCo d co) = mkNthCo d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (CoherenceCo co1 co2) = (mkCoherenceCo $! (go co1)) $! (go co2) + go (KindCo co) = mkKindCo $! (go co) + go (SubCo co) = mkSubCo $! (go co) + go (AxiomRuleCo c cs) = let cs1 = map go cs + in cs1 `seqList` AxiomRuleCo c cs1 + + go_prov UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv kco) = PhantomProv (go kco) + go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) + go_prov p@(PluginProv _) = p + go_prov p@(HoleProv _) = p + -- NB: this last case is a little suspicious, but we need it. Originally, + -- there was a panic here, but it triggered from deeplySkolemise. Because + -- we only skolemise tyvars that are manually bound, this operation makes + -- sense, even over a coercion with holes. + +substForAllCoBndr :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrCallback False (substCo subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrCallback :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> Coercion + -> (TCvSubst, TyVar, Coercion) +substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + , new_var, new_kind_co ) + where + new_env | no_change && not sym = delVarEnv tenv old_var + | sym = extendVarEnv tenv old_var $ + TyVarTy new_var `CastTy` new_kind_co + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_kind_change = isEmptyVarSet (tyCoVarsOfCo old_kind_co) + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair new_ki1 _ = coercionKind new_kind_co + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +substCoVar :: TCvSubst -> CoVar -> Coercion +substCoVar (TCvSubst _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + +substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupCoVar :: TCvSubst -> Var -> Maybe Coercion +lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v + +substTyVarBndr :: TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr = substTyVarBndrCallback substTy + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +substTyVarBndrCallback :: (TCvSubst -> Type -> Type) -- ^ the subst function + -> TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT2( _no_capture, pprTvBndr old_var $$ pprTvBndr new_var $$ ppr subst ) + ASSERT( isTyVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypes (varEnvElts tenv)) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = isEmptyVarSet (tyCoVarsOfType old_ki) -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TCvSubst] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ updateTyVarKind (subst_fn subst) old_var + -- The uniqAway part makes sure the new variable is not already in scope + +substCoVarBndr :: TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrCallback False substTy + +substCoVarBndrCallback :: Bool -- apply "sym" to the covar? + -> (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrCallback sym subst_fun subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t) + -- In that case, mkCoVarCo will return a ReflCoercion, and + -- we want to substitute that (not new_var) for old_var + new_co = (if sym then mkSymCo else id) $ mkCoVarCo new_var + no_kind_change = isEmptyVarSet (tyCoVarsOfTypes [t1, t2]) + no_change = new_var == old_var && not (isReflCo new_co) && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) new_var_type + + (_, _, t1, t2, role) = coVarKindsTypesRole old_var + t1' = subst_fun subst t1 + t2' = subst_fun subst t2 + new_var_type = uncurry (mkCoercionType role) (if sym then (t2', t1') else (t1', t2')) + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) +cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq + | isTyVar tv + = (TCvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + | otherwise + = (TCvSubst (extendInScopeSet in_scope tv') + tv_env (extendVarEnv cv_env tv (mkCoVarCo tv')), tv') + where + tv' = setVarUnique tv uniq -- Simply set the unique; the kind + -- has no type variables to worry about + +cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs subst [] _usupply = (subst, []) +cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) + where + (uniq, usupply') = takeUniqFromSupply usupply + (subst' , tv ) = cloneTyVarBndr subst t uniq + (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' + +{- +%************************************************************************ +%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * +%************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the pretty printer +operates the following precedene structre: + Type constructor application binds more tightly than + Oerator applications which bind more tightly than + Function arrow + +So we might see a :+: T b -> c +meaning (a :+: (T b)) -> c + +Maybe operator applications should bind a bit less tightly? + +Anyway, that's the current story, and it is used consistently for Type and HsType +-} + +data TyPrec -- See Note [Prededence in types] + = TopPrec -- No parens + | FunPrec -- Function args; no parens for tycon apps + | TyOpPrec -- Infix operator + | TyConPrec -- Tycon args; no parens for atomic + deriving( Eq, Ord ) + +maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +------------------ +pprType, pprParendType :: Type -> SDoc +pprType ty = ppr_type TopPrec ty +pprParendType ty = ppr_type TyConPrec ty + +pprTyLit :: TyLit -> SDoc +pprTyLit = ppr_tylit TopPrec + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta [pred] = ppr_type TopPrec pred -- I'm in two minds about this +pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy [] = empty +pprThetaArrowTy [pred] = ppr_type TyOpPrec pred <+> darrow + -- TyOpPrec: Num a => a -> a does not need parens + -- bug (a :~: b) => a -> b currently does + -- Trac # 9658 +pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) + <+> darrow + -- Notice 'fsep' here rather that 'sep', so that + -- type contexts don't get displayed in a giant column + -- Rather than + -- instance (Eq a, + -- Eq b, + -- Eq c, + -- Eq d, + -- Eq e, + -- Eq f, + -- Eq g, + -- Eq h, + -- Eq i, + -- Eq j, + -- Eq k, + -- Eq l) => + -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + -- we get + -- + -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, + -- Eq j, Eq k, Eq l) => + -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + +------------------ +instance Outputable Type where + ppr ty = pprType ty + +instance Outputable TyLit where + ppr = pprTyLit + +------------------ + -- OK, here's the main printer + +ppr_type :: TyPrec -> Type -> SDoc +ppr_type _ (TyVarTy tv) = ppr_tvar tv + +ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys +ppr_type p (LitTy l) = ppr_tylit p l +ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty + +ppr_type p (AppTy t1 t2) + = if_print_coercions + ppr_app_ty + (case split_app_tys t1 [t2] of + (CastTy head _, args) -> ppr_type p (mk_app_tys head args) + _ -> ppr_app_ty) + where + ppr_app_ty = maybeParen p TyConPrec $ + ppr_type FunPrec t1 <+> ppr_type TyConPrec t2 + + split_app_tys (AppTy ty1 ty2) args = split_app_tys ty1 (ty2:args) + split_app_tys head args = (head, args) + + mk_app_tys (TyConApp tc tys1) tys2 = TyConApp tc (tys1 ++ tys2) + mk_app_tys ty1 tys2 = foldl AppTy ty1 tys2 + +ppr_type p (CastTy ty co) + = if_print_coercions + (parens (ppr_type TopPrec ty <+> ptext (sLit "|>") <+> ppr co)) + (ppr_type p ty) + +ppr_type _ (CoercionTy co) + = if_print_coercions + (parens (ppr co)) + (text "<>") + +ppr_forall_type :: TyPrec -> Type -> SDoc +ppr_forall_type p ty + = maybeParen p FunPrec $ ppr_sigma_type True ty + -- True <=> we always print the foralls on *nested* quantifiers + -- Opt_PrintExplicitForalls only affects top-level quantifiers + -- False <=> we don't print an extra-constraints wildcard + +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + = parenSymOcc (getOccName tv) (ppr tv) + +ppr_tylit :: TyPrec -> TyLit -> SDoc +ppr_tylit _ tl = + case tl of + NumTyLit n -> integer n + StrTyLit s -> text (show s) + +if_print_coercions :: SDoc -- if printing coercions + -> SDoc -- otherwise + -> SDoc +if_print_coercions yes no + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + if gopt Opt_PrintExplicitCoercions dflags + || dumpStyle style || debugStyle style + then yes + else no + +------------------- +ppr_sigma_type :: Bool -> Type -> SDoc +-- First Bool <=> Show the foralls unconditionally +-- Second Bool <=> Show an extra-constraints wildcard +ppr_sigma_type show_foralls_unconditionally ty + = sep [ if show_foralls_unconditionally + then pprForAll bndrs + else pprUserForAll bndrs + , pprThetaArrowTy ctxt + , pprArrowChain TopPrec (ppr_fun_tail tau) ] + where + (bndrs, rho) = split1 [] ty + (ctxt, tau) = split2 [] rho + + split1 bndrs (ForAllTy bndr@(Named {}) ty) = split1 (bndr:bndrs) ty + split1 bndrs ty = (reverse bndrs, ty) + + split2 ps (ForAllTy (Anon ty1) ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 + split2 ps ty = (reverse ps, ty) + + -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + ppr_fun_tail (ForAllTy (Anon ty1) ty2) + | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 + ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] + +pprSigmaType :: Type -> SDoc +pprSigmaType ty = ppr_sigma_type False ty + +pprUserForAll :: [TyBinder] -> SDoc +-- Print a user-level forall; see Note [When to print foralls] +pprUserForAll bndrs + = sdocWithDynFlags $ \dflags -> + ppWhen (any bndr_has_kind_var bndrs || gopt Opt_PrintExplicitForalls dflags) $ + pprForAll bndrs + where + bndr_has_kind_var bndr + = not (isEmptyVarSet (tyCoVarsOfType (binderType bndr))) + +pprForAllImplicit :: [TyVar] -> SDoc +pprForAllImplicit tvs = pprForAll (zipWith Named tvs (repeat Invisible)) + +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +-- Do not pass in anonymous binders! +pprForAll :: [TyBinder] -> SDoc +pprForAll [] = empty +pprForAll bndrs@(Named _ vis : _) + = add_separator (forAllLit <+> doc) <+> pprForAll bndrs' + where + (bndrs', doc) = ppr_tv_bndrs bndrs vis + + add_separator stuff = case vis of + Invisible -> stuff <> dot + Visible -> stuff <+> arrow +pprForAll bndrs = pprPanic "pprForAll: anonymous binder" (ppr bndrs) + +pprTvBndrs :: [TyVar] -> SDoc +pprTvBndrs tvs = sep (map pprTvBndr tvs) + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +ppr_tv_bndrs :: [TyBinder] + -> VisibilityFlag -- ^ visibility of the first binder in the list + -> ([TyBinder], SDoc) +ppr_tv_bndrs all_bndrs@(Named tv vis : bndrs) vis1 + | vis == vis1 = let (bndrs', doc) = ppr_tv_bndrs bndrs vis1 in + (bndrs', pprTvBndr tv <+> doc) + | otherwise = (all_bndrs, empty) +ppr_tv_bndrs [] _ = ([], empty) +ppr_tv_bndrs bndrs _ = pprPanic "ppr_tv_bndrs: anonymous binder" (ppr bndrs) + +pprTvBndr :: TyVar -> SDoc +pprTvBndr tv + | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) + where + kind = tyVarKind tv + +instance Outputable TyBinder where + ppr (Named v Visible) = ppr v + ppr (Named v Invisible) = braces (ppr v) + ppr (Anon ty) = text "[anon]" <+> ppr ty + +instance Outputable VisibilityFlag where + ppr Visible = text "[vis]" + ppr Invisible = text "[invis]" + +----------------- +instance Outputable Coercion where -- defined here to avoid orphans + ppr = pprCo +instance Outputable LeftOrRight where + ppr CLeft = ptext (sLit "Left") + ppr CRight = ptext (sLit "Right") + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we want to print top-level foralls when (and only when) the user specifies +-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses +too much information; see Trac #9018. + +So I'm trying out this rule: print explicit foralls if + a) User specifies -fprint-explicit-foralls, or + b) Any of the quantified type variables has a kind + that mentions a kind variable + +This catches common situations, such as a type siguature + f :: m a +which means + f :: forall k. forall (m :: k->*) (a :: k). m a +We really want to see both the "forall k" and the kind signatures +on m and a. The latter comes from pprTvBndr. + +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See Trac #2766. +-} + +pprDataCons :: TyCon -> SDoc +pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons + where + sepWithVBars [] = empty + sepWithVBars docs = sep (punctuate (space <> vbar) docs) + +pprDataConWithArgs :: DataCon -> SDoc +pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc + forAllDoc = pprUserForAll $ map (\tv -> Named tv Invisible) $ + ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs) + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType arg_tys) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys = pprTyTcApp TopPrec tc tys + -- We have to use ppr on the TyCon (not its name) + -- so that we get promotion quotes in the right place + +pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc +-- Used for types only; so that we can make a +-- special case for type-level lists +pprTyTcApp p tc tys + | tc `hasKey` ipTyConKey + , [LitTy (StrTyLit n),ty] <- tys + = maybeParen p FunPrec $ + char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty + + | tc `hasKey` consDataConKey + , [_kind,ty1,ty2] <- tys + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitKinds dflags then ppr_deflt + else pprTyList p ty1 ty2 + + | not opt_PprStyle_Debug + , tc `hasKey` errorMessageTypeErrorFamKey + = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see + + | tc `hasKey` tYPETyConKey + , [TyConApp lev_tc []] <- tys + = if | lev_tc `hasKey` liftedDataConKey -> char '*' + | lev_tc `hasKey` unliftedDataConKey -> char '#' + | otherwise -> ppr_deflt + + | otherwise + = ppr_deflt + where + ppr_deflt = pprTcAppTy p ppr_type tc tys + +pprTcAppTy :: TyPrec -> (TyPrec -> Type -> SDoc) -> TyCon -> [Type] -> SDoc +pprTcAppTy = pprTcApp id + +pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc) + -> TyCon -> [Coercion] -> SDoc +pprTcAppCo = pprTcApp (pFst . coercionKind) + +pprTcApp :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc +-- Used for both types and coercions, hence polymorphism +pprTcApp _ _ pp tc [ty] + | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + +pprTcApp to_type p pp tc tys + | Just sort <- tyConTuple_maybe tc + , let arity = tyConArity tc + , arity == length tys + , let num_to_drop = case sort of UnboxedTuple -> arity `div` 2 + _ -> 0 + = pprTupleApp p pp tc sort (drop num_to_drop tys) + + | Just dc <- isPromotedDataCon_maybe tc + , let dc_tc = dataConTyCon dc + , Just tup_sort <- tyConTuple_maybe dc_tc + , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 + ty_args = drop arity tys -- Drop the kind args + , ty_args `lengthIs` arity -- Result is saturated + = pprPromotionQuote tc <> + (tupleParens tup_sort $ pprWithCommas (pp TopPrec) ty_args) + + | otherwise + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + pprTcApp_help to_type p pp tc tys dflags style + where + +pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) + -> TyCon -> TupleSort -> [a] -> SDoc +-- Print a saturated tuple +pprTupleApp p pp tc sort tys + | null tys + , ConstraintTuple <- sort + = if opt_PprStyle_Debug then ptext (sLit "(%%)") + else maybeParen p FunPrec $ + ptext (sLit "() :: Constraint") + | otherwise + = pprPromotionQuote tc <> + tupleParens sort (pprWithCommas (pp TopPrec) tys) + +pprTcApp_help :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) + -> TyCon -> [a] -> DynFlags -> PprStyle -> SDoc +-- This one has accss to the DynFlags +pprTcApp_help to_type p pp tc tys dflags style + | print_prefix + = pprPrefixApp p pp_tc (map (pp TyConPrec) tys_wo_kinds) + + | [ty1,ty2] <- tys_wo_kinds -- Infix, two arguments; + -- we know nothing of precedence though + = pprInfixApp p pp pp_tc ty1 ty2 + + | tc_name `hasKey` starKindTyConKey + || tc_name `hasKey` unicodeStarKindTyConKey + || tc_name `hasKey` unliftedTypeKindTyConKey + = pp_tc -- Do not wrap *, # in parens + + | otherwise + = pprPrefixApp p (parens pp_tc) (map (pp TyConPrec) tys_wo_kinds) + where + tc_name = tyConName tc + + -- With the solver working in unlifted equality, it will want to + -- to print unlifted equality constraints sometimes. But these are + -- confusing to users. So fix them up here. + (print_prefix, pp_tc) + | (tc `hasKey` eqPrimTyConKey || tc `hasKey` heqTyConKey) && not print_eqs + = (False, text "~") + | tc `hasKey` eqReprPrimTyConKey && not print_eqs + = (True, text "Coercible") + | otherwise + = (not (isSymOcc (nameOccName tc_name)), ppr tc) + + print_eqs = gopt Opt_PrintEqualityRelations dflags || + dumpStyle style || + debugStyle style + tys_wo_kinds = suppressInvisibles to_type dflags tc tys + +------------------ +-- | Given a 'TyCon',and the args to which it is applied, +-- suppress the args that are implicit +suppressInvisibles :: (a -> Type) -> DynFlags -> TyCon -> [a] -> [a] +suppressInvisibles to_type dflags tc xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = snd $ partitionInvisibles tc to_type xs + +---------------- +pprTyList :: TyPrec -> Type -> Type -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +pprTyList p ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) -> char '\'' <> brackets (fsep (punctuate comma + (map (ppr_type TopPrec) (ty1:arg_tys)))) + (arg_tys, Just tl) -> maybeParen p FunPrec $ + hang (ppr_type FunPrec ty1) + 2 (fsep [ colon <+> ppr_type FunPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: Type -> ([Type], Maybe Type) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (TyConApp tc tys) + | tc `hasKey` consDataConKey + , [_kind, ty1,ty2] <- tys + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `hasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +---------------- +pprInfixApp :: TyPrec -> (TyPrec -> a -> SDoc) -> SDoc -> a -> a -> SDoc +pprInfixApp p pp pp_tc ty1 ty2 + = maybeParen p TyOpPrec $ + sep [pp TyOpPrec ty1, pprInfixVar True pp_tc <+> pp TyOpPrec ty2] + +pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc +pprPrefixApp p pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) +---------------- +pprArrowChain :: TyPrec -> [SDoc] -> SDoc +-- pprArrowChain p [a,b,c] generates a -> b -> c +pprArrowChain _ [] = empty +pprArrowChain p (arg:args) = maybeParen p FunPrec $ + sep [arg, sep (map (arrow <+>) args)] + +{- +%************************************************************************ +%* * +\subsection{TidyType} +%* * +%************************************************************************ +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyTyCoVarBndrs env tvs = mapAccumL tidyTyCoVarBndr env tvs + +tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar + = case tidyOccName occ_env occ1 of + (tidy', occ') -> ((tidy', subst'), tyvar') + where + subst' = extendVarEnv subst tyvar tyvar' + tyvar' = setTyVarKind (setTyVarName tyvar name') kind' + name' = tidyNameOcc name occ' + kind' = tidyKind tidy_env (tyVarKind tyvar) + where + name = tyVarName tyvar + occ = getOccName name + -- System Names are for unification variables; + -- when we tidy them we give them a trailing "0" (or 1 etc) + -- so that they don't take precedence for the un-modified name + -- Plus, indicating a unification variable in this way is a + -- helpful clue for users + occ1 | isSystemName name + = if isTyVar tyvar + then mkTyVarOcc (occNameString occ ++ "0") + else mkVarOcc (occNameString occ ++ "0") + | otherwise = occ + +--------------- +tidyFreeTyCoVars :: TidyEnv -> TyCoVarSet -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyCoVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyCoVars (full_occ_env, var_env) (varSetElems tyvars)) + + --------------- +tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars + +--------------- +tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyTyCoVarBndr' +tidyOpenTyCoVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyTyCoVarBndr env tyvar -- Treat it as a binder + +--------------- +tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar +tidyTyVarOcc (_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> tv + Just tv' -> tv' + +--------------- +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = map (tidyType env) tys + +--------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (ForAllTy (Anon fun) arg) + = (ForAllTy $! (Anon $! (tidyType env fun))) $! (tidyType env arg) +tidyType env (ForAllTy (Named tv vis) ty) + = (ForAllTy $! ((Named $! tvp) $! vis)) $! (tidyType envp ty) + where + (envp, tvp) = tidyTyCoVarBndr env tv +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty + = (env', tidyType (trimmed_occ_env, var_env) ty) + where + (env'@(_, var_env), tvs') = tidyOpenTyCoVars env (tyCoVarsOfTypeList ty) + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the type, so that we don't gratuitously rename + -- the _bound_ variables of the type. + +--------------- +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys = mapAccumL tidyOpenType env tys + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType + +---------------- +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go (Refl r ty) = Refl r (tidyType env ty) + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp 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 (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (AxiomInstCo con ind cos) = let args = map go cos + in args `seqList` AxiomInstCo con ind args + go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! + tidyType env t1) $! tidyType env t2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo d co) = NthCo d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (CoherenceCo co1 co2) = (CoherenceCo $! go co1) $! go co2 + go (KindCo co) = KindCo $! go co + go (SubCo co) = SubCo $! go co + go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos + in cos1 `seqList` AxiomRuleCo ax cos1 + + go_prov UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv co) = PhantomProv (go co) + go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) + go_prov p@(PluginProv _) = p + go_prov p@(HoleProv _) = p + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) diff --git a/compiler/types/TypeRep.hs-boot b/compiler/types/TyCoRep.hs-boot index 7233c5d239..76a5abf2f1 100644 --- a/compiler/types/TypeRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -1,15 +1,18 @@ -module TypeRep where +module TyCoRep where import Outputable (Outputable) import Data.Data (Data,Typeable) data Type +data TyBinder data TyThing -data TvSubst +data Coercion +data LeftOrRight +data UnivCoProvenance +data TCvSubst type PredType = Type type Kind = Type -type SuperKind = Type type ThetaType = [PredType] instance Outputable Type diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index fd0d5e5aac..356e2ea9dc 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -14,7 +14,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, - FamTyConFlav(..), Role(..), Promoted(..), Injectivity(..), + FamTyConFlav(..), Role(..), Injectivity(..), -- ** Field labels tyConFieldLabels, tyConFieldLabelEnv, @@ -30,19 +30,18 @@ module TyCon( mkSynonymTyCon, mkFamilyTyCon, mkPromotedDataCon, - mkPromotedTyCon, + mkTcTyCon, -- ** Predicates on TyCons - isAlgTyCon, + isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, isFamInstTyCon, isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isTypeSynonymTyCon, mightBeUnsaturatedTyCon, - isPromotedDataCon, isPromotedTyCon, - isPromotedDataCon_maybe, isPromotedTyCon_maybe, - promotableTyCon_maybe, isPromotableTyCon, promoteTyCon, + isPromotedDataCon, isPromotedDataCon_maybe, + isKindTyCon, isLiftedTypeKindTyConName, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isEnumerationTyCon, @@ -58,6 +57,7 @@ module TyCon( isRecursiveTyCon, isImplicitTyCon, isTyConWithSrcDataCons, + isTcTyCon, -- ** Extracting information out of TyCons tyConName, @@ -105,7 +105,7 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels ) import Binary @@ -318,6 +318,17 @@ it's worth noting that (~#)'s parameters are at role N. Promoted data constructors' type arguments are at role R. All kind arguments are at role N. +Note [Unboxed tuple levity vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may be boxed or unboxed. Accordingly, +the kind of the unboxed tuple constructor is sort-polymorphic. For example, + + (#,#) :: forall (v :: Levity) (w :: Levity). TYPE v -> TYPE w -> # + +These extra tyvars (v and w) cause some delicate processing around tuples, +where we used to be able to assume that the tycon arity and the +datacon arity were the same. + Note [Injective type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -454,11 +465,10 @@ data TyCon algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - algTcParent :: AlgTyConFlav, -- ^ Gives the class or family declaration + algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration -- 'TyCon' for derived 'TyCon's representing -- class or family instances, respectively. - tcPromoted :: Promoted TyCon -- ^ Promoted TyCon, if any } -- | Represents type synonyms @@ -580,16 +590,12 @@ data TyCon tcRepName :: TyConRepName } - -- | Represents promoted type constructor. - | PromotedTyCon { - tyConUnique :: Unique, -- ^ Same Unique as the type constructor - tyConName :: Name, -- ^ Same Name as the type constructor - tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times - tyConKind :: Kind, -- ^ Always TysPrim.superKind - ty_con :: TyCon, -- ^ Corresponding type constructor - tcRepName :: TyConRepName - } - + -- | These exist only during a recursive type/class type-checking knot. + | TcTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind + } deriving Typeable @@ -656,10 +662,6 @@ data AlgTyConRhs -- again check Trac #1072. } --- | Isomorphic to Maybe, but used when the question is --- whether or not something is promoted -data Promoted a = NotPromoted | Promoted a - -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! @@ -683,7 +685,7 @@ data AlgTyConFlav | UnboxedAlgTyCon -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in TypeRep + -- See Note [ATyCon for classes] in TyCoRep | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the -- current tycon @@ -746,7 +748,7 @@ isNoParent _ = False data Injectivity = NotInjective - | Injective [Bool] -- Length is 1-1 with tyConTyVars (incl kind vars) + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) deriving( Eq ) -- | Information pertaining to the expansion of a type synonym (@type@) @@ -756,7 +758,7 @@ data FamTyConFlav -- -- These are introduced by either a top level declaration: -- - -- > data T a :: * + -- > data family T a :: * -- -- Or an associated data type declaration, within a class declaration: -- @@ -797,27 +799,13 @@ nothing for the axiom to prove! Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A data constructor can be promoted to become a type constructor, -via the PromotedTyCon alternative in TyCon. - -* Only data constructors with - (a) no kind polymorphism - (b) no constraints in its type (eg GADTs) - are promoted. Existentials are ok; see Trac #7347. +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in TyCon. * The TyCon promoted from a DataCon has the *same* Name and Unique as the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) -* The *kind* of a promoted DataCon may be polymorphic. Example: - type of DataCon Just :: forall (a:*). a -> Maybe a - kind of (promoted) tycon Just :: forall (a:box). a -> Maybe a - The kind is not identical to the type, because of the */box - kind signature on the forall'd variable; so the tyConKind field of - PromotedTyCon is not identical to the dataConUserType of the - DataCon. But it's the same modulo changing the variable kinds, - done by DataCon.promoteType. - * Small note: We promote the *user* type of the DataCon. Eg data T = MkT {-# UNPACK #-} !(Bool, Bool) The promoted kind is @@ -924,8 +912,6 @@ tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) = Just rep_nm tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm }) = Just rep_nm -tyConRepName_maybe (PromotedTyCon { tcRepName = rep_nm }) - = Just rep_nm tyConRepName_maybe _ = Nothing @@ -1113,7 +1099,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 'TypeRep.funTyCon' if you want +-- corresponding 'TyCon'. It is reccomended to use 'TyCoRep.funTyCon' if you want -- this functionality mkFunTyCon :: Name -> Kind -> Name -> TyCon mkFunTyCon name kind rep_nm @@ -1143,9 +1129,8 @@ mkAlgTyCon :: Name -- (e.g. vanilla, type family) -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> Promoted TyCon -- ^ Promoted version -> TyCon -mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc +mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -1159,8 +1144,7 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t algTcFields = fieldsOfAlgTcRhs rhs, algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, algTcRec = is_rec, - algTcGadtSyntax = gadt_syn, - tcPromoted = prom_tc + algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes @@ -1170,7 +1154,6 @@ mkClassTyCon name kind tyvars roles rhs clas is_rec tc_rep_name = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas tc_rep_name) is_rec False - NotPromoted -- Class TyCons are not promoted mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -1178,10 +1161,9 @@ mkTupleTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> Promoted TyCon -- ^ Promoted version -> AlgTyConFlav -> TyCon -mkTupleTyCon name kind arity tyvars con sort prom_tc parent +mkTupleTyCon name kind arity tyvars con sort parent = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -1196,19 +1178,32 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent algTcFields = emptyFsEnv, algTcParent = parent, algTcRec = NonRecursive, - algTcGadtSyntax = False, - tcPromoted = prom_tc + algTcGadtSyntax = False } +-- | Makes a tycon suitable for use during type-checking. +-- The only real need for this is for printing error messages during +-- a recursive type/class type-checking knot. It has a kind because +-- TcErrors sometimes calls typeKind. +-- See also Note [Kind checking recursive type and class declarations] +-- in TcTyClsDecls. +mkTcTyCon :: Name -> Kind -> TyCon +mkTcTyCon name kind + = TcTyCon { tyConUnique = getUnique name + , tyConName = name + , tyConKind = kind } + -- | Create an unlifted primitive 'TyCon', such as @Int#@ mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon mkPrimTyCon name kind roles rep = mkPrimTyCon' name kind roles rep True Nothing -- | Kind constructors -mkKindTyCon :: Name -> Kind -> Name -> TyCon -mkKindTyCon name kind rep_nm - = mkPrimTyCon' name kind [] VoidRep True (Just rep_nm) +mkKindTyCon :: Name -> Kind -> [Role] -> Name -> TyCon +mkKindTyCon name kind roles rep_nm + = tc + where + tc = mkPrimTyCon' name kind roles VoidRep False (Just rep_nm) -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon @@ -1277,23 +1272,6 @@ mkPromotedDataCon con name rep_name kind roles where arity = length roles --- | Create a promoted type constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- as the type constructor itself -mkPromotedTyCon :: TyCon -> Kind -> TyCon -mkPromotedTyCon tc kind - = PromotedTyCon { - tyConName = getName tc, - tyConUnique = getUnique tc, - tyConArity = tyConArity tc, - tyConKind = kind, - ty_con = tc, - tcRepName = case tyConRepName_maybe tc of - Just rep_nm -> rep_nm - Nothing -> pprPanic "mkPromotedTyCon" (ppr tc) - -- Promoted TyCons always have a TyConRepName - } - isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False @@ -1339,6 +1317,12 @@ isAlgTyCon :: TyCon -> Bool isAlgTyCon (AlgTyCon {}) = True isAlgTyCon _ = False +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True +isVanillaAlgTyCon _ = False + isDataTyCon :: TyCon -> Bool -- ^ Returns @True@ for data types that are /definitely/ represented by -- heap-allocated constructors. These are scrutinised by Core-level @@ -1371,21 +1355,24 @@ isInjectiveTyCon (AlgTyCon {}) Nominal = True isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational = isGenInjAlgRhs rhs isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon {famTcFlav = flav}) Nominal = isDataFamFlav flav -isInjectiveTyCon (FamilyTyCon {}) Representational = False +isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + Nominal = True +isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) _ = and inj +isInjectiveTyCon (FamilyTyCon {}) _ = False isInjectiveTyCon (PrimTyCon {}) _ = True isInjectiveTyCon (PromotedDataCon {}) _ = True -isInjectiveTyCon (PromotedTyCon {ty_con = tc}) r - = isInjectiveTyCon tc r +isInjectiveTyCon tc@(TcTyCon {}) _ + = pprPanic "isInjectiveTyCon sees a TcTyCon" (ppr tc) -- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds -- (where X is the role passed in): -- If (T tys ~X t), then (t's head ~X T). -- See also Note [Decomposing equalities] in TcCanonical isGenerativeTyCon :: TyCon -> Role -> Bool -isGenerativeTyCon = isInjectiveTyCon - -- as it happens, generativity and injectivity coincide, but there's - -- no a priori reason this must be the case +isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True +isGenerativeTyCon (FamilyTyCon {}) _ = False + -- in all other cases, injectivity implies generativitiy +isGenerativeTyCon tc r = isInjectiveTyCon tc r -- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective -- with respect to representational equality? @@ -1544,8 +1531,8 @@ isClosedSynFamilyTyConWithAxiom_maybe (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing --- | Try to read the injectivity information from a FamilyTyCon. Only --- FamilyTyCons can be injective so for every other TyCon this function panics. +-- | Try to read the injectivity information from a FamilyTyCon. +-- For every other TyCon this function panics. familyTyConInjectivityInfo :: TyCon -> Injectivity familyTyConInjectivityInfo (FamilyTyCon { famTcInj = inj }) = inj familyTyConInjectivityInfo _ = panic "familyTyConInjectivityInfo" @@ -1605,30 +1592,6 @@ isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True isRecursiveTyCon _ = False -promotableTyCon_maybe :: TyCon -> Promoted TyCon -promotableTyCon_maybe (AlgTyCon { tcPromoted = prom }) = prom -promotableTyCon_maybe _ = NotPromoted - -isPromotableTyCon :: TyCon -> Bool -isPromotableTyCon tc = case promotableTyCon_maybe tc of - Promoted {} -> True - NotPromoted -> False - -promoteTyCon :: TyCon -> TyCon -promoteTyCon tc = case promotableTyCon_maybe tc of - Promoted prom_tc -> prom_tc - NotPromoted -> pprPanic "promoteTyCon" (ppr tc) - --- | Is this a PromotedTyCon? -isPromotedTyCon :: TyCon -> Bool -isPromotedTyCon (PromotedTyCon {}) = True -isPromotedTyCon _ = False - --- | Retrieves the promoted TyCon if this is a PromotedTyCon; -isPromotedTyCon_maybe :: TyCon -> Maybe TyCon -isPromotedTyCon_maybe (PromotedTyCon { ty_con = tc }) = Just tc -isPromotedTyCon_maybe _ = Nothing - -- | Is this a PromotedDataCon? isPromotedDataCon :: TyCon -> Bool isPromotedDataCon (PromotedDataCon {}) = True @@ -1639,6 +1602,22 @@ isPromotedDataCon_maybe :: TyCon -> Maybe DataCon isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc isPromotedDataCon_maybe _ = Nothing +-- | Is this tycon really meant for use at the kind level? That is, +-- should it be permitted without -XDataKinds? +isKindTyCon :: TyCon -> Bool +isKindTyCon tc = isLiftedTypeKindTyConName (tyConName tc) || + tc `hasKey` constraintKindTyConKey || + tc `hasKey` tYPETyConKey || + tc `hasKey` levityTyConKey || + tc `hasKey` liftedDataConKey || + tc `hasKey` unliftedDataConKey + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName + = (`hasKey` liftedTypeKindTyConKey) <||> + (`hasKey` starKindTyConKey) <||> + (`hasKey` unicodeStarKindTyConKey) + -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is -- read). @@ -1658,17 +1637,23 @@ isImplicitTyCon :: TyCon -> Bool isImplicitTyCon (FunTyCon {}) = True isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True -isImplicitTyCon (PromotedTyCon {}) = True isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) | TupleTyCon {} <- rhs = isWiredInName name | otherwise = False isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent isImplicitTyCon (SynonymTyCon {}) = False +isImplicitTyCon tc@(TcTyCon {}) + = pprPanic "isImplicitTyCon sees a TcTyCon" (ppr tc) tyConCType_maybe :: TyCon -> Maybe CType tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc tyConCType_maybe _ = Nothing +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TcTyCon {}) = True +isTcTyCon _ = False + {- ----------------------------------------------- -- Expand type-constructor applications @@ -1795,7 +1780,7 @@ tyConRoles tc ; FamilyTyCon {} -> const_role Nominal ; PrimTyCon { tcRoles = roles } -> roles ; PromotedDataCon { tcRoles = roles } -> roles - ; PromotedTyCon {} -> const_role Nominal + ; TcTyCon {} -> pprPanic "tyConRoles sees a TcTyCon" (ppr tc) } where const_role r = replicate (tyConArity tc) r @@ -1956,18 +1941,14 @@ tyConFlavour (SynonymTyCon {}) = "type synonym" tyConFlavour (FunTyCon {}) = "built-in type" tyConFlavour (PrimTyCon {}) = "built-in type" tyConFlavour (PromotedDataCon {}) = "promoted data constructor" -tyConFlavour (PromotedTyCon {}) = "promoted type constructor" +tyConFlavour tc@(TcTyCon {}) + = pprPanic "tyConFlavour sees a TcTyCon" (ppr tc) pprPromotionQuote :: TyCon -> SDoc -- Promoted data constructors already have a tick in their OccName pprPromotionQuote tc = case tc of PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types - - PromotedTyCon {} -> ifPprDebug (char '\'') - -- However, we don't quote TyCons in kinds, except with -dppr-debug - -- e.g. type family T a :: Bool -> * - -- cf Trac #5952. _ -> empty instance NamedThing TyCon where diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 50d3a7e2c3..d8064167a9 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -14,34 +14,53 @@ module Type ( -- $type_classification -- $representation_types - TyThing(..), Type, KindOrType, PredType, ThetaType, - Var, TyVar, isTyVar, + TyThing(..), Type, VisibilityFlag(..), KindOrType, PredType, ThetaType, + Var, TyVar, isTyVar, TyCoVar, TyBinder, -- ** Constructing and deconstructing types - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, mkAppTy, mkAppTys, splitAppTy, splitAppTys, - splitAppTy_maybe, repSplitAppTy_maybe, + splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, - funResultTy, funArgTy, zipFunTys, + funResultTy, funArgTy, mkTyConApp, mkTyConTy, - tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, - splitTyConArgs, splitListTyConApp_maybe, - - mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - mkPiKinds, mkPiType, mkPiTypes, - applyTy, applyTys, applyTysD, applyTysX, dropForAlls, + splitListTyConApp_maybe, + repSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkInvForAllTys, mkVisForAllTys, + mkNamedForAllTy, + splitForAllTy_maybe, splitForAllTys, splitForAllTy, + splitPiTy_maybe, splitPiTys, splitPiTy, + splitNamedPiTys, + mkPiType, mkPiTypes, mkPiTypesPreferFunTy, + piResultTy, piResultTys, + applyTys, applyTysD, applyTysX, dropForAlls, mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy, + mkCastTy, mkCoercionTy, + userTypeError_maybe, pprUserTypeErrorTy, coAxNthLHS, + stripCoercionTy, splitCoercionType_maybe, + + splitPiTysInvisible, filterOutInvisibleTypes, + filterOutInvisibleTyVars, partitionInvisibles, + synTyConResKind, + tyConBinders, + + -- Analyzing types + TyCoMapper(..), mapType, mapCoercion, -- (Newtypes) newTyConInstRhs, @@ -49,9 +68,11 @@ module Type ( -- Pred types mkFamilyTyConApp, isDictLikeTy, - mkEqPred, mkCoerciblePred, mkPrimEqPred, mkReprPrimEqPred, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + equalityTyCon, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, mkClassPred, - isClassPred, isEqPred, + isClassPred, isEqPred, isNomEqPred, isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, isCTupleClass, @@ -61,46 +82,58 @@ module Type ( getEqPredTys, getEqPredTys_maybe, getEqPredRole, predTypeEqRel, + -- ** Binders + mkNamedBinder, mkAnonBinder, isNamedBinder, isAnonBinder, + isIdLikeBinder, binderVisibility, binderVar_maybe, + binderVar, binderRelevantType_maybe, caseBinder, + partitionBinders, partitionBindersIntoBinders, + binderType, isVisibleBinder, isInvisibleBinder, + -- ** Common type constructors funTyCon, -- ** Predicates on types - isTypeVar, isKindVar, allDistinctTyVars, isForAllTy, - isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, + allDistinctTyVars, + isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy, isCoercionTy, + isCoercionTy_maybe, isCoercionType, isForAllTy, + isPiTy, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, isPrimitiveType, isStrictType, + isLevityTy, isLevityVar, getLevity, getLevityFromKind, -- * Main data types representing Kinds - -- $kind_subtyping - Kind, SimpleKind, MetaKindVar, + Kind, -- ** Finding the kind of a type typeKind, - -- ** Common Kinds and SuperKinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, - constraintKind, superKind, - - -- ** Common Kind type constructors - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - constraintKindTyCon, anyKindTyCon, + -- ** Common Kind + liftedTypeKind, unliftedTypeKind, -- * Type free variables - tyVarsOfType, tyVarsOfTypes, closeOverKinds, + tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeAcc, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, closeOverKinds, + splitDepVarsOfType, splitDepVarsOfTypes, + splitVisVarsOfType, splitVisVarsOfTypes, expandTypeSynonyms, - typeSize, varSetElemsKvsFirst, + typeSize, + + -- * Well-scoped lists of variables + varSetElemsWellScoped, toposortTyVars, tyCoVarsOfTypeWellScoped, -- * Type comparison - eqType, eqTypeX, eqTypes, cmpType, cmpTypes, - eqPred, eqPredX, cmpPred, eqKind, eqTyVarBndrs, + eqType, eqTypeX, eqTypes, cmpType, cmpTypes, cmpTypeX, cmpTypesX, cmpTc, + eqVarBndrs, -- * Forcing evaluation of types seqType, seqTypes, -- * Other views onto Types - coreView, + coreView, coreViewOneStarKind, UnaryType, RepType(..), flattenRepType, repType, tyConsOfType, @@ -110,50 +143,52 @@ module Type ( -- * Main type substitution data types TvSubstEnv, -- Representation widely visible - TvSubst(..), -- Representation visible to a few friends + TCvSubst(..), -- Representation visible to a few friends -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTvSubst, + emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, + mkTCvSubst, mkOpenTCvSubst, zipOpenTCvSubst, zipTopTCvSubst, mkTopTCvSubst, + notElemTCvSubst, getTvSubstEnv, setTvSubstEnv, - zapTvSubstEnv, getTvInScope, - extendTvInScope, extendTvInScopeList, - extendTvSubst, extendTvSubstList, - isInScope, composeTvSubst, zipTyEnv, - isEmptyTvSubst, unionTvSubst, + zapTCvSubst, getTCvInScope, + extendTCvInScope, extendTCvInScopeList, + extendTCvSubst, extendTCvSubstList, + isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptyTCvSubst, unionTCvSubst, -- ** Performing substitution on types and kinds substTy, substTys, substTyWith, substTysWith, substTheta, - substTyVar, substTyVars, substTyVarBndr, - cloneTyVarBndr, cloneTyVarBndrs, deShadowTy, lookupTyVar, - substKiWith, substKisWith, + substTyVarBndr, substTyVar, substTyVars, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, substTelescope, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, - pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, + pprTvBndr, pprTvBndrs, pprForAll, pprForAllImplicit, pprUserForAll, + pprSigmaType, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, TyPrec(..), maybeParen, + pprTyVar, pprTcAppTy, pprPrefixApp, pprArrowChain, -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, - tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, - tidyOpenTyVar, tidyOpenTyVars, + tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, tidyTyVarOcc, tidyTopType, - tidyKind, + tidyKind ) where #include "HsVersions.h" --- We import the representation and primitive functions from TypeRep. +-- We import the representation and primitive functions from TyCoRep. -- Many things are reexported, but not the representation! import Kind -import TypeRep +import TyCoRep -- friends: import Var @@ -164,32 +199,31 @@ import NameEnv import Class import TyCon import TysPrim -import {-# SOURCE #-} TysWiredIn ( eqTyCon, listTyCon, coercibleTyCon, typeNatKind, typeSymbolKind ) -import PrelNames ( eqTyConKey, coercibleTyConKey, - ipTyConKey, openTypeKindTyConKey, - constraintKindTyConKey, liftedTypeKindTyConKey, - errorMessageTypeErrorFamName, - typeErrorTextDataConName, - typeErrorShowTypeDataConName, - typeErrorAppendDataConName, - typeErrorVAppendDataConName - ) +import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind + , typeSymbolKind, liftedTypeKind ) +import PrelNames import CoAxiom +import {-# SOURCE #-} Coercion -- others -import Unique ( Unique, hasKey ) -import UniqSupply ( UniqSupply, takeUniqFromSupply ) import BasicTypes ( Arity, RepArity ) import Util -import ListSetOps ( getNth ) import Outputable import FastString +import Pair +import ListSetOps +import Digraph import Maybes ( orElse ) -import Data.Maybe ( isJust ) +import Data.Maybe ( isJust, mapMaybe ) import Control.Monad ( guard ) +import Control.Arrow ( first, second ) -infixr 3 `mkFunTy` -- Associates to the right +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ( Applicative, (<*>), (<$>), pure ) +import Data.Monoid ( Monoid(..) ) +import Data.Foldable ( foldMap ) +#endif -- $type_classification -- #type_classification# @@ -263,30 +297,225 @@ coreView :: Type -> Maybe Type -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + = Just (mkAppTys (substTy (mkTopTCvSubst tenv) rhs) tys') -- Its important to use mkAppTys, rather than (foldl AppTy), -- because the function part might well return a -- partially-applied type constructor; indeed, usually will! coreView _ = Nothing +-- | Like 'coreView', but it also "expands" @Constraint@ to become +-- @TYPE Lifted@. +coreViewOneStarKind :: Type -> Maybe Type +coreViewOneStarKind = go Nothing + where + go _ t | Just t' <- coreView t = go (Just t') t' + go _ (TyConApp tc []) | isStarKindSynonymTyCon tc = go (Just t') t' + where t' = liftedTypeKind + go res _ = res + ----------------------------------------------- expandTypeSynonyms :: Type -> Type -- ^ Expand out all type synonyms. Actually, it'd suffice to expand out -- just the ones that discard type variables (e.g. type Funny a = Int) -- But we don't know which those are currently, so we just expand all. expandTypeSynonyms ty - = go ty + = go (mkEmptyTCvSubst (mkTyCoInScopeSet [ty] [])) ty where - go (TyConApp tc tys) + go subst (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys - = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + = let subst' = unionTCvSubst subst (mkTopTCvSubst tenv) in + go subst' (mkAppTys rhs tys') | otherwise - = TyConApp tc (map go tys) - go (LitTy l) = LitTy l - go (TyVarTy tv) = TyVarTy tv - go (AppTy t1 t2) = mkAppTy (go t1) (go t2) - go (FunTy t1 t2) = FunTy (go t1) (go t2) - go (ForAllTy tv t) = ForAllTy tv (go t) + = TyConApp tc (map (go subst) tys) + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst (ForAllTy (Anon arg) res) + = mkFunTy (go subst arg) (go subst res) + go subst (ForAllTy (Named tv vis) t) + = let (subst', tv') = substTyVarBndrCallback go subst tv in + ForAllTy (Named tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_co subst (Refl r ty) + = mkReflCo r (go subst ty) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = mkTyConAppCo r tc (map (go_co subst) args) + go_co subst (AppCo co arg) + = mkAppCo (go_co subst co) (go_co subst arg) + go_co subst (ForAllCo tv kind_co co) + = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in + mkForAllCo tv' kind_co' (go_co subst' co) + go_co subst (CoVarCo cv) + = substCoVar subst cv + go_co subst (AxiomInstCo ax ind args) + = mkAxiomInstCo ax ind (map (go_co subst) args) + go_co subst (UnivCo p r t1 t2) + = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + go_co subst (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + go_co subst (NthCo n co) + = mkNthCo n (go_co subst co) + go_co subst (LRCo lr co) + = mkLRCo lr (go_co subst co) + go_co subst (InstCo co arg) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (CoherenceCo co1 co2) + = mkCoherenceCo (go_co subst co1) (go_co subst co2) + go_co subst (KindCo co) + = mkKindCo (go_co subst co) + go_co subst (SubCo co) + = mkSubCo (go_co subst co) + go_co subst (AxiomRuleCo ax cs) = AxiomRuleCo ax (map (go_co subst) cs) + + go_prov _ UnsafeCoerceProv = UnsafeCoerceProv + go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) + go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) + go_prov _ p@(PluginProv _) = p + go_prov _ (HoleProv h) = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + -- the "False" and "const" are to accommodate the type of + -- substForAllCoBndrCallback, which is general enough to + -- handle coercion optimization (which sometimes swaps the + -- order of a coercion) + go_cobndr subst = substForAllCoBndrCallback False (go_co subst) subst + +{- +************************************************************************ +* * + Analyzing types +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for mapCoercion ForAllCo case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant. +It stores a TyVar and a Coercion, where the kind of the TyVar always matches +the left-hand kind of the coercion. This is convenient lots of the time, but +not when mapping a function over a coercion. + +The problem is that tcm_tybinder will affect the TyVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINABLE pragmas are indispensable. mapType/mapCoercion are used +to implement zonking, and it's vital that they get specialised to the TcM +monad. This specialisation happens automatically (that is, without a +SPECIALISE pragma) as long as the definitions are INLINABLE. For example, +this one change made a 20% allocation difference in perf/compiler/T5030. + +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_smart :: Bool -- ^ Should the new type be created with smart + -- constructors? + , tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> Role + -> Type -> Type -> m Coercion + -- ^ What to do with coercion holes. See Note [Coercion holes] in + -- TyCoRep. + + , tcm_tybinder :: env -> TyVar -> VisibilityFlag -> m (env, TyVar) + -- ^ The returned env is used in the extended scope + } + +{-# INLINABLE mapType #-} -- See Note [Specialising mappers] +mapType :: (Applicative m, Monad m) => TyCoMapper env m -> env -> Type -> m Type +mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar + , tcm_tybinder = tybinder }) + env ty + = go ty + where + go (TyVarTy tv) = tyvar env tv + go (AppTy t1 t2) = mkappty <$> go t1 <*> go t2 + go (TyConApp tc tys) = mktyconapp tc <$> mapM go tys + go (ForAllTy (Anon arg) res) = mkfunty <$> go arg <*> go res + go (ForAllTy (Named tv vis) inner) + = do { (env', tv') <- tybinder env tv vis + ; inner' <- mapType mapper env' inner + ; return $ ForAllTy (Named tv' vis) inner' } + go ty@(LitTy {}) = return ty + go (CastTy ty co) = mkcastty <$> go ty <*> mapCoercion mapper env co + go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co + + (mktyconapp, mkappty, mkcastty, mkfunty) + | smart = (mkTyConApp, mkAppTy, mkCastTy, mkFunTy) + | otherwise = (TyConApp, AppTy, CastTy, ForAllTy . Anon) + +{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] +mapCoercion :: (Applicative m, Monad m) + => TyCoMapper env m -> env -> Coercion -> m Coercion +mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar + , tcm_hole = cohole, tcm_tybinder = tybinder }) + env co + = go co + where + go (Refl r ty) = Refl r <$> mapType mapper env ty + go (TyConAppCo r tc args) + = mktyconappco r tc <$> mapM go args + go (AppCo c1 c2) = mkappco <$> go c1 <*> go c2 + go (ForAllCo tv kind_co co) + = do { kind_co' <- go kind_co + ; (env', tv') <- tybinder env tv Invisible + ; co' <- mapCoercion mapper env' co + ; return $ mkforallco tv' kind_co' co' } + -- See Note [Efficiency for mapCoercion ForAllCo case] + go (CoVarCo cv) = covar env cv + go (AxiomInstCo ax i args) + = mkaxiominstco ax i <$> mapM go args + go (UnivCo (HoleProv hole) r t1 t2) + = cohole env hole r t1 t2 + go (UnivCo p r t1 t2) + = mkunivco <$> go_prov p <*> pure r + <*> mapType mapper env t1 <*> mapType mapper env t2 + go (SymCo co) = mksymco <$> go co + go (TransCo c1 c2) = mktransco <$> go c1 <*> go c2 + go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos + go (NthCo i co) = mknthco i <$> go co + go (LRCo lr co) = mklrco lr <$> go co + go (InstCo co arg) = mkinstco <$> go co <*> go arg + go (CoherenceCo c1 c2) = mkcoherenceco <$> go c1 <*> go c2 + go (KindCo co) = mkkindco <$> go co + go (SubCo co) = mksubco <$> go co + + go_prov UnsafeCoerceProv = return UnsafeCoerceProv + go_prov (PhantomProv co) = PhantomProv <$> go co + go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co + go_prov p@(PluginProv _) = return p + go_prov (HoleProv _) = panic "mapCoercion" + + ( mktyconappco, mkappco, mkaxiominstco, mkunivco + , mksymco, mktransco, mknthco, mklrco, mkinstco, mkcoherenceco + , mkkindco, mksubco, mkforallco) + | smart + = ( mkTyConAppCo, mkAppCo, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo, mkCoherenceCo + , mkKindCo, mkSubCo, mkForAllCo ) + | otherwise + = ( TyConAppCo, AppCo, AxiomInstCo, UnivCo + , SymCo, TransCo, NthCo, LRCo, InstCo, CoherenceCo + , KindCo, SubCo, ForAllCo ) {- ************************************************************************ @@ -314,8 +543,22 @@ isTyVarTy ty = isJust (getTyVar_maybe ty) -- | Attempts to obtain the type variable underlying a 'Type' getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe _ = Nothing + | otherwise = repGetTyVar_maybe ty + +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~R kind type +getCastedTyVar_maybe :: Type -> Maybe (TyVar, Coercion) +getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' +getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) +getCastedTyVar_maybe (TyVarTy tv) + = Just (tv, mkReflCo Nominal (tyVarKind tv)) +getCastedTyVar_maybe _ = Nothing + +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing allDistinctTyVars :: [KindOrType] -> Bool allDistinctTyVars tkvs = go emptyVarSet tkvs @@ -354,6 +597,7 @@ are the same, as are 'Constraint' and '*'. But for now I've put the test in repSplitAppTy_maybe, which applies throughout, because the other calls to splitAppTy are in Unify, which is also used by the type checker (e.g. when matching type-function equations). + -} -- | Applies a type to another, as in e.g. @k a@ @@ -387,15 +631,30 @@ splitAppTy_maybe ty = repSplitAppTy_maybe ty repSplitAppTy_maybe :: Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that -- any Core view stuff is already done -repSplitAppTy_maybe (FunTy ty1 ty2) - | isConstraintKind (typeKind ty1) = Nothing -- See Note [Decomposing fat arrow c=>t] - | otherwise = Just (TyConApp funTyCon [ty1], ty2) +repSplitAppTy_maybe (ForAllTy (Anon ty1) ty2) + = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc , Just (tys', ty') <- snocView tys = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! repSplitAppTy_maybe _other = Nothing + +-- this one doesn't braek apart (c => t). +-- See Note [Decomposing fat arrow c=>t] +-- Defined here to avoid module loops between Unify and TcType. +tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that +-- any coreView stuff is already done. Refuses to look through (c => t) +tcRepSplitAppTy_maybe (ForAllTy (Anon ty1) ty2) + | isConstraintKind (typeKind ty1) = Nothing -- See Note [Decomposing fat arrow c=>t] + | otherwise = Just (TyConApp funTyCon [ty1], ty2) +tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcRepSplitAppTy_maybe (TyConApp tc tys) + | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! +tcRepSplitAppTy_maybe _other = Nothing ------------- splitAppTy :: Type -> (Type, Type) -- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', @@ -420,7 +679,7 @@ splitAppTys ty = split ty ty [] (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy ty1 ty2) args = ASSERT( null args ) + split _ (ForAllTy (Anon ty1) ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) split orig_ty _ args = (orig_ty, args) @@ -490,14 +749,9 @@ pprUserTypeErrorTy ty = --------------------------------------------------------------------- FunTy ~~~~~ --} - -mkFunTy :: Type -> Type -> Type --- ^ Creates a function type from the given argument and result type -mkFunTy arg res = FunTy arg res -mkFunTys :: [Type] -> Type -> Type -mkFunTys tys ty = foldr mkFunTy ty tys +Function types are represented with (ForAllTy (Anon ...) ...) +-} isFunTy :: Type -> Bool isFunTy ty = isJust (splitFunTy_maybe ty) @@ -506,21 +760,21 @@ splitFunTy :: Type -> (Type, Type) -- ^ Attempts to extract the argument and result types from a type, and -- panics if that is not possible. See also 'splitFunTy_maybe' splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' -splitFunTy (FunTy arg res) = (arg, res) -splitFunTy other = pprPanic "splitFunTy" (ppr other) +splitFunTy (ForAllTy (Anon arg) res) = (arg, res) +splitFunTy other = pprPanic "splitFunTy" (ppr other) splitFunTy_maybe :: Type -> Maybe (Type, Type) -- ^ Attempts to extract the argument and result types from a type splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' -splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe _ = Nothing +splitFunTy_maybe (ForAllTy (Anon arg) res) = Just (arg, res) +splitFunTy_maybe _ = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args _ (FunTy arg res) = split (arg:args) res res - split args orig_ty _ = (reverse args, orig_ty) + split args _ (ForAllTy (Anon arg) res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) splitFunTysN :: Int -> Type -> ([Type], Type) -- ^ Split off exactly the given number argument types, and panics if that is not possible @@ -530,31 +784,27 @@ splitFunTysN n ty = ASSERT2( isFunTy ty, int n <+> ppr ty ) case splitFunTysN (n-1) res of { (args, res) -> (arg:args, res) }} --- | Splits off argument types from the given type and associating --- them with the things in the input list from left to right. The --- final result type is returned, along with the resulting pairs of --- objects and types, albeit with the list of pairs in reverse order. --- Panics if there are not enough argument types for the input list. -zipFunTys :: Outputable a => [a] -> Type -> ([(a, Type)], Type) -zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty - where - split acc [] nty _ = (reverse acc, nty) - split acc xs nty ty - | Just ty' <- coreView ty = split acc xs nty ty' - split acc (x:xs) _ (FunTy arg res) = split ((x,arg):acc) xs res res - split _ _ _ _ = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) - funResultTy :: Type -> Type -- ^ Extract the function result type and panic if that is not possible -funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (FunTy _arg res) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) +funResultTy ty = piResultTy ty (pprPanic "funResultTy" (ppr ty)) + +-- | Essentially 'funResultTy' on kinds handling pi-types too +piResultTy :: Type -> Type -> Type +piResultTy ty arg | Just ty' <- coreView ty = piResultTy ty' arg +piResultTy (ForAllTy (Anon _) res) _ = res +piResultTy (ForAllTy (Named tv _) res) arg = substTyWith [tv] [arg] res +piResultTy ty arg = pprPanic "piResultTy" + (ppr ty $$ ppr arg) + +-- | Fold 'piResultTy' over many types +piResultTys :: Type -> [Type] -> Type +piResultTys = foldl piResultTy funArgTy :: Type -> Type -- ^ Extract the function argument type and panic if that is not possible funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (FunTy arg _res) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) +funArgTy (ForAllTy (Anon arg) _res) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) {- --------------------------------------------------------------------- @@ -567,7 +817,7 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty) mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 + = ForAllTy (Anon ty1) ty2 | otherwise = TyConApp tycon tys @@ -576,12 +826,20 @@ mkTyConApp tycon tys -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. +-- | Retrieve the tycon heading this type, if there is one. Does /not/ +-- look through synonyms. +tyConAppTyConPicky_maybe :: Type -> Maybe TyCon +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (ForAllTy (Anon _) _) = Just funTyCon +tyConAppTyConPicky_maybe _ = Nothing + + -- | The same as @fst . splitTyConApp@ tyConAppTyCon_maybe :: Type -> Maybe TyCon tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' -tyConAppTyCon_maybe (TyConApp tc _) = Just tc -tyConAppTyCon_maybe (FunTy {}) = Just funTyCon -tyConAppTyCon_maybe _ = Nothing +tyConAppTyCon_maybe (TyConApp tc _) = Just tc +tyConAppTyCon_maybe (ForAllTy (Anon _) _) = Just funTyCon +tyConAppTyCon_maybe _ = Nothing tyConAppTyCon :: Type -> TyCon tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) @@ -589,10 +847,9 @@ tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr -- | The same as @snd . splitTyConApp@ tyConAppArgs_maybe :: Type -> Maybe [Type] tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' -tyConAppArgs_maybe (TyConApp _ tys) = Just tys -tyConAppArgs_maybe (FunTy arg res) = Just [arg,res] -tyConAppArgs_maybe _ = Nothing - +tyConAppArgs_maybe (TyConApp _ tys) = Just tys +tyConAppArgs_maybe (ForAllTy (Anon arg) res) = Just [arg,res] +tyConAppArgs_maybe _ = Nothing tyConAppArgs :: Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) @@ -601,7 +858,7 @@ tyConAppArgN :: Int -> Type -> Type -- Executing Nth tyConAppArgN n ty = case tyConAppArgs_maybe ty of - Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n + Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys `getNth` n Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) -- | Attempts to tease a type apart into a type constructor and the application @@ -616,9 +873,14 @@ splitTyConApp ty = case splitTyConApp_maybe ty of -- of a number of arguments to that constructor splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' -splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -splitTyConApp_maybe _ = Nothing +splitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +-- | Like 'splitTyConApp_maybe', but doesn't look through synonyms. This +-- assumes the synonyms have already been dealt with. +repSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (ForAllTy (Anon arg) res) = Just (funTyCon, [arg,res]) +repSplitTyConApp_maybe _ = Nothing -- | Attempts to tease a list type apart and gives the type of the elements if -- successful (looks through type synonyms) @@ -641,14 +903,6 @@ nextRole ty | otherwise = Nominal -splitTyConArgs :: TyCon -> [KindOrType] -> ([Kind], [Type]) --- Given a tycon app (T k1 .. kn t1 .. tm), split the kind and type args --- TyCons always have prenex kinds -splitTyConArgs tc kts - = splitAtList kind_vars kts - where - (kind_vars, _) = splitForAllTys (tyConKind tc) - newTyConInstRhs :: TyCon -> [Type] -> Type -- ^ Unwrap one 'layer' of newtype on a type constructor and its -- arguments, using an eta-reduced version of the @newtype@ if possible. @@ -661,6 +915,125 @@ newTyConInstRhs tycon tys {- --------------------------------------------------------------------- + CastTy + ~~~~~~ +A casted type has its *kind* casted into something new. + +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Here is the (truncated) typing rule for the dependent ForAllTy: + +inner : kind +------------------------------------ +ForAllTy (Named tv vis) inner : kind + +Note that neither the inner type nor for ForAllTy itself have to have +kind *! But, it means that we should push any kind casts through the +ForAllTy. The only trouble is avoiding capture. + +-} + +-- | Make a 'CastTy'. The Coercion must be nominal. +mkCastTy :: Type -> Coercion -> Type +-- Running example: +-- T :: forall k1. k1 -> forall k2. k2 -> Bool -> Maybe k1 -> * +-- co :: * ~R X (maybe X is a newtype around *) +-- ty = T Nat 3 Symbol "foo" True (Just 2) +-- +-- We wish to "push" the cast down as far as possible. See also +-- Note [Pushing down casts] in TyCoRep. Here is where we end +-- up: +-- +-- (T Nat 3 Symbol |> <Symbol> -> <Bool> -> <Maybe Nat> -> co) +-- "foo" True (Just 2) +-- +-- General approach: +-- +mkCastTy ty (Refl {}) = ty +mkCastTy (CastTy ty co1) co2 = mkCastTy ty (co1 `mkTransCo` co2) +-- See Note [Weird typing rule for ForAllTy] +mkCastTy (ForAllTy (Named tv vis) inner_ty) co + = -- have to make sure that pushing the co in doesn't capture the bound var + let fvs = tyCoVarsOfCo co + empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substTyVarBndr empty_subst tv + in + ForAllTy (Named tv' vis) (substTy subst inner_ty `mkCastTy` co) +mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; + -- there may be unzonked variables about + let result = split_apps [] ty co in + ASSERT2( CastTy ty co `eqType` result + , ppr ty <+> dcolon <+> ppr (typeKind ty) $$ + ppr co <+> dcolon <+> ppr (coercionKind co) $$ + ppr result <+> dcolon <+> ppr (typeKind result) ) + result + where + -- split_apps breaks apart any type applications, so we can see how far down + -- to push the cast + split_apps args (AppTy t1 t2) co + = split_apps (t2:args) t1 co + split_apps args (TyConApp tc tc_args) co + | mightBeUnsaturatedTyCon tc + = affix_co (tyConKind tc) (mkTyConTy tc) (tc_args `chkAppend` args) co + | otherwise -- not decomposable... but it may still be oversaturated + = let (non_decomp_args, decomp_args) = splitAt (tyConArity tc) tc_args + saturated_tc = mkTyConApp tc non_decomp_args + in + affix_co (typeKind saturated_tc) saturated_tc (decomp_args `chkAppend` args) co + + split_apps args (ForAllTy (Anon arg) res) co + = affix_co (tyConKind funTyCon) (mkTyConTy funTyCon) + (arg : res : args) co + split_apps args ty co + = affix_co (typeKind ty) ty args co + + -- having broken everything apart, this figures out the point at which there + -- are no more dependent quantifications, and puts the cast there + affix_co _ ty [] co = no_double_casts ty co + affix_co kind ty args co + -- if kind contains any dependent quantifications, we can't push. + -- apply arguments until it doesn't + = let (bndrs, _inner_ki) = splitPiTys kind + (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs + (some_dep_args, rest_args) = splitAtList some_dep_bndrs args + dep_subst = zipOpenTCvSubstBinders some_dep_bndrs some_dep_args + used_no_dep_bndrs = takeList rest_args no_dep_bndrs + rest_arg_tys = substTys dep_subst (map binderType used_no_dep_bndrs) + co' = mkFunCos Nominal + (map (mkReflCo Nominal) rest_arg_tys) + co + in + ((ty `mkAppTys` some_dep_args) `no_double_casts` co') `mkAppTys` rest_args + + no_double_casts (CastTy ty co1) co2 = CastTy ty (co1 `mkTransCo` co2) + no_double_casts ty co = CastTy ty co + +{- +-------------------------------------------------------------------- + CoercionTy + ~~~~~~~~~~ +CoercionTy allows us to inject coercions into types. A CoercionTy +should appear only in the right-hand side of an application. +-} + +mkCoercionTy :: Coercion -> Type +mkCoercionTy = CoercionTy + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + +{- +--------------------------------------------------------------------- SynTy ~~~~~ @@ -699,6 +1072,10 @@ type UnaryType = Type data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see Note [Nullary unboxed tuple]) | UnaryRep UnaryType +instance Outputable RepType where + ppr (UbxTupleRep tys) = ptext (sLit "UbxTupleRep") <+> ppr tys + ppr (UnaryRep ty) = ptext (sLit "UnaryRep") <+> ppr ty + flattenRepType :: RepType -> [UnaryType] flattenRepType (UbxTupleRep tys) = tys flattenRepType (UnaryRep ty) = [ty] @@ -709,6 +1086,7 @@ flattenRepType (UnaryRep ty) = [ty] -- 2. Synonyms -- 3. Predicates -- 4. All newtypes, including recursive ones, but not newtype families +-- 5. Casts -- -- It's useful in the back end of the compiler. repType :: Type -> RepType @@ -720,8 +1098,8 @@ repType ty | Just ty' <- coreView ty = go rec_nts ty' - go rec_nts (ForAllTy _ ty) -- Drop foralls - = go rec_nts ty + go rec_nts (ForAllTy (Named {}) ty2) -- Drop type foralls + = go rec_nts ty2 go rec_nts (TyConApp tc tys) -- Expand newtypes | isNewTyCon tc @@ -732,29 +1110,18 @@ repType ty | isUnboxedTupleTyCon tc = if null tys then UnaryRep voidPrimTy -- See Note [Nullary unboxed tuple] - else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys) + else UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_levity_tys) + where + -- See Note [Unboxed tuple levity vars] in TyCon + non_levity_tys = drop (length tys `div` 2) tys - go _ ty = UnaryRep ty + go rec_nts (CastTy ty _) + = go rec_nts ty + go _ ty@(CoercionTy _) + = pprPanic "repType" (ppr ty) --- | All type constructors occurring in the type; looking through type --- synonyms, but not newtypes. --- When it finds a Class, it returns the class TyCon. -tyConsOfType :: Type -> NameEnv TyCon -tyConsOfType ty - = go ty - where - go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyNameEnv - go (LitTy {}) = emptyNameEnv - go (TyConApp tc tys) = go_tc tc tys - go (AppTy a b) = go a `plusNameEnv` go b - go (FunTy a b) = go a `plusNameEnv` go b - go (ForAllTy _ ty) = go ty - - go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc - go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + go _ ty = UnaryRep ty -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. @@ -764,18 +1131,19 @@ typePrimRep :: UnaryType -> PrimRep typePrimRep ty = case repType ty of UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty) - UnaryRep rep -> case rep of - TyConApp tc _ -> tyConPrimRep tc - FunTy _ _ -> PtrRep - AppTy _ _ -> PtrRep -- See Note [AppTy rep] - TyVarTy _ -> PtrRep - _ -> pprPanic "typePrimRep: UnaryRep" (ppr ty) + UnaryRep rep -> go rep + where go (TyConApp tc _) = tyConPrimRep tc + go (ForAllTy _ _) = PtrRep + go (AppTy _ _) = PtrRep -- See Note [AppTy rep] + go (TyVarTy _) = PtrRep + go (CastTy ty _) = go ty + go _ = pprPanic "typePrimRep: UnaryRep" (ppr ty) typeRepArity :: Arity -> Type -> RepArity typeRepArity 0 _ = 0 typeRepArity n ty = case repType ty of - UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2 - _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty)) + UnaryRep (ForAllTy bndr ty) -> length (flattenRepType (repType (binderType bndr))) + typeRepArity (n - 1) ty + _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty, repType ty)) isVoidTy :: Type -> Bool -- True if the type has zero width @@ -789,86 +1157,201 @@ Note [AppTy rep] Types of the form 'f a' must be of kind *, not #, so we are guaranteed that they are represented by pointers. The reason is that f must have kind (kk -> kk) and kk cannot be unlifted; see Note [The kind invariant] -in TypeRep. +in TyCoRep. --------------------------------------------------------------------- ForAllTy ~~~~~~~~ -} -mkForAllTy :: TyVar -> Type -> Type -mkForAllTy tyvar ty - = ForAllTy tyvar ty +mkForAllTy :: TyBinder -> Type -> Type +mkForAllTy = ForAllTy + +-- | Make a dependent forall. +mkNamedForAllTy :: TyVar -> VisibilityFlag -> Type -> Type +mkNamedForAllTy tv vis = ASSERT( isTyVar tv ) + ForAllTy (Named tv vis) -- | Wraps foralls over the type using the provided 'TyVar's from left to right -mkForAllTys :: [TyVar] -> Type -> Type +mkForAllTys :: [TyBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -mkPiKinds :: [TyVar] -> Kind -> Kind --- mkPiKinds [k1, k2, (a:k1 -> *)] k2 --- returns forall k1 k2. (k1 -> *) -> k2 -mkPiKinds [] res = res -mkPiKinds (tv:tvs) res - | isKindVar tv = ForAllTy tv (mkPiKinds tvs res) - | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) +-- | Like mkForAllTys, but assumes all variables are dependent and invisible, +-- a common case +mkInvForAllTys :: [TyVar] -> Type -> Type +mkInvForAllTys tvs = ASSERT( all isTyVar tvs ) + mkForAllTys (map (flip Named Invisible) tvs) + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) + mkForAllTys (map (flip Named Visible) tvs) mkPiType :: Var -> Type -> Type --- ^ Makes a @(->)@ type or a forall type, depending +-- ^ Makes a @(->)@ type or an implicit forall type, depending -- on whether it is given a type variable or a term variable. +-- This is used, for example, when producing the type of a lambda. mkPiTypes :: [Var] -> Type -> Type -- ^ 'mkPiType' for multiple type or value arguments mkPiType v ty - | isId v = mkFunTy (varType v) ty - | otherwise = mkForAllTy v ty + | isTyVar v = mkForAllTy (Named v Invisible) ty + | otherwise = mkForAllTy (Anon (varType v)) ty mkPiTypes vs ty = foldr mkPiType ty vs -isForAllTy :: Type -> Bool -isForAllTy (ForAllTy _ _) = True -isForAllTy _ = False +-- | Given a list of type-level vars, makes ForAllTys, preferring +-- anonymous binders if the variable is, in fact, not dependent. +-- All binders are /visible/. +mkPiTypesPreferFunTy :: [TyVar] -> Type -> Type +mkPiTypesPreferFunTy vars inner_ty = fst $ go vars inner_ty + where + go :: [TyVar] -> Type -> (Type, VarSet) -- also returns the free vars + go [] ty = (ty, tyCoVarsOfType ty) + go (v:vs) ty + = if v `elemVarSet` fvs + then ( mkForAllTy (Named v Visible) qty + , fvs `delVarSet` v `unionVarSet` kind_vars ) + else ( mkForAllTy (Anon (tyVarKind v)) qty + , fvs `unionVarSet` kind_vars ) + where + (qty, fvs) = go vs ty + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the list of tyvars and the result type. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTys :: Type -> ([TyVar], Type) +splitForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Named tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Split off all TyBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([TyBinder], Type) +splitPiTys ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Like 'splitPiTys' but split off only /named/ binders. +splitNamedPiTys :: Type -> ([TyBinder], Type) +splitNamedPiTys ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b@(Named {}) res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) --- | Attempts to take a forall type apart, returning the bound type variable --- and the remainder of the type +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy (ForAllTy (Named {}) _) = True +isForAllTy _ = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy (ForAllTy {}) = True +isPiTy _ = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTy :: Type -> (TyVar, Type) +splitForAllTy ty + | Just answer <- splitForAllTy_maybe ty = answer + | otherwise = pprPanic "splitForAllTy" (ppr ty) + +-- | Attempts to take a forall type apart, but only if it's a proper forall, +-- with a named binder splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) splitForAllTy_maybe ty = splitFAT_m ty where splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty' - splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) - splitFAT_m _ = Nothing + splitFAT_m (ForAllTy (Named tv _) ty) = Just (tv, ty) + splitFAT_m _ = Nothing --- | Attempts to take a forall type apart, returning all the immediate such bound --- type variables and the remainder of the type. Always succeeds, even if that means --- returning an empty list of 'TyVar's -splitForAllTys :: Type -> ([TyVar], Type) -splitForAllTys ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +splitPiTy_maybe :: Type -> Maybe (TyBinder, Type) +splitPiTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy bndr ty) = Just (bndr, ty) + go _ = Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (TyBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) --- | Equivalent to @snd . splitForAllTys@ +-- | Drops all non-anonymous ForAllTys dropForAlls :: Type -> Type -dropForAlls ty = snd (splitForAllTys ty) +dropForAlls ty | Just ty' <- coreView ty = dropForAlls ty' + | otherwise = go ty + where + go (ForAllTy (Named {}) res) = go res + go res = res -{- --- (mkPiType now in CoreUtils) +-- | Given a tycon and its arguments, filters out any invisible arguments +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibles tc id tys -applyTy, applyTys -~~~~~~~~~~~~~~~~~ --} +-- | Like 'filterOutInvisibles', but works on 'TyVar's +filterOutInvisibleTyVars :: TyCon -> [TyVar] -> [TyVar] +filterOutInvisibleTyVars tc tvs = snd $ partitionInvisibles tc mkTyVarTy tvs --- | Instantiate a forall type with one or more type arguments. --- Used when we have a polymorphic function applied to type args: +-- | Given a tycon and a list of things (which correspond to arguments), +-- partitions the things into the invisible ones and the visible ones. +-- The callback function is necessary for this scenario: +-- +-- > T :: forall k. k -> k +-- > partitionInvisibles T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get -- --- > f t1 t2 +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n -- --- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression. --- Panics if no application is possible. -applyTy :: Type -> KindOrType -> Type -applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg -applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty -applyTy _ _ = panic "applyTy" +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +-- +-- If you're absolutely sure that your tycon's kind doesn't end in a variable, +-- it's OK if the callback function panics, as that's the only time it's +-- consulted. +partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) +partitionInvisibles tc get_ty = go emptyTCvSubst (tyConKind tc) + where + go _ _ [] = ([], []) + go subst (ForAllTy bndr res_ki) (x:xs) + | isVisibleBinder bndr = second (x :) (go subst' res_ki xs) + | otherwise = first (x :) (go subst' res_ki xs) + where + subst' = extendTCvSubstBinder subst bndr (get_ty x) + go subst (TyVarTy tv) xs + | Just ki <- lookupTyVar subst tv = go subst ki xs + go _ _ xs = ([], xs) -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is visible. + +-- like splitPiTys, but returns only *invisible* binders, including constraints +splitPiTysInvisible :: Type -> ([TyBinder], Type) +splitPiTysInvisible ty = split ty ty [] + where + split orig_ty ty bndrs + | Just ty' <- coreView ty = split orig_ty ty' bndrs + split _ (ForAllTy bndr ty) bndrs + | isInvisibleBinder bndr + = split ty ty (bndr:bndrs) + + split orig_ty _ bndrs + = (reverse bndrs, orig_ty) + +tyConBinders :: TyCon -> [TyBinder] +tyConBinders = fst . splitPiTys . tyConKind + +{- +applyTys +~~~~~~~~~~~~~~~~~ +-} applyTys :: Type -> [KindOrType] -> Type -- ^ This function is interesting because: @@ -895,19 +1378,19 @@ applyTys ty args = applyTysD empty ty args applyTysD :: SDoc -> Type -> [Type] -> Type -- Debug version applyTysD _ orig_fun_ty [] = orig_fun_ty applyTysD doc orig_fun_ty arg_tys - | n_tvs == n_args -- The vastly common case - = substTyWith tvs arg_tys rho_ty - | n_tvs > n_args -- Too many for-alls - = substTyWith (take n_args tvs) arg_tys - (mkForAllTys (drop n_args tvs) rho_ty) + | n_bndrs == n_args -- The vastly common case + = substTyWithBinders bndrs arg_tys rho_ty + | n_bndrs > n_args -- Too many for-alls + = substTyWithBinders (take n_args bndrs) arg_tys + (mkForAllTys (drop n_args bndrs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty $$ ppr arg_tys ) -- Zero case gives infinite loop! - applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty) - (drop n_tvs arg_tys) + = ASSERT2( n_bndrs > 0, doc $$ ppr orig_fun_ty $$ ppr arg_tys ) -- Zero case gives infinite loop! + applyTysD doc (substTyWithBinders bndrs (take n_bndrs arg_tys) rho_ty) + (drop n_bndrs arg_tys) where - (tvs, rho_ty) = splitForAllTys orig_fun_ty - n_tvs = length tvs - n_args = length arg_tys + (bndrs, rho_ty) = splitPiTys orig_fun_ty + n_bndrs = length bndrs + n_args = length arg_tys applyTysX :: [TyVar] -> Type -> [Type] -> Type -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys @@ -919,8 +1402,96 @@ applyTysX tvs body_ty arg_tys n_tvs = length tvs {- -************************************************************************ -* * +%************************************************************************ +%* * + TyBinders +%* * +%************************************************************************ +-} + +-- | Make a named binder +mkNamedBinder :: Var -> VisibilityFlag -> TyBinder +mkNamedBinder = Named + +-- | Make an anonymous binder +mkAnonBinder :: Type -> TyBinder +mkAnonBinder = Anon + +isNamedBinder :: TyBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder _ = False + +isAnonBinder :: TyBinder -> Bool +isAnonBinder (Anon {}) = True +isAnonBinder _ = False + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isIdLikeBinder :: TyBinder -> Bool +isIdLikeBinder (Named {}) = False +isIdLikeBinder (Anon {}) = True + +-- | Does this type, when used to the left of an arrow, require +-- a visible argument? This checks to see if the kind of the type +-- is constraint. +isVisibleType :: Type -> Bool +isVisibleType = not . isPredTy + +binderVisibility :: TyBinder -> VisibilityFlag +binderVisibility (Named _ vis) = vis +binderVisibility (Anon ty) + | isVisibleType ty = Visible + | otherwise = Invisible + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyBinder -> Bool +isInvisibleBinder (Named _ vis) = vis == Invisible +isInvisibleBinder (Anon ty) = isPredTy ty + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + +-- | Extract a bound variable in a binder, if any +binderVar_maybe :: TyBinder -> Maybe Var +binderVar_maybe (Named v _) = Just v +binderVar_maybe (Anon {}) = Nothing + +-- | Extract a bound variable in a binder, or panics +binderVar :: String -- ^ printed if there is a panic + -> TyBinder -> Var +binderVar _ (Named v _) = v +binderVar e (Anon t) = pprPanic ("binderVar (" ++ e ++ ")") (ppr t) + +-- | Extract a relevant type, if there is one. +binderRelevantType_maybe :: TyBinder -> Maybe Type +binderRelevantType_maybe (Named {}) = Nothing +binderRelevantType_maybe (Anon ty) = Just ty + +-- | Like 'maybe', but for binders. +caseBinder :: TyBinder -- ^ binder to scrutinize + -> (TyVar -> a) -- ^ named case + -> (Type -> a) -- ^ anonymous case + -> a +caseBinder (Named v _) f _ = f v +caseBinder (Anon t) _ d = d t + +-- | Break apart a list of binders into tyvars and anonymous types. +partitionBinders :: [TyBinder] -> ([TyVar], [Type]) +partitionBinders = partitionWith named_or_anon + where + named_or_anon bndr = caseBinder bndr Left Right + +-- | Break apart a list of binders into a list of named binders and +-- a list of anonymous types. +partitionBindersIntoBinders :: [TyBinder] -> ([TyBinder], [Type]) +partitionBindersIntoBinders = partitionWith named_or_anon + where + named_or_anon bndr = caseBinder bndr (\_ -> Left bndr) Right + +{- +%************************************************************************ +%* * Pred * * ************************************************************************ @@ -928,33 +1499,50 @@ applyTysX tvs body_ty arg_tys Predicates on PredType -} +-- | Is the type suitable to classify a given/wanted in the typechecker? isPredTy :: Type -> Bool -- NB: isPredTy is used when printing types, which can happen in debug printing -- during type checking of not-fully-zonked types. So it's not cool to say -- isConstraintKind (typeKind ty) because absent zonking the type might -- be ill-kinded, and typeKind crashes -- Hence the rather tiresome story here + -- + -- NB: This must return "True" to *unlifted* coercions, which are not + -- of kind Constraint! isPredTy ty = go ty [] where go :: Type -> [KindOrType] -> Bool go (AppTy ty1 ty2) args = go ty1 (ty2 : args) - go (TyConApp tc tys) args = go_k (tyConKind tc) (tys ++ args) + go (TyConApp tc tys) args + | tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + , [_,_,_,_] <- all_args + = True + + | otherwise + = go_k (tyConKind tc) all_args + where + all_args = tys ++ args go (TyVarTy tv) args = go_k (tyVarKind tv) args go _ _ = False go_k :: Kind -> [KindOrType] -> Bool -- True <=> kind is k1 -> .. -> kn -> Constraint - go_k k [] = isConstraintKind k - go_k (FunTy _ k1) (_ :args) = go_k k1 args - go_k (ForAllTy kv k1) (k2:args) = go_k (substKiWith [kv] [k2] k1) args + go_k k [] = isConstraintKind k + go_k (ForAllTy bndr k1) (arg:args) + = go_k (substTyWithBinders [bndr] [arg] k1) args go_k _ _ = False -- Typeable * Int :: Constraint -isClassPred, isEqPred, isIPPred :: PredType -> Bool +isClassPred, isEqPred, isNomEqPred, isIPPred :: PredType -> Bool isClassPred ty = case tyConAppTyCon_maybe ty of Just tyCon | isClassTyCon tyCon -> True _ -> False isEqPred ty = case tyConAppTyCon_maybe ty of - Just tyCon -> tyCon `hasKey` eqTyConKey + Just tyCon -> tyCon `hasKey` eqPrimTyConKey + || tyCon `hasKey` eqReprPrimTyConKey + _ -> False + +isNomEqPred ty = case tyConAppTyCon_maybe ty of + Just tyCon -> tyCon `hasKey` eqPrimTyConKey _ -> False isIPPred ty = case tyConAppTyCon_maybe ty of @@ -984,34 +1572,49 @@ Make PredTypes --------------------- Equality types --------------------------------- -} --- | Creates a type equality predicate -mkEqPred :: Type -> Type -> PredType -mkEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) - TyConApp eqTyCon [k, ty1, ty2] - where - k = typeKind ty1 - -mkCoerciblePred :: Type -> Type -> PredType -mkCoerciblePred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) - TyConApp coercibleTyCon [k, ty1, ty2] - where - k = typeKind ty1 +-- | Makes a lifted equality predicate at the given role +mkPrimEqPredRole :: Role -> Type -> Type -> PredType +mkPrimEqPredRole Nominal = mkPrimEqPred +mkPrimEqPredRole Representational = mkReprPrimEqPred +mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" +-- | Creates a primitive type equality predicate. +-- Invariant: the types are not Coercions mkPrimEqPred :: Type -> Type -> Type -mkPrimEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) - TyConApp eqPrimTyCon [k, ty1, ty2] +mkPrimEqPred ty1 ty2 + = TyConApp eqPrimTyCon [k1, k2, ty1, ty2] where - k = typeKind ty1 + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Creates a primite type equality predicate with explicit kinds +mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroPrimEqPred k1 k2 ty1 ty2 = TyConApp eqPrimTyCon [k1, k2, ty1, ty2] + +-- | Creates a primitive representational type equality predicate +-- with explicit kinds +mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroReprPrimEqPred k1 k2 ty1 ty2 + = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + +-- | Try to split up a coercion type into the types that it coerces +splitCoercionType_maybe :: Type -> Maybe (Type, Type) +splitCoercionType_maybe ty + = do { (tc, [_, _, ty1, ty2]) <- splitTyConApp_maybe ty + ; guard $ tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + ; return (ty1, ty2) } mkReprPrimEqPred :: Type -> Type -> Type mkReprPrimEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) - TyConApp eqReprPrimTyCon [k, ty1, ty2] + = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] where - k = typeKind ty1 + k1 = typeKind ty1 + k2 = typeKind ty2 + +equalityTyCon :: Role -> TyCon +equalityTyCon Nominal = eqPrimTyCon +equalityTyCon Representational = eqReprPrimTyCon +equalityTyCon Phantom = eqPhantPrimTyCon -- --------------------- Dictionary types --------------------------------- @@ -1082,17 +1685,12 @@ data PredTree = ClassPred Class [Type] classifyPredType :: PredType -> PredTree classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of - Just (tc, tys) | tc `hasKey` coercibleTyConKey - , let [_, ty1, ty2] = tys - -> EqPred ReprEq ty1 ty2 - Just (tc, tys) | tc `hasKey` eqTyConKey - , let [_, ty1, ty2] = tys - -> EqPred NomEq ty1 ty2 - -- NB: Coercible is also a class, so this check must come *after* - -- the Coercible check - Just (tc, tys) | Just clas <- tyConClass_maybe tc - -> ClassPred clas tys - _ -> IrredPred ev_ty + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 + | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 + Just (tc, tys) + | Just clas <- tyConClass_maybe tc -> ClassPred clas tys + _ -> IrredPred ev_ty getClassPredTys :: PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of @@ -1107,33 +1705,28 @@ getClassPredTys_maybe ty = case splitTyConApp_maybe ty of getEqPredTys :: PredType -> (Type, Type) getEqPredTys ty = case splitTyConApp_maybe ty of - Just (tc, (_ : ty1 : ty2 : tys)) -> - ASSERT( null tys && (tc `hasKey` eqTyConKey - || tc `hasKey` coercibleTyConKey) ) - (ty1, ty2) + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey + || tc `hasKey` eqReprPrimTyConKey + -> (ty1, ty2) _ -> pprPanic "getEqPredTys" (ppr ty) getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) getEqPredTys_maybe ty = case splitTyConApp_maybe ty of - Just (tc, [_, ty1, ty2]) - | tc `hasKey` eqTyConKey -> Just (Nominal, ty1, ty2) - | tc `hasKey` coercibleTyConKey -> Just (Representational, ty1, ty2) + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) + | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) _ -> Nothing getEqPredRole :: PredType -> Role -getEqPredRole ty - = case splitTyConApp_maybe ty of - Just (tc, [_, _, _]) - | tc `hasKey` eqTyConKey -> Nominal - | tc `hasKey` coercibleTyConKey -> Representational - _ -> pprPanic "getEqPredRole" (ppr ty) +getEqPredRole ty = eqRelRole (predTypeEqRel ty) -- | Get the equality relation relevant for a pred type. predTypeEqRel :: PredType -> EqRel predTypeEqRel ty | Just (tc, _) <- splitTyConApp_maybe ty - , tc `hasKey` coercibleTyConKey + , tc `hasKey` eqReprPrimTyConKey = ReprEq | otherwise = NomEq @@ -1146,13 +1739,49 @@ predTypeEqRel ty ************************************************************************ -} +-- NB: This function does not respect `eqType`, in that two types that +-- are `eqType` may return different sizes. This is OK, because this +-- function is used only in reporting, not decision-making. typeSize :: Type -> Int -typeSize (LitTy {}) = 1 -typeSize (TyVarTy {}) = 1 -typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (ForAllTy _ t) = 1 + typeSize t -typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy b t) = typeSize (binderType b) + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co + +{- +%************************************************************************ +%* * + Well-scoped tyvars +* * +************************************************************************ +-} + +-- | Do a topological sort on a list of tyvars. This is a deterministic +-- sorting operation (that is, doesn't depend on Uniques). +toposortTyVars :: [TyVar] -> [TyVar] +toposortTyVars tvs = reverse $ + [ tv | (tv, _, _) <- topologicalSortG $ + graphFromEdgedVertices nodes ] + where + var_ids :: VarEnv Int + var_ids = mkVarEnv (zip tvs [1..]) + + nodes = [ ( tv + , lookupVarEnv_NF var_ids tv + , mapMaybe (lookupVarEnv var_ids) + (tyCoVarsOfTypeList (tyVarKind tv)) ) + | tv <- tvs ] + +-- | Extract a well-scoped list of variables from a set of variables. +varSetElemsWellScoped :: VarSet -> [Var] +varSetElemsWellScoped = toposortTyVars . varSetElems + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = toposortTyVars . tyCoVarsOfTypeList {- ************************************************************************ @@ -1176,7 +1805,7 @@ mkFamilyTyConApp tc tys | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc , let tvs = tyConTyVars tc fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys ) - zipTopTvSubst tvs tys + zipTopTCvSubst tvs tys = mkTyConApp fam_tc (substTys fam_subst fam_tys) | otherwise = mkTyConApp tc tys @@ -1217,9 +1846,29 @@ isUnLiftedType :: Type -> Bool -- construct them isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' -isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty -isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType _ = False +isUnLiftedType (ForAllTy (Named {}) ty) = isUnLiftedType ty +isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType _ = False + +-- | Extract the levity classifier of a type. Panics if this is not possible. +getLevity :: String -- ^ Printed in case of an error + -> Type -> Type +getLevity err ty = getLevityFromKind err (typeKind ty) + +-- | Extract the levity classifier of a type from its kind. +-- For example, getLevityFromKind * = Lifted; getLevityFromKind # = Unlifted. +-- Panics if this is not possible. +getLevityFromKind :: String -- ^ Printed in case of an error + -> Type -> Type +getLevityFromKind err = go + where + go k | Just k' <- coreViewOneStarKind k = go k' + go k + | Just (tc, [arg]) <- splitTyConApp_maybe k + , tc `hasKey` tYPETyConKey + = arg + go k = pprPanic "getLevity" (text err $$ + ppr k <+> dcolon <+> ppr (typeKind k)) isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of @@ -1270,12 +1919,13 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of -} seqType :: Type -> () -seqType (LitTy n) = n `seq` () -seqType (TyVarTy tv) = tv `seq` () -seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy tv ty) = seqType (tyVarKind tv) `seq` seqType ty +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy bndr ty) = seqType (binderType bndr) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co seqTypes :: [Type] -> () seqTypes [] = () @@ -1288,101 +1938,113 @@ seqTypes (ty:tys) = seqType ty `seq` seqTypes tys (We don't use instances so that we know where it happens) * * ************************************************************************ --} -eqKind :: Kind -> Kind -> Bool --- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] -eqKind = eqType +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use repSplitAppTy_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +-} eqType :: Type -> Type -> Bool -- ^ Type equality on source types. Does not look through @newtypes@ or -- 'PredType's, but it does look through type synonyms. --- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] +-- This first checks that the kinds of the types are equal and then +-- checks whether the types are equal, ignoring casts and coercions. +-- (The kind check is a recursive call, but since all kinds have type +-- @Type@, there is no need to check the types of kinds.) +-- See also Note [Non-trivial definitional equality] in TyCoRep. eqType t1 t2 = isEqual $ cmpType t1 t2 -instance Eq Type where - (==) = eqType - +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. eqTypeX :: RnEnv2 -> Type -> Type -> Bool eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 +-- | Type equality on lists of types, looking through type synonyms +-- but not newtypes. eqTypes :: [Type] -> [Type] -> Bool eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 -eqPred :: PredType -> PredType -> Bool -eqPred = eqType - -eqPredX :: RnEnv2 -> PredType -> PredType -> Bool -eqPredX env p1 p2 = isEqual $ cmpTypeX env p1 p2 - -eqTyVarBndrs :: RnEnv2 -> [TyVar] -> [TyVar] -> Maybe RnEnv2 --- Check that the tyvar lists are the same length +eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length -- and have matching kinds; if so, extend the RnEnv2 -- Returns Nothing if they don't match -eqTyVarBndrs env [] [] +eqVarBndrs env [] [] = Just env -eqTyVarBndrs env (tv1:tvs1) (tv2:tvs2) +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) | eqTypeX env (tyVarKind tv1) (tyVarKind tv2) - = eqTyVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 -eqTyVarBndrs _ _ _= Nothing + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing -- Now here comes the real worker cmpType :: Type -> Type -> Ordering --- Watch out for horrible hack: See Note [Comparison with OpenTypeKind] -cmpType t1 t2 = cmpTypeX rn_env t1 t2 +cmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = cmpTypeX rn_env t1 t2 where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) cmpTypes :: [Type] -> [Type] -> Ordering cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2 where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2)) - -cmpPred :: PredType -> PredType -> Ordering -cmpPred p1 p2 = cmpTypeX rn_env p1 p2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType p1 `unionVarSet` tyVarsOfType p2)) + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 - | Just t2' <- coreView t2 = cmpTypeX env t1 t2' --- We expand predicate types, because in Core-land we have --- lots of definitions like --- fOrdBool :: Ord Bool --- fOrdBool = D:Ord .. .. .. --- So the RHS has a data type - -cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 -cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) - `thenCmp` cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 -cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 -cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 -cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `cmpTc` tc2) `thenCmp` cmpTypesX env tys1 tys2 -cmpTypeX _ (LitTy l1) (LitTy l2) = compare l1 l2 - - -- Deal with the rest: TyVarTy < AppTy < FunTy < LitTy < TyConApp < ForAllTy < PredTy -cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT - -cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT -cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT - -cmpTypeX _ (LitTy _) (TyVarTy _) = GT -cmpTypeX _ (LitTy _) (AppTy _ _) = GT -cmpTypeX _ (LitTy _) (FunTy _ _) = GT - -cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT -cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT -cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT -cmpTypeX _ (TyConApp _ _) (LitTy _) = GT - -cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT -cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT -cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT -cmpTypeX _ (ForAllTy _ _) (LitTy _) = GT -cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT - -cmpTypeX _ _ _ = LT + -- See Note [Non-trivial definitional equality] in TyCoRep +cmpTypeX env orig_t1 orig_t2 = go env k1 k2 `thenCmp` go env orig_t1 orig_t2 + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + go env t1 t2 | Just t1' <- coreViewOneStarKind t1 = go env t1' t2 + go env t1 t2 | Just t2' <- coreViewOneStarKind t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = rnOccL env tv1 `compare` rnOccR env tv2 + go env (ForAllTy (Named tv1 _) t1) (ForAllTy (Named tv2 _) t2) + = go env (tyVarKind tv1) (tyVarKind tv2) + `thenCmp` go (rnBndr2 env tv1 tv2) t1 t2 + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- repSplitAppTy_maybe ty2 + = go env s1 s2 `thenCmp` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- repSplitAppTy_maybe ty1 + = go env s1 s2 `thenCmp` go env t1 t2 + go env (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2) + = go env s1 s2 `thenCmp` go env t1 t2 + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = (tc1 `cmpTc` tc2) `thenCmp` gos env tys1 tys2 + go _ (LitTy l1) (LitTy l2) = compare l1 l2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = EQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "cmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (ForAllTy (Anon {}) _) = 6 + get_rank (ForAllTy (Named {}) _) = 7 + + gos _ [] [] = EQ + gos _ [] _ = LT + gos _ _ [] = GT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmp` gos env tys1 tys2 ------------- cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering @@ -1392,353 +2054,16 @@ cmpTypesX _ [] _ = LT cmpTypesX _ _ [] = GT ------------- +-- | Compare two 'TyCon's. NB: This should /never/ see the "star synonyms", +-- as recognized by Kind.isStarKindSynonymTyCon. See Note +-- [Kind Constraint and kind *] in Kind. cmpTc :: TyCon -> TyCon -> Ordering --- Here we treat * and Constraint as equal --- See Note [Kind Constraint and kind *] in Kinds.hs --- --- Also we treat OpenTypeKind as equal to either * or # --- See Note [Comparison with OpenTypeKind] cmpTc tc1 tc2 - | u1 == openTypeKindTyConKey, isSubOpenTypeKindKey u2 = EQ - | u2 == openTypeKindTyConKey, isSubOpenTypeKindKey u1 = EQ - | otherwise = nu1 `compare` nu2 + = ASSERT( not (isStarKindSynonymTyCon tc1) && not (isStarKindSynonymTyCon tc2) ) + u1 `compare` u2 where u1 = tyConUnique tc1 - nu1 = if u1==constraintKindTyConKey then liftedTypeKindTyConKey else u1 u2 = tyConUnique tc2 - nu2 = if u2==constraintKindTyConKey then liftedTypeKindTyConKey else u2 - -{- -Note [Comparison with OpenTypeKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In PrimOpWrappers we have things like - PrimOpWrappers.mkWeak# = /\ a b c. Prim.mkWeak# a b c -where - Prim.mkWeak# :: forall (a:Open) b c. a -> b -> c - -> State# RealWorld -> (# State# RealWorld, Weak# b #) -Now, eta reduction will turn the definition into - PrimOpWrappers.mkWeak# = Prim.mkWeak# -which is kind-of OK, but now the types aren't really equal. So HACK HACK -we pretend (in Core) that Open is equal to * or #. I hate this. - -Note [cmpTypeX] -~~~~~~~~~~~~~~~ - -When we compare foralls, we should look at the kinds. But if we do so, -we get a corelint error like the following (in -libraries/ghc-prim/GHC/PrimopWrappers.hs): - - Binder's type: forall (o_abY :: *). - o_abY - -> GHC.Prim.State# GHC.Prim.RealWorld - -> GHC.Prim.State# GHC.Prim.RealWorld - Rhs type: forall (a_12 :: ?). - a_12 - -> GHC.Prim.State# GHC.Prim.RealWorld - -> GHC.Prim.State# GHC.Prim.RealWorld - -This is why we don't look at the kind. Maybe we should look if the -kinds are compatible. - --- cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) --- = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) `thenCmp` --- cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 - -************************************************************************ -* * - Type substitutions -* * -************************************************************************ --} - -emptyTvSubstEnv :: TvSubstEnv -emptyTvSubstEnv = emptyVarEnv - -composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTvSubst in_scope env1 env2 - = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2 - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TvSubst in_scope env1 - -emptyTvSubst :: TvSubst -emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv - -isEmptyTvSubst :: TvSubst -> Bool - -- See Note [Extending the TvSubstEnv] in TypeRep -isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv - -mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst -mkTvSubst = TvSubst - -getTvSubstEnv :: TvSubst -> TvSubstEnv -getTvSubstEnv (TvSubst _ env) = env - -getTvInScope :: TvSubst -> InScopeSet -getTvInScope (TvSubst in_scope _) = in_scope - -isInScope :: Var -> TvSubst -> Bool -isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope - -notElemTvSubst :: CoVar -> TvSubst -> Bool -notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) - -setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst -setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv - -zapTvSubstEnv :: TvSubst -> TvSubst -zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv - -extendTvInScope :: TvSubst -> Var -> TvSubst -extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv - -extendTvInScopeList :: TvSubst -> [Var] -> TvSubst -extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv - -extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst -extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty) - -extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst -extendTvSubstList (TvSubst in_scope tenv) tvs tys - = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys)) - -unionTvSubst :: TvSubst -> TvSubst -> TvSubst --- Works when the ranges are disjoint -unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2) - = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) ) - TvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - --- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated - --- Note [Generating the in-scope set for a substitution] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- If we want to substitute [a -> ty1, b -> ty2] I used to --- think it was enough to generate an in-scope set that includes --- fv(ty1,ty2). But that's not enough; we really should also take the --- free vars of the type we are substituting into! Example: --- (forall b. (a,b,x)) [a -> List b] --- Then if we use the in-scope set {b}, there is a danger we will rename --- the forall'd variable to 'x' by mistake, getting this: --- (forall x. (List b, x, x) --- Urk! This means looking at all the calls to mkOpenTvSubst.... - - --- | Generates the in-scope set for the 'TvSubst' from the types in the incoming --- environment, hence "open" -mkOpenTvSubst :: TvSubstEnv -> TvSubst -mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv - --- | Generates the in-scope set for the 'TvSubst' from the types in the incoming --- environment, hence "open" -zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst -zipOpenTvSubst tyvars tys - | debugIsOn && (length tyvars /= length tys) - = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst - | otherwise - = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) - --- | Called when doing top-level substitutions. Here we expect that the --- free vars of the range of the substitution will be empty. -mkTopTvSubst :: [(TyVar, Type)] -> TvSubst -mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs) - -zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst -zipTopTvSubst tyvars tys - | debugIsOn && (length tyvars /= length tys) - = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst - | otherwise - = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) - -zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv -zipTyEnv tyvars tys - | debugIsOn && (length tyvars /= length tys) - = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv - | otherwise - = zip_ty_env tyvars tys emptyVarEnv - --- Later substitutions in the list over-ride earlier ones, --- but there should be no loops -zip_ty_env :: [TyVar] -> [Type] -> TvSubstEnv -> TvSubstEnv -zip_ty_env [] [] env = env -zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty) - -- There used to be a special case for when - -- ty == TyVarTy tv - -- (a not-uncommon case) in which case the substitution was dropped. - -- But the type-tidier changes the print-name of a type variable without - -- changing the unique, and that led to a bug. Why? Pre-tidying, we had - -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. - -- And it happened that t was the type variable of the class. Post-tiding, - -- it got turned into {Foo t2}. The ext-core printer expanded this using - -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, - -- and so generated a rep type mentioning t not t2. - -- - -- Simplest fix is to nuke the "optimisation" -zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr tvs $$ ppr tys) env --- zip_ty_env _ _ env = env - -instance Outputable TvSubst where - ppr (TvSubst ins tenv) - = brackets $ sep[ ptext (sLit "TvSubst"), - nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ] - -{- -************************************************************************ -* * - Performing type or kind substitutions -* * -************************************************************************ --} - --- | Type substitution making use of an 'TvSubst' that --- is assumed to be open, see 'zipOpenTvSubst' -substTyWith :: [TyVar] -> [Type] -> Type -> Type -substTyWith tvs tys = ASSERT( length tvs == length tys ) - substTy (zipOpenTvSubst tvs tys) - -substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind -substKiWith = substTyWith - --- | Type substitution making use of an 'TvSubst' that --- is assumed to be open, see 'zipOpenTvSubst' -substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] -substTysWith tvs tys = ASSERT( length tvs == length tys ) - substTys (zipOpenTvSubst tvs tys) - -substKisWith :: [KindVar] -> [Kind] -> [Kind] -> [Kind] -substKisWith = substTysWith - --- | Substitute within a 'Type' -substTy :: TvSubst -> Type -> Type -substTy subst ty | isEmptyTvSubst subst = ty - | otherwise = subst_ty subst ty - --- | Substitute within several 'Type's -substTys :: TvSubst -> [Type] -> [Type] -substTys subst tys | isEmptyTvSubst subst = tys - | otherwise = map (subst_ty subst) tys - --- | Substitute within a 'ThetaType' -substTheta :: TvSubst -> ThetaType -> ThetaType -substTheta subst theta - | isEmptyTvSubst subst = theta - | otherwise = map (substTy subst) theta - --- | Remove any nested binders mentioning the 'TyVar's in the 'TyVarSet' -deShadowTy :: TyVarSet -> Type -> Type -deShadowTy tvs ty - = subst_ty (mkTvSubst in_scope emptyTvSubstEnv) ty - where - in_scope = mkInScopeSet tvs - -subst_ty :: TvSubst -> Type -> Type --- subst_ty is the main workhorse for type substitution --- --- Note that the in_scope set is poked only if we hit a forall --- so it may often never be fully computed -subst_ty subst ty - = go ty - where - go (LitTy n) = n `seq` LitTy n - go (TyVarTy tv) = substTyVar subst tv - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- by [Int], represented with TyConApp - go (ForAllTy tv ty) = case substTyVarBndr subst tv of - (subst', tv') -> - ForAllTy tv' $! (subst_ty subst' ty) - -substTyVar :: TvSubst -> TyVar -> Type -substTyVar (TvSubst _ tenv) tv - | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once] - | otherwise = ASSERT( isTyVar tv ) TyVarTy tv -- in TypeRep - -- We do not require that the tyvar is in scope - -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau) - -- and it's a nuisance to bring all the free vars of tau into - -- scope --- and then force that thunk at every tyvar - -- Instead we have an ASSERT in substTyVarBndr to check for capture - -substTyVars :: TvSubst -> [TyVar] -> [Type] -substTyVars subst tvs = map (substTyVar subst) tvs - -lookupTyVar :: TvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TvSubst] in TypeRep -lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv - -substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVarBndr subst@(TvSubst in_scope tenv) old_var - = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) - (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) - where - new_env | no_change = delVarEnv tenv old_var - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - - _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) - -- Assertion check that we are not capturing something in the substitution - - old_ki = tyVarKind old_var - no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) -- verify that kind is closed - no_change = no_kind_change && (new_var == old_var) - -- no_change means that the new_var is identical in - -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TvSubst] in TypeRep - -- - -- In that case we don't need to extend the substitution - -- to map old to new. But instead we must zap any - -- current substitution for the variable. For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - - new_var | no_kind_change = uniqAway in_scope old_var - | otherwise = uniqAway in_scope $ updateTyVarKind (substTy subst) old_var - -- The uniqAway part makes sure the new variable is not already in scope - -cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar) -cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq - = (TvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')), tv') - where - tv' = setVarUnique tv uniq -- Simply set the unique; the kind - -- has no type variables to worry about - -cloneTyVarBndrs :: TvSubst -> [TyVar] -> UniqSupply -> (TvSubst, [TyVar]) -cloneTyVarBndrs subst [] _usupply = (subst, []) -cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) - where - (uniq, usupply') = takeUniqFromSupply usupply - (subst' , tv ) = cloneTyVarBndr subst t uniq - (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' - -{- ----------------------------------------------------- --- Kind Stuff - -Kinds -~~~~~ - -For the description of subkinding in GHC, see - http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeType#Kinds --} - -type MetaKindVar = TyVar -- invariant: MetaKindVar will always be a - -- TcTyVar with details MetaTv (TauTv ...) ... --- meta kind var constructors and functions are in TcType - -type SimpleKind = Kind {- ************************************************************************ @@ -1749,31 +2074,14 @@ type SimpleKind = Kind -} typeKind :: Type -> Kind -typeKind orig_ty = go orig_ty - where - - go ty@(TyConApp tc tys) - | isPromotedTyCon tc - = ASSERT( tyConArity tc == length tys ) superKind - | otherwise - = kindAppResult (ptext (sLit "typeKind 1") <+> ppr ty $$ ppr orig_ty) - (tyConKind tc) tys - - go ty@(AppTy fun arg) = kindAppResult (ptext (sLit "typeKind 2") <+> ppr ty $$ ppr orig_ty) - (go fun) [arg] - go (LitTy l) = typeLiteralKind l - go (ForAllTy _ ty) = go ty - go (TyVarTy tyvar) = tyVarKind tyvar - go _ty@(FunTy _arg res) - -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), - -- not unliftedTypeKind (#) - -- The only things that can be after a function arrow are - -- (a) types (of kind openTypeKind or its sub-kinds) - -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) - | isSuperKind k = k - | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind - where - k = go res +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (AppTy fun arg) = piResultTy (typeKind fun) arg +typeKind (LitTy l) = typeLiteralKind l +typeKind (ForAllTy (Anon _) _) = liftedTypeKind +typeKind (ForAllTy _ ty) = typeKind ty +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = pSnd $ coercionKind co +typeKind (CoercionTy co) = coercionType co typeLiteralKind :: TyLit -> Kind typeLiteralKind l = @@ -1781,28 +2089,127 @@ typeLiteralKind l = NumTyLit _ -> typeNatKind StrTyLit _ -> typeSymbolKind +-- | Print a tyvar with its kind +pprTyVar :: TyVar -> SDoc +pprTyVar tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) + {- -Kind inference -~~~~~~~~~~~~~~ -During kind inference, a kind variable unifies only with -a "simple kind", sk - sk ::= * | sk1 -> sk2 -For example - data T a = MkT a (T Int#) -fails. We give T the kind (k -> *), and the kind variable k won't unify -with # (the kind of Int#). - -Type inference -~~~~~~~~~~~~~~ -When creating a fresh internal type variable, we give it a kind to express -constraints on it. E.g. in (\x->e) we make up a fresh type variable for x, -with kind ??. - -During unification we only bind an internal type variable to a type -whose kind is lower in the sub-kind hierarchy than the kind of the tyvar. - -When unifying two internal type variables, we collect their kind constraints by -finding the GLB of the two. Since the partial order is a tree, they only -have a glb if one is a sub-kind of the other. In that case, we bind the -less-informative one to the more informative one. Neat, eh? +%************************************************************************ +%* * + Miscellaneous functions +%* * +%************************************************************************ + -} +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> NameEnv TyCon +tyConsOfType ty + = go ty + where + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyNameEnv + go (LitTy {}) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys + go (AppTy a b) = go a `plusNameEnv` go b + go (ForAllTy (Anon a) b) = go a `plusNameEnv` go b `plusNameEnv` go_tc funTyCon + go (ForAllTy (Named tv _) ty) = go ty `plusNameEnv` go (tyVarKind tv) + go (CastTy ty co) = go ty `plusNameEnv` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl _ ty) = go ty + go_co (TyConAppCo _ tc args) = go_tc tc `plusNameEnv` go_cos args + go_co (AppCo co arg) = go_co co `plusNameEnv` go_co arg + go_co (ForAllCo _ kind_co co) = go_co kind_co `plusNameEnv` go_co co + go_co (CoVarCo {}) = emptyNameEnv + go_co (AxiomInstCo ax _ args) = go_ax ax `plusNameEnv` go_cos args + go_co (UnivCo p _ t1 t2) = go_prov p `plusNameEnv` go t1 `plusNameEnv` go t2 + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `plusNameEnv` go_co co2 + go_co (NthCo _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `plusNameEnv` go_co arg + go_co (CoherenceCo co1 co2) = go_co co1 `plusNameEnv` go_co co2 + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_prov UnsafeCoerceProv = emptyNameEnv + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyNameEnv + go_prov (HoleProv h) = pprPanic "tyConsOfType hit a hole" (ppr h) + + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys + go_cos cos = foldr (plusNameEnv . go_co) emptyNameEnv cos + + go_tc tc = unitNameEnv (tyConName tc) tc + go_ax ax = go_tc $ coAxiomTyCon ax + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) + +-- | Retrieve the free variables in this type, splitting them based +-- on whether the variable was used in a dependent context. It's possible +-- for a variable to be reported twice, if it's used both dependently +-- and non-dependently. (This isn't the most precise analysis, because +-- it's used in the typechecking knot. It might list some dependent +-- variables as also non-dependent.) +splitDepVarsOfType :: Type -> Pair TyCoVarSet +splitDepVarsOfType = go + where + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) + (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp _ tys) = foldMap go tys + go (ForAllTy (Anon arg) res) = go arg `mappend` go res + go (ForAllTy (Named tv _) ty) + = let Pair kvs tvs = go ty in + Pair (kvs `delVarSet` tv `unionVarSet` tyCoVarsOfType (tyVarKind tv)) + (tvs `delVarSet` tv) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` Pair (tyCoVarsOfCo co) + emptyVarSet + go (CoercionTy co) = go_co co + + go_co co = let Pair ty1 ty2 = coercionKind co in + go ty1 `mappend` go ty2 -- NB: the Pairs separate along different + -- dimensions here. Be careful! + +-- | Like 'splitDepVarsOfType', but over a list of types +splitDepVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitDepVarsOfTypes = foldMap splitDepVarsOfType + +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +splitVisVarsOfType :: Type -> Pair TyCoVarSet +splitVisVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (ForAllTy (Anon t1) t2) = go t1 `mappend` go t2 + go (ForAllTy (Named tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ tyVarKind tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibles tc id tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitVisVarsOfTypes = foldMap splitVisVarsOfType diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index 587454e357..aa12398bd7 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -1,9 +1,16 @@ module Type where -import {-# SOURCE #-} TypeRep( Type, Kind ) -import Var +import TyCon +import {-# SOURCE #-} TyCoRep( Type, Kind ) isPredTy :: Type -> Bool +isCoercionTy :: Type -> Bool + +mkAppTy :: Type -> Type -> Type +piResultTy :: Type -> Type -> Type typeKind :: Type -> Kind -substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind -eqKind :: Kind -> Kind -> Bool +eqType :: Type -> Type -> Bool + +coreViewOneStarKind :: Type -> Maybe Type + +partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs deleted file mode 100644 index f13ca8aa1e..0000000000 --- a/compiler/types/TypeRep.hs +++ /dev/null @@ -1,1020 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1998 - -\section[TypeRep]{Type - friends' interface} - -Note [The Type-related module hierarchy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Class - TyCon imports Class - TypeRep - TysPrim imports TypeRep ( including mkTyConTy ) - Kind imports TysPrim ( mainly for primitive kinds ) - Type imports Kind - Coercion imports Type --} - -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, - DeriveTraversable #-} -{-# OPTIONS_HADDOCK hide #-} --- We expose the relevant stuff from this module via the Type module - -module TypeRep ( - TyThing(..), - Type(..), - TyLit(..), - KindOrType, Kind, SuperKind, - PredType, ThetaType, -- Synonyms - - -- Functions over types - mkTyConTy, mkTyVarTy, mkTyVarTys, - isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar, - - -- Pretty-printing - pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, - pprTyThing, pprTyThingCategory, pprSigmaType, - pprTheta, pprForAll, pprUserForAll, - pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprTyLit, suppressKinds, - TyPrec(..), maybeParen, pprTcApp, - pprPrefixApp, pprArrowChain, ppr_type, - pprDataCons, - - -- Free variables - tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst, - tyVarsOfTypeAcc, tyVarsOfTypeList, tyVarsOfTypesAcc, tyVarsOfTypesList, - tyVarsOfTypeDSet, tyVarsOfTypesDSet, - closeOverKindsDSet, closeOverKindsAcc, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyOpenKind, - tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, - tidyOpenTyVar, tidyOpenTyVars, - tidyTyVarOcc, - tidyTopType, - tidyKind, - - -- Substitutions - TvSubst(..), TvSubstEnv - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConFullSig ) -import {-# SOURCE #-} ConLike ( ConLike(..) ) -import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop - --- friends: -import Var -import VarEnv -import VarSet -import Name -import BasicTypes -import TyCon -import Class -import CoAxiom -import FV - --- others -import PrelNames -import Outputable -import FastString -import ListSetOps -import Util -import DynFlags -import StaticFlags( opt_PprStyle_Debug ) - --- libraries -import Data.List( mapAccumL, partition ) -import qualified Data.Data as Data hiding ( TyCon ) - -{- -************************************************************************ -* * -\subsection{The data type} -* * -************************************************************************ --} - --- | The key representation of types within the compiler - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data Type - = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) - - | AppTy -- See Note [AppTy rep] - Type - Type -- ^ Type application to something other than a 'TyCon'. Parameters: - -- - -- 1) Function: must /not/ be a 'TyConApp', - -- must be another 'AppTy', or 'TyVarTy' - -- - -- 2) Argument type - - | TyConApp -- See Note [AppTy rep] - TyCon - [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. - -- Invariant: saturated applications of 'FunTyCon' must - -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's - -- do appear as 'TyConApp's. - -- Parameters: - -- - -- 1) Type constructor being applied to. - -- - -- 2) Type arguments. Might not have enough type arguments - -- here to saturate the constructor. - -- Even type synonyms are not necessarily saturated; - -- for example unsaturated type synonyms - -- can appear as the right hand side of a type synonym. - - | FunTy - Type - Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ - -- See Note [Equality-constrained types] - - | ForAllTy - Var -- Type or kind variable - Type -- ^ A polymorphic type - - | LitTy TyLit -- ^ Type literals are similar to type constructors. - - deriving (Data.Data, Data.Typeable) - - --- NOTE: Other parts of the code assume that type literals do not contain --- types or type variables. -data TyLit - = NumTyLit Integer - | StrTyLit FastString - deriving (Eq, Ord, Data.Data, Data.Typeable) - -type KindOrType = Type -- See Note [Arguments to type constructors] - --- | The key type representing kinds in the compiler. --- Invariant: a kind is always in one of these forms: --- --- > FunTy k1 k2 --- > TyConApp PrimTyCon [...] --- > TyVar kv -- (during inference only) --- > ForAll ... -- (for top-level coercions) -type Kind = Type - --- | "Super kinds", used to help encode 'Kind's as types. --- Invariant: a super kind is always of this form: --- --- > TyConApp SuperKindTyCon ... -type SuperKind = Type - -{- -Note [The kind invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The kinds - # UnliftedTypeKind - OpenKind super-kind of *, # - -can never appear under an arrow or type constructor in a kind; they -can only be at the top level of a kind. It follows that primitive TyCons, -which have a naughty pseudo-kind - State# :: * -> # -must always be saturated, so that we can never get a type whose kind -has a UnliftedTypeKind or ArgTypeKind underneath an arrow. - -Nor can we abstract over a type variable with any of these kinds. - - k :: = kk | # | ArgKind | (#) | OpenKind - kk :: = * | kk -> kk | T kk1 ... kkn - -So a type variable can only be abstracted kk. - -Note [Arguments to type constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because of kind polymorphism, in addition to type application we now -have kind instantiation. We reuse the same notations to do so. - -For example: - - Just (* -> *) Maybe - Right * Nat Zero - -are represented by: - - TyConApp (PromotedDataCon Just) [* -> *, Maybe] - TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] - -Important note: Nat is used as a *kind* and not as a type. This can be -confusing, since type-level Nat and kind-level Nat are identical. We -use the kind of (PromotedDataCon Right) to know if its arguments are -kinds or types. - -This kind instantiation only happens in TyConApp currently. - - -Note [Equality-constrained types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type forall ab. (a ~ [b]) => blah -is encoded like this: - - ForAllTy (a:*) $ ForAllTy (b:*) $ - FunTy (TyConApp (~) [a, [b]]) $ - blah - -------------------------------------- - Note [PredTy] --} - --- | A type of the form @p@ of kind @Constraint@ represents a value whose type is --- the Haskell predicate @p@, where a predicate is what occurs before --- the @=>@ in a Haskell type. --- --- We use 'PredType' as documentation to mark those types that we guarantee to have --- this kind. --- --- It can be expanded into its representation, but: --- --- * The type checker must treat it as opaque --- --- * The rest of the compiler treats it as transparent --- --- Consider these examples: --- --- > f :: (Eq a) => a -> Int --- > g :: (?x :: Int -> Int) => a -> Int --- > h :: (r\l) => {r} => {l::Int | r} --- --- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -type PredType = Type - --- | A collection of 'PredType's -type ThetaType = [PredType] - -{- -(We don't support TREX records yet, but the setup is designed -to expand to allow them.) - -A Haskell qualified type, such as that for f,g,h above, is -represented using - * a FunTy for the double arrow - * with a type of kind Constraint as the function argument - -The predicate really does turn into a real extra argument to the -function. If the argument has type (p :: Constraint) then the predicate p is -represented by evidence of type p. - -************************************************************************ -* * - Simple constructors -* * -************************************************************************ - -These functions are here so that they can be used by TysPrim, -which in turn is imported by Type --} - -mkTyVarTy :: TyVar -> Type -mkTyVarTy = TyVarTy - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = TyConApp tycon [] - --- Some basic functions, put here to break loops eg with the pretty printer - -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey -isLiftedTypeKind _ = False - --- | Is this a super-kind (i.e. a type-of-kinds)? -isSuperKind :: Type -> Bool -isSuperKind (TyConApp skc []) = skc `hasKey` superKindTyConKey -isSuperKind _ = False - -isTypeVar :: Var -> Bool -isTypeVar v = isTKVar v && not (isSuperKind (varType v)) - -isKindVar :: Var -> Bool -isKindVar v = isTKVar v && isSuperKind (varType v) - -{- -************************************************************************ -* * - Free variables of types and coercions -* * -************************************************************************ --} - --- | Returns free variables of a type, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfType :: Type -> VarSet -tyVarsOfType ty = runFVSet $ tyVarsOfTypeAcc ty - --- | `tyVarsOfType` that returns free variables of a type in deterministic --- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyVarsOfTypeList :: Type -> [TyVar] -tyVarsOfTypeList ty = runFVList $ tyVarsOfTypeAcc ty - --- | `tyVarsOfType` that returns free variables of a type in a deterministic --- set. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in FV. -tyVarsOfTypeDSet :: Type -> DTyVarSet -tyVarsOfTypeDSet ty = runFVDSet $ tyVarsOfTypeAcc ty - --- | Returns free variables of types, including kind variables as --- a non-deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfTypes :: [Type] -> TyVarSet -tyVarsOfTypes tys = runFVSet $ tyVarsOfTypesAcc tys - --- | Returns free variables of types, including kind variables as --- a deterministically ordered list. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfTypesList :: [Type] -> [TyVar] -tyVarsOfTypesList tys = runFVList $ tyVarsOfTypesAcc tys - --- | Returns free variables of types, including kind variables as --- a deterministic set. For type synonyms it does /not/ expand the --- synonym. -tyVarsOfTypesDSet :: [Type] -> DTyVarSet -tyVarsOfTypesDSet tys = runFVDSet $ tyVarsOfTypesAcc tys - - --- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`. --- The previous implementation used `unionVarSet` which is O(n+m) and can --- make the function quadratic. --- It's exported, so that it can be composed with other functions that compute --- free variables. --- See Note [FV naming conventions] in FV. -tyVarsOfTypeAcc :: Type -> FV -tyVarsOfTypeAcc (TyVarTy v) fv_cand in_scope acc = oneVar v fv_cand in_scope acc -tyVarsOfTypeAcc (TyConApp _ tys) fv_cand in_scope acc = - tyVarsOfTypesAcc tys fv_cand in_scope acc -tyVarsOfTypeAcc (LitTy {}) fv_cand in_scope acc = noVars fv_cand in_scope acc -tyVarsOfTypeAcc (FunTy arg res) fv_cand in_scope acc = - (tyVarsOfTypeAcc arg `unionFV` tyVarsOfTypeAcc res) fv_cand in_scope acc -tyVarsOfTypeAcc (AppTy fun arg) fv_cand in_scope acc = - (tyVarsOfTypeAcc fun `unionFV` tyVarsOfTypeAcc arg) fv_cand in_scope acc -tyVarsOfTypeAcc (ForAllTy tyvar ty) fv_cand in_scope acc = - (delFV tyvar (tyVarsOfTypeAcc ty) `unionFV` - tyVarsOfTypeAcc (tyVarKind tyvar)) fv_cand in_scope acc - -tyVarsOfTypesAcc :: [Type] -> FV -tyVarsOfTypesAcc (ty:tys) fv_cand in_scope acc = - (tyVarsOfTypeAcc ty `unionFV` tyVarsOfTypesAcc tys) fv_cand in_scope acc -tyVarsOfTypesAcc [] fv_cand in_scope acc = noVars fv_cand in_scope acc - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a non-deterministic set. -closeOverKinds :: TyVarSet -> TyVarSet -closeOverKinds = runFVSet . closeOverKindsAcc . varSetElems - --- | Given a list of tyvars returns a deterministic FV computation that --- returns the given tyvars with the kind variables free in the kinds of the --- given tyvars. -closeOverKindsAcc :: [TyVar] -> FV -closeOverKindsAcc tvs = - mapUnionFV (tyVarsOfTypeAcc . tyVarKind) tvs `unionFV` someVars tvs - --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministic set. -closeOverKindsDSet :: DTyVarSet -> DTyVarSet -closeOverKindsDSet = runFVDSet . closeOverKindsAcc . dVarSetElems - -varSetElemsKvsFirst :: VarSet -> [TyVar] --- {k1,a,k2,b} --> [k1,k2,a,b] -varSetElemsKvsFirst set - = kvs ++ tvs - where - (kvs, tvs) = partition isKindVar (varSetElems set) - -{- -************************************************************************ -* * - TyThing -* * -************************************************************************ - -Despite the fact that DataCon has to be imported via a hi-boot route, -this module seems the right place for TyThing, because it's needed for -funTyCon and all the types in TysPrim. - -Note [ATyCon for classes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Both classes and type constructors are represented in the type environment -as ATyCon. You can tell the difference, and get to the class, with - isClassTyCon :: TyCon -> Bool - tyConClass_maybe :: TyCon -> Maybe Class -The Class and its associated TyCon have the same Name. --} - --- | A global typecheckable-thing, essentially anything that has a name. --- Not to be confused with a 'TcTyThing', which is also a typecheckable --- thing but in the *local* context. See 'TcEnv' for how to retrieve --- a 'TyThing' given a 'Name'. -data TyThing - = AnId Id - | AConLike ConLike - | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] - | ACoAxiom (CoAxiom Branched) - deriving (Eq, Ord) - -instance Outputable TyThing where - ppr = pprTyThing - -pprTyThing :: TyThing -> SDoc -pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) - -pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory (ATyCon tc) - | isClassTyCon tc = ptext (sLit "Class") - | otherwise = ptext (sLit "Type constructor") -pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") -pprTyThingCategory (AnId _) = ptext (sLit "Identifier") -pprTyThingCategory (AConLike (RealDataCon _)) = ptext (sLit "Data constructor") -pprTyThingCategory (AConLike (PatSynCon _)) = ptext (sLit "Pattern synonym") - - -instance NamedThing TyThing where -- Can't put this with the type - getName (AnId id) = getName id -- decl, because the DataCon instance - getName (ATyCon tc) = getName tc -- isn't visible there - getName (ACoAxiom cc) = getName cc - getName (AConLike cl) = getName cl - -{- -************************************************************************ -* * - Substitutions - Data type defined here to avoid unnecessary mutual recursion -* * -************************************************************************ --} - --- | Type substitution --- --- #tvsubst_invariant# --- The following invariants must hold of a 'TvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TvSubst - = TvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - -- See Note [Apply Once] - -- and Note [Extending the TvSubstEnv] - --- | A substitution of 'Type's for 'TyVar's --- and 'Kind's for 'KindVar's -type TvSubstEnv = TyVarEnv Type - -- A TvSubstEnv is used both inside a TvSubst (with the apply-once - -- invariant discussed in Note [Apply Once]), and also independently - -- in the middle of matching, and unification (see Types.Unify) - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever - -{- -Note [Apply Once] -~~~~~~~~~~~~~~~~~ -We use TvSubsts to instantiate things, and we might instantiate - forall a b. ty -\with the types - [a, b], or [b, a]. -So the substitution might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substitution that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - *************************************************** - *** So a TvSubst must be applied precisely once *** - *************************************************** - -A TvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the TvSubstEnv is empty: -if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- -then (substTy subst ty) does nothing. - -For example, consider: - (/\a. /\b:(a~Int). ...b..) Int -We substitute Int for 'a'. The Unique of 'b' does not change, but -nevertheless we add 'b' to the TvSubstEnv, because b's kind does change - -This invariant has several crucial consequences: - -* In substTyVarBndr, we need extend the TvSubstEnv - - if the unique has changed - - or if the kind has changed - -* In substTyVar, we do not need to consult the in-scope set; - the TvSubstEnv is enough - -* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty - - - -************************************************************************ -* * - Pretty-printing types - - Defined very early because of debug printing in assertions -* * -************************************************************************ - -@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is -defined to use this. @pprParendType@ is the same, except it puts -parens around the type, except for the atomic cases. @pprParendType@ -works just by setting the initial context precedence very high. - -Note [Precedence in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't keep the fixity of type operators in the operator. So the pretty printer -operates the following precedene structre: - Type constructor application binds more tightly than - Oerator applications which bind more tightly than - Function arrow - -So we might see a :+: T b -> c -meaning (a :+: (T b)) -> c - -Maybe operator applications should bind a bit less tightly? - -Anyway, that's the current story, and it is used consistently for Type and HsType --} - -data TyPrec -- See Note [Prededence in types] - - = TopPrec -- No parens - | FunPrec -- Function args; no parens for tycon apps - | TyOpPrec -- Infix operator - | TyConPrec -- Tycon args; no parens for atomic - deriving( Eq, Ord ) - -maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - ------------------- -pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_type TopPrec ty -pprParendType ty = ppr_type TyConPrec ty - -pprTyLit :: TyLit -> SDoc -pprTyLit = ppr_tylit TopPrec - -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - ------------- -pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = pprTypeApp (classTyCon clas) tys - ------------- -pprTheta :: ThetaType -> SDoc -pprTheta [pred] = ppr_type TopPrec pred -- I'm in two minds about this -pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) - -pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy [] = empty -pprThetaArrowTy [pred] = ppr_type TyOpPrec pred <+> darrow - -- TyOpPrec: Num a => a -> a does not need parens - -- bug (a :~: b) => a -> b currently does - -- Trac # 9658 -pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) - <+> darrow - -- Notice 'fsep' here rather that 'sep', so that - -- type contexts don't get displayed in a giant column - -- Rather than - -- instance (Eq a, - -- Eq b, - -- Eq c, - -- Eq d, - -- Eq e, - -- Eq f, - -- Eq g, - -- Eq h, - -- Eq i, - -- Eq j, - -- Eq k, - -- Eq l) => - -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) - -- we get - -- - -- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, - -- Eq j, Eq k, Eq l) => - -- Eq (a, b, c, d, e, f, g, h, i, j, k, l) - ------------------- -instance Outputable Type where - ppr ty = pprType ty - -instance Outputable TyLit where - ppr = pprTyLit - ------------------- - -- OK, here's the main printer - -ppr_type :: TyPrec -> Type -> SDoc -ppr_type _ (TyVarTy tv) = ppr_tvar tv -ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys -ppr_type p (LitTy l) = ppr_tylit p l -ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty - -ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ - ppr_type FunPrec t1 <+> ppr_type TyConPrec t2 - -ppr_type p fun_ty@(FunTy ty1 ty2) - | isPredTy ty1 - = ppr_forall_type p fun_ty - | otherwise - = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2) - where - -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - ppr_fun_tail (FunTy ty1 ty2) - | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 - ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] - - -ppr_forall_type :: TyPrec -> Type -> SDoc -ppr_forall_type p ty - = maybeParen p FunPrec $ ppr_sigma_type True ty - -- True <=> we always print the foralls on *nested* quantifiers - -- Opt_PrintExplicitForalls only affects top-level quantifiers - -- False <=> we don't print an extra-constraints wildcard - -ppr_tvar :: TyVar -> SDoc -ppr_tvar tv -- Note [Infix type variables] - = parenSymOcc (getOccName tv) (ppr tv) - -ppr_tylit :: TyPrec -> TyLit -> SDoc -ppr_tylit _ tl = - case tl of - NumTyLit n -> integer n - StrTyLit s -> text (show s) - -------------------- -ppr_sigma_type :: Bool -> Type -> SDoc --- First Bool <=> Show the foralls unconditionally --- Second Bool <=> Show an extra-constraints wildcard -ppr_sigma_type show_foralls_unconditionally ty - = sep [ if show_foralls_unconditionally - then pprForAll tvs - else pprUserForAll tvs - , pprThetaArrowTy ctxt - , pprType tau ] - where - (tvs, rho) = split1 [] ty - (ctxt, tau) = split2 [] rho - - split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) - - split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 - split2 ps ty = (reverse ps, ty) - -pprSigmaType :: Type -> SDoc -pprSigmaType ty = ppr_sigma_type False ty - -pprUserForAll :: [TyVar] -> SDoc --- Print a user-level forall; see Note [When to print foralls] -pprUserForAll tvs - = sdocWithDynFlags $ \dflags -> - ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ - pprForAll tvs - where - tv_has_kind_var tv = not (isEmptyVarSet (tyVarsOfType (tyVarKind tv))) - -pprForAll :: [TyVar] -> SDoc -pprForAll [] = empty -pprForAll tvs = forAllLit <+> pprTvBndrs tvs <> dot - -pprTvBndrs :: [TyVar] -> SDoc -pprTvBndrs tvs = sep (map pprTvBndr tvs) - -pprTvBndr :: TyVar -> SDoc -pprTvBndr tv - | isLiftedTypeKind kind = ppr_tvar tv - | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) - where - kind = tyVarKind tv - -{- -Note [When to print foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Mostly we want to print top-level foralls when (and only when) the user specifies --fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses -too much information; see Trac #9018. - -So I'm trying out this rule: print explicit foralls if - a) User specifies -fprint-explicit-foralls, or - b) Any of the quantified type variables has a kind - that mentions a kind variable - -This catches common situations, such as a type siguature - f :: m a -which means - f :: forall k. forall (m :: k->*) (a :: k). m a -We really want to see both the "forall k" and the kind signatures -on m and a. The latter comes from pprTvBndr. - -Note [Infix type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With TypeOperators you can say - - f :: (a ~> b) -> b - -and the (~>) is considered a type variable. However, the type -pretty-printer in this module will just see (a ~> b) as - - App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") - -So it'll print the type in prefix form. To avoid confusion we must -remember to parenthesise the operator, thus - - (~>) a b -> b - -See Trac #2766. --} - -pprDataCons :: TyCon -> SDoc -pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons - where - sepWithVBars [] = empty - sepWithVBars docs = sep (punctuate (space <> vbar) docs) - -pprDataConWithArgs :: DataCon -> SDoc -pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc - forAllDoc = pprUserForAll ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) - thetaDoc = pprThetaArrowTy theta - argsDoc = hsep (fmap pprParendType arg_tys) - -pprTypeApp :: TyCon -> [Type] -> SDoc -pprTypeApp tc tys = pprTyTcApp TopPrec tc tys - -- We have to use ppr on the TyCon (not its name) - -- so that we get promotion quotes in the right place - -pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc --- Used for types only; so that we can make a --- special case for type-level lists -pprTyTcApp p tc tys - | tc `hasKey` ipTyConKey - , [LitTy (StrTyLit n),ty] <- tys - = maybeParen p FunPrec $ - char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty - - | tc `hasKey` consDataConKey - , [_kind,ty1,ty2] <- tys - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitKinds dflags then pprTcApp p ppr_type tc tys - else pprTyList p ty1 ty2 - - | not opt_PprStyle_Debug - , tc `hasKey` errorMessageTypeErrorFamKey - = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see it - - | otherwise - = pprTcApp p ppr_type tc tys - -pprTcApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc --- Used for both types and coercions, hence polymorphism -pprTcApp _ pp tc [ty] - | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) - | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) - - -pprTcApp p pp tc tys - | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = pprTupleApp p pp tc sort tys - - | Just dc <- isPromotedDataCon_maybe tc - , let dc_tc = dataConTyCon dc - , Just tup_sort <- tyConTuple_maybe dc_tc - , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 - ty_args = drop arity tys -- Drop the kind args - , ty_args `lengthIs` arity -- Result is saturated - = pprPromotionQuote tc <> - (tupleParens tup_sort $ pprWithCommas (pp TopPrec) ty_args) - - | otherwise - = sdocWithDynFlags (pprTcApp_help p pp tc tys) - -pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> TupleSort -> [a] -> SDoc --- Print a saturated tuple -pprTupleApp p pp tc sort tys - | null tys - , ConstraintTuple <- sort - = if opt_PprStyle_Debug then ptext (sLit "(%%)") - else maybeParen p FunPrec $ - ptext (sLit "() :: Constraint") - | otherwise - = pprPromotionQuote tc <> - tupleParens sort (pprWithCommas (pp TopPrec) tys) - -pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc --- This one has accss to the DynFlags -pprTcApp_help p pp tc tys dflags - | not (isSymOcc (nameOccName (tyConName tc))) - = pprPrefixApp p (ppr tc) (map (pp TyConPrec) tys_wo_kinds) - - | [ty1,ty2] <- tys_wo_kinds -- Infix, two arguments; - -- we know nothing of precedence though - = pprInfixApp p pp (ppr tc) ty1 ty2 - - | tc `hasKey` liftedTypeKindTyConKey - || tc `hasKey` unliftedTypeKindTyConKey - = ASSERT( null tys ) ppr tc -- Do not wrap *, # in parens - - | otherwise - = pprPrefixApp p (parens (ppr tc)) (map (pp TyConPrec) tys_wo_kinds) - where - tys_wo_kinds = suppressKinds dflags (tyConKind tc) tys - ------------------- -suppressKinds :: DynFlags -> Kind -> [a] -> [a] --- Given the kind of a TyCon, and the args to which it is applied, --- suppress the args that are kind args --- C.f. Note [Suppressing kinds] in IfaceType -suppressKinds dflags kind xs - | gopt Opt_PrintExplicitKinds dflags = xs - | otherwise = suppress kind xs - where - suppress (ForAllTy _ kind) (_ : xs) = suppress kind xs - suppress (FunTy _ res) (x:xs) = x : suppress res xs - suppress _ xs = xs - ----------------- -pprTyList :: TyPrec -> Type -> Type -> SDoc --- Given a type-level list (t1 ': t2), see if we can print --- it in list notation [t1, ...]. -pprTyList p ty1 ty2 - = case gather ty2 of - (arg_tys, Nothing) -> char '\'' <> brackets (fsep (punctuate comma - (map (ppr_type TopPrec) (ty1:arg_tys)))) - (arg_tys, Just tl) -> maybeParen p FunPrec $ - hang (ppr_type FunPrec ty1) - 2 (fsep [ colon <+> ppr_type FunPrec ty | ty <- arg_tys ++ [tl]]) - where - gather :: Type -> ([Type], Maybe Type) - -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] - -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl - gather (TyConApp tc tys) - | tc `hasKey` consDataConKey - , [_kind, ty1,ty2] <- tys - , (args, tl) <- gather ty2 - = (ty1:args, tl) - | tc `hasKey` nilDataConKey - = ([], Nothing) - gather ty = ([], Just ty) - ----------------- -pprInfixApp :: TyPrec -> (TyPrec -> a -> SDoc) -> SDoc -> a -> a -> SDoc -pprInfixApp p pp pp_tc ty1 ty2 - = maybeParen p TyOpPrec $ - sep [pp TyOpPrec ty1, pprInfixVar True pp_tc <+> pp TyOpPrec ty2] - -pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc -pprPrefixApp p pp_fun pp_tys - | null pp_tys = pp_fun - | otherwise = maybeParen p TyConPrec $ - hang pp_fun 2 (sep pp_tys) - ----------------- -pprArrowChain :: TyPrec -> [SDoc] -> SDoc --- pprArrowChain p [a,b,c] generates a -> b -> c -pprArrowChain _ [] = empty -pprArrowChain p (arg:args) = maybeParen p FunPrec $ - sep [arg, sep (map (arrow <+>) args)] - -{- -************************************************************************ -* * -\subsection{TidyType} -* * -************************************************************************ - -Tidying is here because it has a special case for FlatSkol --} - --- | This tidies up a type for printing in an error message, or in --- an interface file. --- --- It doesn't change the uniques at all, just the print names. -tidyTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyTyVarBndrs env tvs = mapAccumL tidyTyVarBndr env tvs - -tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr tidy_env@(occ_env, subst) tyvar - = case tidyOccName occ_env occ1 of - (tidy', occ') -> ((tidy', subst'), tyvar') - where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarKind (setTyVarName tyvar name') kind' - name' = tidyNameOcc name occ' - kind' = tidyKind tidy_env (tyVarKind tyvar) - where - name = tyVarName tyvar - occ = getOccName name - -- System Names are for unification variables; - -- when we tidy them we give them a trailing "0" (or 1 etc) - -- so that they don't take precedence for the un-modified name - -- Plus, indicating a unification variable in this way is a - -- helpful clue for users - occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0") - | otherwise = occ - - ---------------- -tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv --- ^ Add the free 'TyVar's to the env in tidy form, --- so that we can tidy the type they are free in -tidyFreeTyVars (full_occ_env, var_env) tyvars - = fst (tidyOpenTyVars (full_occ_env, var_env) (varSetElems tyvars)) - - --------------- -tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars - ---------------- -tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) --- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name --- using the environment if one has not already been allocated. See --- also 'tidyTyVarBndr' -tidyOpenTyVar env@(_, subst) tyvar - = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder - ---------------- -tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar -tidyTyVarOcc (_, subst) tv - = case lookupVarEnv subst tv of - Nothing -> tv - Just tv' -> tv' - ---------------- -tidyTypes :: TidyEnv -> [Type] -> [Type] -tidyTypes env tys = map (tidyType env) tys - ---------------- -tidyType :: TidyEnv -> Type -> Type -tidyType _ (LitTy n) = LitTy n -tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) -tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys - in args `seqList` TyConApp tycon args -tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) - where - (envp, tvp) = tidyTyVarBndr env tv - ---------------- --- | Grabs the free type variables, tidies them --- and then uses 'tidyType' to work over the type itself -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty - = (env', tidyType (trimmed_occ_env, var_env) ty) - where - (env'@(_, var_env), tvs') = tidyOpenTyVars env (tyVarsOfTypeList ty) - trimmed_occ_env = initTidyOccEnv (map getOccName tvs') - -- The idea here was that we restrict the new TidyEnv to the - -- _free_ vars of the type, so that we don't gratuitously rename - -- the _bound_ variables of the type. - ---------------- -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys = mapAccumL tidyOpenType env tys - ---------------- --- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) -tidyTopType :: Type -> Type -tidyTopType ty = tidyType emptyTidyEnv ty - ---------------- -tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyOpenKind = tidyOpenType - -tidyKind :: TidyEnv -> Kind -> Kind -tidyKind = tidyType diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index 78e4936ab7..0c2469a9ed 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -1,23 +1,23 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} module Unify ( - -- Matching of types: - -- the "tc" prefix indicates that matching always - -- respects newtypes (rather than looking through them) - tcMatchTy, tcUnifyTyWithTFs, tcMatchTys, tcMatchTyX, tcMatchTysX, - ruleMatchTyX, tcMatchPreds, - - MatchEnv(..), matchList, + tcMatchTy, tcMatchTys, tcMatchTyX, tcMatchTysX, tcUnifyTyWithTFs, + ruleMatchTyX, typesCantMatch, -- Side-effect free unification - tcUnifyTy, tcUnifyTys, BindFlag(..), - - UnifyResultM(..), UnifyResult, tcUnifyTysFG + tcUnifyTy, tcUnifyTys, + tcUnifyTysFG, + BindFlag(..), + UnifyResult, UnifyResultM(..), + -- Matching a type against a lifted type (coercion) + liftCoMatch ) where #include "HsVersions.h" @@ -26,30 +26,27 @@ import Var import VarEnv import VarSet import Kind -import Type +import Type hiding ( getTvSubstEnv ) +import Coercion hiding ( getCvSubstEnv ) import TyCon -import TypeRep -import Util ( filterByList ) +import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv ) +import Util +import Pair import Outputable -import FastString (sLit) -import Control.Monad (liftM, foldM, ap) +import Control.Monad #if __GLASGOW_HASKELL__ > 710 import qualified Control.Monad.Fail as MonadFail #endif #if __GLASGOW_HASKELL__ < 709 -import Control.Applicative (Applicative(..)) +import Data.Traversable ( traverse ) #endif +import Control.Applicative hiding ( empty ) +import qualified Control.Applicative {- -************************************************************************ -* * - Matching -* * -************************************************************************ - -Matching is much tricker than you might think. +Unification is much tricker than you might think. 1. The substitution we generate binds the *template type variables* which are given to us explicitly. @@ -69,191 +66,93 @@ Matching is much tricker than you might think. where x is the template type variable. Then we do not want to bind x to a/b! This is a kind of occurs check. The necessary locals accumulate in the RnEnv2. --} -data MatchEnv - = ME { me_tmpls :: VarSet -- Template variables - , me_env :: RnEnv2 -- Renaming envt for nested foralls - } -- In-scope set includes template variables - -- Nota Bene: MatchEnv isn't specific to Types. It is used - -- for matching terms and coercions as well as types - -tcMatchTy :: TyVarSet -- Template tyvars - -> Type -- Template - -> Type -- Target - -> Maybe TvSubst -- One-shot; in principle the template - -- variables could be free in the target -tcMatchTy tmpls ty1 ty2 - = tcMatchTyX tmpls init_subst ty1 ty2 - where - init_subst = mkTvSubst in_scope emptyTvSubstEnv - in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfType ty2) - -- We're assuming that all the interesting - -- tyvars in ty1 are in tmpls +Note [Kind coercions in Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to match/unify while ignoring casts. But, we can't just ignore +them completely, or we'll end up with ill-kinded substitutions. For example, +say we're matching `a` with `ty |> co`. If we just drop the cast, we'll +return [a |-> ty], but `a` and `ty` might have different kinds. We can't +just match/unify their kinds, either, because this might gratuitously +fail. After all, `co` is the witness that the kinds are the same -- they +may look nothing alike. + +So, we pass a kind coercion to the match/unify worker. This coercion witnesses +the equality between the substed kind of the left-hand type and the substed +kind of the right-hand type. To get this coercion, we first have to match/unify +the kinds before looking at the types. Happily, we need look only one level +up, as all kinds are guaranteed to have kind *. + +We thought, at one point, that this was all unnecessary: why should casts +be in types in the first place? But they do. In +dependent/should_compile/KindEqualities2, we see, for example +the constraint Num (Int |> (blah ; sym blah)). +We naturally want to find a dictionary for that constraint, which +requires dealing with coercions in this manner. + +-} -tcMatchTys :: TyVarSet -- Template tyvars - -> [Type] -- Template - -> [Type] -- Target - -> Maybe TvSubst -- One-shot; in principle the template - -- variables could be free in the target +-- | @tcMatchTy tys t1 t2@ produces a substitution (over a subset of +-- the variables @tys@) @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might +-- bind coercion variables, if the variable is an argument to a GADT +-- constructor. +tcMatchTy :: TyCoVarSet -> Type -> Type -> Maybe TCvSubst +tcMatchTy tmpls ty1 ty2 = tcMatchTys tmpls [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +tcMatchTyX :: TyCoVarSet -- ^ Template tyvars + -> TCvSubst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TCvSubst +tcMatchTyX tmpls subst ty1 ty2 = tcMatchTysX tmpls subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +tcMatchTys :: TyCoVarSet -- ^ Template tyvars + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot; in principle the template + -- variables could be free in the target tcMatchTys tmpls tys1 tys2 - = tcMatchTysX tmpls init_subst tys1 tys2 - where - init_subst = mkTvSubst in_scope emptyTvSubstEnv - in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfTypes tys2) - -tcMatchTyX :: TyVarSet -- Template tyvars - -> TvSubst -- Substitution to extend - -> Type -- Template - -> Type -- Target - -> Maybe TvSubst -tcMatchTyX tmpls (TvSubst in_scope subst_env) ty1 ty2 - = case match menv subst_env ty1 ty2 of - Just subst_env' -> Just (TvSubst in_scope subst_env') - Nothing -> Nothing - where - menv = ME {me_tmpls = tmpls, me_env = mkRnEnv2 in_scope} - -tcMatchTysX :: TyVarSet -- Template tyvars - -> TvSubst -- Substitution to extend - -> [Type] -- Template - -> [Type] -- Target - -> Maybe TvSubst -- One-shot; in principle the template - -- variables could be free in the target -tcMatchTysX tmpls (TvSubst in_scope subst_env) tys1 tys2 - = case match_tys menv subst_env tys1 tys2 of - Just subst_env' -> Just (TvSubst in_scope subst_env') - Nothing -> Nothing - where - menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } - -tcMatchPreds - :: [TyVar] -- Bind these - -> [PredType] -> [PredType] - -> Maybe TvSubstEnv -tcMatchPreds tmpls ps1 ps2 - = matchList (match menv) emptyTvSubstEnv ps1 ps2 - where - menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars } - in_scope_tyvars = mkInScopeSet (tyVarsOfTypes ps1 `unionVarSet` tyVarsOfTypes ps2) - --- This one is called from the expression matcher, which already has a MatchEnv in hand -ruleMatchTyX :: MatchEnv - -> TvSubstEnv -- Substitution to extend - -> Type -- Template - -> Type -- Target - -> Maybe TvSubstEnv - -ruleMatchTyX menv subst ty1 ty2 = match menv subst ty1 ty2 -- Rename for export - --- Now the internals of matching - --- | Workhorse matching function. Our goal is to find a substitution --- on all of the template variables (specified by @me_tmpls menv@) such --- that @ty1@ and @ty2@ unify. This substitution is accumulated in @subst@. --- If a variable is not a template variable, we don't attempt to find a --- substitution for it; it must match exactly on both sides. Furthermore, --- only @ty1@ can have template variables. --- --- This function handles binders, see 'RnEnv2' for more details on --- how that works. -match :: MatchEnv -- For the most part this is pushed downwards - -> TvSubstEnv -- Substitution so far: - -- Domain is subset of template tyvars - -- Free vars of range is subset of - -- in-scope set of the RnEnv2 - -> Type -> Type -- Template and target respectively - -> Maybe TvSubstEnv - -match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2 - | Just ty2' <- coreView ty2 = match menv subst ty1 ty2' - -match menv subst (TyVarTy tv1) ty2 - | Just ty1' <- lookupVarEnv subst tv1' -- tv1' is already bound - = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2 - -- ty1 has no locally-bound variables, hence nukeRnEnvL - then Just subst - else Nothing -- ty2 doesn't match - - | tv1' `elemVarSet` me_tmpls menv - = if any (inRnEnvR rn_env) (tyVarsOfTypeList ty2) - then Nothing -- Occurs check - -- ezyang: Is this really an occurs check? It seems - -- to just reject matching \x. A against \x. x (maintaining - -- the invariant that the free vars of the range of @subst@ - -- are a subset of the in-scope set in @me_env menv@.) - else do { subst1 <- match_kind menv subst (tyVarKind tv1) (typeKind ty2) - -- Note [Matching kinds] - ; return (extendVarEnv subst1 tv1' ty2) } - - | otherwise -- tv1 is not a template tyvar - = case ty2 of - TyVarTy tv2 | tv1' == rnOccR rn_env tv2 -> Just subst - _ -> Nothing + = tcMatchTysX tmpls (mkEmptyTCvSubst in_scope) tys1 tys2 where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - -match menv subst (ForAllTy tv1 ty1) (ForAllTy tv2 ty2) - = do { subst' <- match_kind menv subst (tyVarKind tv1) (tyVarKind tv2) - ; match menv' subst' ty1 ty2 } - where -- Use the magic of rnBndr2 to go under the binders - menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } - -match menv subst (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 = match_tys menv subst tys1 tys2 -match menv subst (FunTy ty1a ty1b) (FunTy ty2a ty2b) - = do { subst' <- match menv subst ty1a ty2a - ; match menv subst' ty1b ty2b } -match menv subst (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 - -- 'repSplit' used because the coreView stuff is done above - = do { subst' <- match menv subst ty1a ty2a - ; match menv subst' ty1b ty2b } - -match _ subst (LitTy x) (LitTy y) | x == y = return subst - -match _ _ _ _ - = Nothing - - - --------------- -match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv --- Match the kind of the template tyvar with the kind of Type --- Note [Matching kinds] -match_kind menv subst k1 k2 - | k2 `isSubKind` k1 - = return subst - - | otherwise - = match menv subst k1 k2 - --- Note [Matching kinds] --- ~~~~~~~~~~~~~~~~~~~~~ --- For ordinary type variables, we don't want (m a) to match (n b) --- if say (a::*) and (b::*->*). This is just a yes/no issue. --- --- For coercion kinds matters are more complicated. If we have a --- coercion template variable co::a~[b], where a,b are presumably also --- template type variables, then we must match co's kind against the --- kind of the actual argument, so as to give bindings to a,b. --- --- In fact I have no example in mind that *requires* this kind-matching --- to instantiate template type variables, but it seems like the right --- thing to do. C.f. Note [Matching variable types] in Rules.hs - --------------- -match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv -match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2 - --------------- -matchList :: (env -> a -> b -> Maybe env) - -> env -> [a] -> [b] -> Maybe env -matchList _ subst [] [] = Just subst -matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b - ; matchList fn subst' as bs } -matchList _ _ _ _ = Nothing + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfTypes tys2) + -- We're assuming that all the interesting + -- tyvars in tys1 are in tmpls + +-- | Like 'tcMatchTys', but extending a substitution +tcMatchTysX :: TyCoVarSet -- ^ Template tyvars + -> TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTysX tmpls (TCvSubst in_scope tv_env cv_env) tys1 tys2 +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpls) False False + (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of + Unifiable (tv_env', cv_env') + -> Just $ TCvSubst in_scope tv_env' cv_env' + _ -> Nothing + +-- | This one is called from the expression matcher, +-- which already has a MatchEnv in hand +ruleMatchTyX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpl_tvs) False False rn_env + tenv emptyCvSubstEnv [tmpl] [target] of + Unifiable (tenv', _) -> Just tenv' + _ -> Nothing + +matchBindFun :: TyCoVarSet -> TyVar -> BindFlag +matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem {- ************************************************************************ @@ -296,7 +195,7 @@ suffices. -- apart, even after arbitrary type function evaluation and substitution? typesCantMatch :: [(Type,Type)] -> Bool -- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (\(s,t) -> cant_match s t) prs +typesCantMatch prs = any (uncurry cant_match) prs where cant_match :: Type -> Type -> Bool cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of @@ -389,83 +288,51 @@ usages won't notice this design choice. -} tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TvSubst -- A regular one-shot (idempotent) substitution + -> Maybe TCvSubst + -- A regular one-shot (idempotent) substitution -- Simple unification of two types; all type variables are bindable -tcUnifyTy ty1 ty2 - = case initUM (const BindMe) (unify ty1 ty2) of - Unifiable subst -> Just subst - _other -> Nothing +tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] -- | Unify two types, treating type family applications as possibly unifying -- with anything and looking through injective type family applications. -tcUnifyTyWithTFs :: Bool -> Type -> Type -> Maybe TvSubst --- This algorithm is a direct implementation of the "Algorithm U" presented in --- the paper "Injective type families for Haskell", Figures 2 and 3. Equation --- numbers in the comments refer to equations from the paper. -tcUnifyTyWithTFs twoWay t1 t2 = niFixTvSubst `fmap` go t1 t2 emptyTvSubstEnv - where - go :: Type -> Type -> TvSubstEnv -> Maybe TvSubstEnv - -- look through type synonyms - go t1 t2 theta | Just t1' <- coreView t1 = go t1' t2 theta - go t1 t2 theta | Just t2' <- coreView t2 = go t1 t2' theta - -- proper unification - go (TyVarTy tv) t2 theta - -- Equation (1) - | Just t1' <- lookupVarEnv theta tv - = go t1' t2 theta - | otherwise = let t2' = Type.substTy (niFixTvSubst theta) t2 - in if tv `elemVarEnv` tyVarsOfType t2' - -- Equation (2) - then Just theta - -- Equation (3) - else Just $ extendVarEnv theta tv t2' - -- Equation (4) - go t1 t2@(TyVarTy _) theta | twoWay = go t2 t1 theta - -- Equation (5) - go (AppTy s1 s2) ty theta | Just(t1, t2) <- splitAppTy_maybe ty = - go s1 t1 theta >>= go s2 t2 - go ty (AppTy s1 s2) theta | Just(t1, t2) <- splitAppTy_maybe ty = - go s1 t1 theta >>= go s2 t2 - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) theta - -- Equation (6) - | isAlgTyCon tc1 && isAlgTyCon tc2 && tc1 == tc2 - = let tys = zip tys1 tys2 - in foldM (\theta' (t1,t2) -> go t1 t2 theta') theta tys - - -- Equation (7) - | isTypeFamilyTyCon tc1 && isTypeFamilyTyCon tc2 && tc1 == tc2 - , Injective inj <- familyTyConInjectivityInfo tc1 - = let tys1' = filterByList inj tys1 - tys2' = filterByList inj tys2 - injTys = zip tys1' tys2' - in foldM (\theta' (t1,t2) -> go t1 t2 theta') theta injTys - - -- Equations (8) - | isTypeFamilyTyCon tc1 - = Just theta - - -- Equations (9) - | isTypeFamilyTyCon tc2, twoWay - = Just theta - - -- Equation (10) - go _ _ _ = Nothing +tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; + -- False <=> do one-way matching. + -- See end of sec 5.2 from the paper + -> Type -> Type -> Maybe TCvSubst +-- This algorithm is an implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. +-- The code is incorporated with the standard unifier for convenience, but +-- its operation should match the specification in the paper. +tcUnifyTyWithTFs twoWay t1 t2 + = case tc_unify_tys (const BindMe) twoWay True + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (subst, _) -> Just $ niFixTCvSubst subst + MaybeApart (subst, _) -> Just $ niFixTCvSubst subst + -- we want to *succeed* in questionable cases. This is a + -- pre-unification algorithm. + SurelyApart -> Nothing + where + rn_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [t1, t2] ----------------- -tcUnifyTys :: (TyVar -> BindFlag) +tcUnifyTys :: (TyCoVar -> BindFlag) -> [Type] -> [Type] - -> Maybe TvSubst -- A regular one-shot (idempotent) substitution + -> Maybe TCvSubst + -- ^ A regular one-shot (idempotent) substitution + -- that unifies the erased types. See comments + -- for 'tcUnifyTysFG' + -- The two types may have common type variables, and indeed do so in the -- second call to tcUnifyTys in FunDeps.checkClsFD tcUnifyTys bind_fn tys1 tys2 = case tcUnifyTysFG bind_fn tys1 tys2 of - Unifiable subst -> Just subst - _ -> Nothing + Unifiable result -> Just result + _ -> Nothing -- This type does double-duty. It is used in the UM (unifier monad) and to -- return the final result. See Note [Fine-grained unification] -type UnifyResult = UnifyResultM TvSubst +type UnifyResult = UnifyResultM TCvSubst data UnifyResultM a = Unifiable a -- the subst that unifies the types | MaybeApart a -- the subst has as much as we know -- it must be part of an most general unifier @@ -473,17 +340,71 @@ data UnifyResultM a = Unifiable a -- the subst that unifies the types | SurelyApart deriving Functor --- See Note [Fine-grained unification] +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + return = pure + + SurelyApart >>= _ = SurelyApart + MaybeApart x >>= f = case f x of + Unifiable y -> MaybeApart y + other -> other + Unifiable x >>= f = f x + +instance Alternative UnifyResultM where + empty = SurelyApart + + a@(Unifiable {}) <|> _ = a + _ <|> b@(Unifiable {}) = b + a@(MaybeApart {}) <|> _ = a + _ <|> b@(MaybeApart {}) = b + SurelyApart <|> SurelyApart = SurelyApart + +instance MonadPlus UnifyResultM where + mzero = Control.Applicative.empty + mplus = (<|>) + +-- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose +-- domain elements all respond 'BindMe' to @bind_tv@) such that +-- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned +-- Coercions. tcUnifyTysFG :: (TyVar -> BindFlag) -> [Type] -> [Type] -> UnifyResult tcUnifyTysFG bind_fn tys1 tys2 - = initUM bind_fn (unify_tys tys1 tys2) + = do { (env, _) <- tc_unify_tys bind_fn True False env + emptyTvSubstEnv emptyCvSubstEnv + tys1 tys2 + ; return $ niFixTCvSubst env } + where + vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + env = mkRnEnv2 $ mkInScopeSet vars + +-- | This function is actually the one to call the unifier -- a little +-- too general for outside clients, though. +tc_unify_tys :: (TyVar -> BindFlag) + -> Bool -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +tc_unify_tys bind_fn unif inj_check rn_env tv_env cv_env tys1 tys2 + = initUM bind_fn unif inj_check rn_env tv_env cv_env $ + do { unify_tys kis1 kis2 + ; unify_tys tys1 tys2 + ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } + where + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 instance Outputable a => Outputable (UnifyResultM a) where - ppr SurelyApart = ptext (sLit "SurelyApart") - ppr (Unifiable x) = ptext (sLit "Unifiable") <+> ppr x - ppr (MaybeApart x) = ptext (sLit "MaybeApart") <+> ppr x + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart x) = text "MaybeApart" <+> ppr x {- ************************************************************************ @@ -494,7 +415,7 @@ instance Outputable a => Outputable (UnifyResultM a) where Note [Non-idempotent substitution] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During unification we use a TvSubstEnv that is +During unification we use a TvSubstEnv/CvSubstEnv pair that is (a) non-idempotent (b) loop-free; ie repeatedly applying it yields a fixed point @@ -520,41 +441,48 @@ This is the reason for extending env with [f:k -> f:*], in the definition of env' in niFixTvSubst -} -niFixTvSubst :: TvSubstEnv -> TvSubst +niFixTCvSubst :: TvSubstEnv -> TCvSubst -- Find the idempotent fixed point of the non-idempotent substitution -- See Note [Finding the substitution fixpoint] -- ToDo: use laziness instead of iteration? -niFixTvSubst env = f env +niFixTCvSubst tenv = f tenv where - f env | not_fixpoint = f (mapVarEnv (substTy subst') env) - | otherwise = subst + f tenv + | not_fixpoint = f (mapVarEnv (substTy subst') tenv) + | otherwise = subst where - not_fixpoint = foldVarSet ((||) . in_domain) False all_range_tvs - in_domain tv = tv `elemVarEnv` env + not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs + in_domain tv = tv `elemVarEnv` tenv - range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet env - all_range_tvs = closeOverKinds range_tvs - subst = mkTvSubst (mkInScopeSet all_range_tvs) env + range_tvs = foldVarEnv (unionVarSet . tyCoVarsOfType) emptyVarSet tenv + subst = mkTCvSubst (mkInScopeSet range_tvs) + (tenv, emptyCvSubstEnv) -- env' extends env by replacing any free type with -- that same tyvar with a substituted kind -- See note [Finding the substitution fixpoint] - env' = extendVarEnvList env [ (rtv, mkTyVarTy $ setTyVarKind rtv $ - substTy subst $ tyVarKind rtv) - | rtv <- varSetElems range_tvs - , not (in_domain rtv) ] - subst' = mkTvSubst (mkInScopeSet all_range_tvs) env' - -niSubstTvSet :: TvSubstEnv -> TyVarSet -> TyVarSet + tenv' = extendVarEnvList tenv [ (rtv, mkTyVarTy $ + setTyVarKind rtv $ + substTy subst $ + tyVarKind rtv) + | rtv <- varSetElems range_tvs + , not (in_domain rtv) ] + subst' = mkTCvSubst (mkInScopeSet range_tvs) + (tenv', emptyCvSubstEnv) + +niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet -- Apply the non-idempotent substitution to a set of type variables, -- remembering that the substitution isn't necessarily idempotent -- This is used in the occurs check, before extending the substitution -niSubstTvSet subst tvs +niSubstTvSet tsubst tvs = foldVarSet (unionVarSet . get) emptyVarSet tvs where - get tv = case lookupVarEnv subst tv of - Nothing -> unitVarSet tv - Just ty -> niSubstTvSet subst (tyVarsOfType ty) + get tv + | Just ty <- lookupVarEnv tsubst tv + = niSubstTvSet tsubst (tyCoVarsOfType ty) + + | otherwise + = unitVarSet tv {- ************************************************************************ @@ -562,25 +490,184 @@ niSubstTvSet subst tvs The workhorse * * ************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The algorithm implemented here is rather delicate, and we depend on it +to uphold certain properties. This is a summary of these required +properties. Any reference to "flattening" refers to the flattening +algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not +the flattening algorithm in the solver. + +Notation: + θ,φ substitutions + ξ type-function-free types + τ,σ other types + τ♭ type τ, flattened + + ≡ eqType + +(U1) Soundness. +If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). θ is a most general +unifier for τ₁ and τ₂. + +(U2) Completeness. +If (unify ξ₁ ξ₂) = SurelyApart, +then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). + +These two properties are stated as Property 11 in the "Closed Type Families" +paper (POPL'14). Below, this paper is called [CTF]. + +(U3) Apartness under substitution. +If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, for +any θ. (Property 12 from [CTF]) + +(U4) Apart types do not unify. +If (unify ξ τ♭) = SurelyApart, then there exists no θ such that +θ(ξ) = θ(τ). (Property 13 from [CTF]) + +THEOREM. Completeness w.r.t ~ +If (unify τ₁♭ τ₂♭) = SurelyApart, then there exists no proof that (τ₁ ~ τ₂). + +PROOF. See appendix of [CTF]. + + +The unification algorithm is used for type family injectivity, as described +in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run +in this mode, it has the following properties. + +(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even +after arbitrary type family reductions. Note that σ and τ are not flattened +here. + +(I2) If (unify σ τ) = MaybeApart θ, and if some +φ exists such that φ(σ) ~ φ(τ), then φ extends θ. + + +Furthermore, the RULES matching algorithm requires this property, +but only when using this algorithm for matching: + +(M1) If (match σ τ) succeeds with θ, then all matchable tyvars in σ +are bound in θ. + +Property M1 means that we must extend the substitution with, say +(a ↦ a) when appropriate during matching. +See also Note [Self-substitution when matching]. + +(M2) Completeness of matching. +If θ(σ) = τ, then (match σ τ) = Unifiable φ, where θ is an extension of φ. + +Sadly, property M2 and I2 conflict. Consider + +type family F1 a b where + F1 Int Bool = Char + F1 Double String = Char + +Consider now two matching problems: + +P1. match (F1 a Bool) (F1 Int Bool) +P2. match (F1 a Bool) (F1 Double String) + +In case P1, we must find (a ↦ Int) to satisfy M2. +In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note +that the correct mapping for I2 is (a ↦ Int). There is no way to discover +this, but we musn't map a to anything else!) + +We thus must parameterize the algorithm over whether it's being used +for an injectivity check (refrain from looking at non-injective arguments +to type families) or not (do indeed look at those arguments). + +(It's all a question of whether or not to include equation (7) from Fig. 2 +of [ITF].) + +This extra parameter is a bit fiddly, perhaps, but seemingly less so than +having two separate, almost-identical algorithms. + +Note [Self-substitution when matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should happen when we're *matching* (not unifying) a1 with a1? We +should get a substitution [a1 |-> a1]. A successful match should map all +the template variables (except ones that disappear when expanding synonyms). +But when unifying, we don't want to do this, because we'll then fall into +a loop. + +This arrangement affects the code in three places: + - If we're matching a refined template variable, don't recur. Instead, just + check for equality. That is, if we know [a |-> Maybe a] and are matching + (a ~? Maybe Int), we want to just fail. + + - Skip the occurs check when matching. This comes up in two places, because + matching against variables is handled separately from matching against + full-on types. + +Note that this arrangement was provoked by a real failure, where the same +unique ended up in the template as in the target. (It was a rule firing when +compiling Data.List.NonEmpty.) + +Note [Matching coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + +We would like that to be accepted. For that to work, we need to introduce +a coercion variable on the left an then use it on the right. Accordingly, +at use sites of Foo, we need to be able to use matching to figure out the +value for the coercion. (See the desugared version: + + axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) + +) We never want this action to happen during *unification* though, when +all bets are off. + -} -unify :: Type -> Type -> UM () +-- See Note [Specification of unification] +unify_ty :: Type -> Type -> Coercion -- Types to be unified and a co + -- between their kinds + -- See Note [Kind coercions in Unify] + -> UM () -- Respects newtypes, PredTypes --- in unify, any NewTcApps/Preds should be taken at face value -unify (TyVarTy tv1) ty2 = uVar tv1 ty2 -unify ty1 (TyVarTy tv2) = uVar tv2 ty1 +unify_ty ty1 ty2 kco + | Just ty1' <- coreView ty1 = unify_ty ty1' ty2 kco + | Just ty2' <- coreView ty2 = unify_ty ty1 ty2' kco + | CastTy ty1' co <- ty1 = unify_ty ty1' ty2 (co `mkTransCo` kco) + | CastTy ty2' co <- ty2 = unify_ty ty1 ty2' (kco `mkTransCo` mkSymCo co) -unify ty1 ty2 | Just ty1' <- coreView ty1 = unify ty1' ty2 -unify ty1 ty2 | Just ty2' <- coreView ty2 = unify ty1 ty2' +unify_ty (TyVarTy tv1) ty2 kco = uVar tv1 ty2 kco +unify_ty ty1 (TyVarTy tv2) kco + = do { unif <- amIUnifying + ; if unif + then umSwapRn $ uVar tv2 ty1 (mkSymCo kco) + else surelyApart } -- non-tv on left; tv on right: can't match. -unify ty1 ty2 +unify_ty ty1 ty2 _kco | Just (tc1, tys1) <- splitTyConApp_maybe ty1 , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - = if tc1 == tc2 + = if tc1 == tc2 || (isStarKind ty1 && isStarKind ty2) then if isInjectiveTyCon tc1 Nominal then unify_tys tys1 tys2 - else don'tBeSoSure $ unify_tys tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case familyTyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs + | otherwise + = repeat False + + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 + + ; unify_tys inj_tys1 inj_tys2 + ; inj_tf <- checkingInjectivity + ; unless inj_tf $ -- See (end of) Note [Specification of unification] + don'tBeSoSure $ unify_tys noninj_tys1 noninj_tys2 } else -- tc1 /= tc2 if isGenerativeTyCon tc1 Nominal && isGenerativeTyCon tc2 Nominal then surelyApart @@ -588,109 +675,168 @@ unify ty1 ty2 -- Applications need a bit of care! -- They can match FunTy and TyConApp, so use splitAppTy_maybe - -- NB: we've already dealt with type variables and Notes, + -- NB: we've already dealt with type variables, -- so if one type is an App the other one jolly well better be too -unify (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 - = do { unify ty1a ty2a - ; unify ty1b ty2b } - -unify ty1 (AppTy ty2a ty2b) - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 - = do { unify ty1a ty2a - ; unify ty1b ty2b } - -unify (LitTy x) (LitTy y) | x == y = return () - -unify _ _ = surelyApart - -- ForAlls?? +unify_ty (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = unify_ty_app ty1a ty1b ty2a ty2b + +unify_ty ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + = unify_ty_app ty1a ty1b ty2a ty2b + +unify_ty (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty (ForAllTy (Named tv1 _) ty1) (ForAllTy (Named tv2 _) ty2) kco + = do { unify_ty (tyVarKind tv1) (tyVarKind tv2) (mkNomReflCo liftedTypeKind) + ; umRnBndr2 tv1 tv2 $ unify_ty ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty (CoercionTy co1) (CoercionTy co2) kco + = do { unif <- amIUnifying + ; c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not unif + , not (cv `elemVarEnv` c_subst) + -> do { b <- tvBindFlagL cv + ; if b == BindMe + then do { checkRnEnvRCo co2 + ; let [_, _, co_l, co_r] = decomposeCo 4 kco + -- cv :: t1 ~ t2 + -- co2 :: s1 ~ s2 + -- co_l :: t1 ~ s1 + -- co_r :: t2 ~ s2 + ; extendCvEnv cv (co_l `mkTransCo` + co2 `mkTransCo` + mkSymCo co_r) } + else return () } + _ -> return () } + +unify_ty ty1 _ _ + | Just (tc1, _) <- splitTyConApp_maybe ty1 + , not (isGenerativeTyCon tc1 Nominal) + = maybeApart + +unify_ty _ ty2 _ + | Just (tc2, _) <- splitTyConApp_maybe ty2 + , not (isGenerativeTyCon tc2 Nominal) + = do { unif <- amIUnifying + ; if unif then maybeApart else surelyApart } + +unify_ty _ _ _ = surelyApart + +unify_ty_app :: Type -> Type -> Type -> Type -> UM () +unify_ty_app ty1a ty1b ty2a ty2b + = do { -- TODO (RAE): Remove this exponential behavior. + let ki1a = typeKind ty1a + ki2a = typeKind ty2a + ; unify_ty ki1a ki2a (mkNomReflCo liftedTypeKind) + ; let kind_co = mkNomReflCo ki1a + ; unify_ty ty1a ty2a kind_co + ; unify_ty ty1b ty2b (mkNthCo 0 kind_co) } ------------------------------- unify_tys :: [Type] -> [Type] -> UM () unify_tys orig_xs orig_ys = go orig_xs orig_ys where go [] [] = return () - go (x:xs) (y:ys) = do { unify x y - ; go xs ys } + go (x:xs) (y:ys) + = do { unify_ty x y (mkNomReflCo $ typeKind x) + ; go xs ys } go _ _ = maybeApart -- See Note [Lists of different lengths are MaybeApart] --------------------------------- -uVar :: TyVar -- Type variable to be unified - -> Type -- with this type +uVar :: TyVar -- Variable to be unified + -> Type -- with this Type + -> Coercion -- :: kind tv ~N kind ty -> UM () -uVar tv1 ty - = do { subst <- umGetTvSubstEnv - -- Check to see whether tv1 is refined by the substitution +uVar tv1 ty kco + = do { -- Check to see whether tv1 is refined by the substitution + subst <- getTvSubstEnv ; case (lookupVarEnv subst tv1) of - Just ty' -> unify ty' ty -- Yes, call back into unify' - Nothing -> uUnrefined subst tv1 ty ty } -- No, continue - -uUnrefined :: TvSubstEnv -- environment to extend (from the UM monad) - -> TyVar -- Type variable to be unified - -> Type -- with this type - -> Type -- (version w/ expanded synonyms) + Just ty' -> do { unif <- amIUnifying + ; if unif + then unify_ty ty' ty kco -- Yes, call back into unify + else -- when *matching*, we don't want to just recur here. + -- this is because the range of the subst is the target + -- type, not the template type. So, just check for + -- normal type equality. + guard (ty' `eqType` ty) } + Nothing -> uUnrefined tv1 ty ty kco } -- No, continue + +uUnrefined :: TyVar -- variable to be unified + -> Type -- with this Type + -> Type -- (version w/ expanded synonyms) + -> Coercion -- :: kind tv ~N kind ty -> UM () -- We know that tv1 isn't refined -uUnrefined subst tv1 ty2 ty2' +uUnrefined tv1 ty2 ty2' kco | Just ty2'' <- coreView ty2' - = uUnrefined subst tv1 ty2 ty2'' -- Unwrap synonyms + = uUnrefined tv1 ty2 ty2'' kco -- Unwrap synonyms -- This is essential, in case we have -- type Foo a = a -- and then unify a ~ Foo a -uUnrefined subst tv1 ty2 (TyVarTy tv2) - | tv1 == tv2 -- Same type variable - = return () - - -- Check to see whether tv2 is refined - | Just ty' <- lookupVarEnv subst tv2 - = uUnrefined subst tv1 ty' ty' - - | otherwise - - = do { -- So both are unrefined; unify the kinds - ; unify (tyVarKind tv1) (tyVarKind tv2) + | TyVarTy tv2 <- ty2' + = do { tv1' <- umRnOccL tv1 + ; tv2' <- umRnOccR tv2 + ; unif <- amIUnifying + -- See Note [Self-substitution when matching] + ; when (tv1' /= tv2' || not unif) $ do + { subst <- getTvSubstEnv + -- Check to see whether tv2 is refined + ; case lookupVarEnv subst tv2 of + { Just ty' | unif -> uUnrefined tv1 ty' ty' kco + ; _ -> do + { -- So both are unrefined -- And then bind one or the other, -- depending on which is bindable - -- NB: unlike TcUnify we do not have an elaborate sub-kinding - -- story. That is relevant only during type inference, and - -- (I very much hope) is not relevant here. - ; b1 <- tvBindFlag tv1 - ; b2 <- tvBindFlag tv2 - ; let ty1 = TyVarTy tv1 + ; b1 <- tvBindFlagL tv1 + ; b2 <- tvBindFlagR tv2 + ; let ty1 = mkTyVarTy tv1 ; case (b1, b2) of - (Skolem, Skolem) -> maybeApart -- See Note [Unification with skolems] - (BindMe, _) -> extendSubst tv1 ty2 - (_, BindMe) -> extendSubst tv2 ty1 } - -uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable - | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2') - = maybeApart -- Occurs check - -- See Note [Fine-grained unification] - | otherwise - = do { unify k1 k2 - -- Note [Kinds Containing Only Literals] - ; bindTv tv1 ty2 } -- Bind tyvar to the synonym if poss - where - k1 = tyVarKind tv1 - k2 = typeKind ty2' + (BindMe, _) -> do { checkRnEnvR ty2 -- make sure ty2 is not a local + ; extendTvEnv tv1 (ty2 `mkCastTy` mkSymCo kco) } + (_, BindMe) | unif -> do { checkRnEnvL ty1 -- ditto for ty1 + ; extendTvEnv tv2 (ty1 `mkCastTy` kco) } + + _ | tv1' == tv2' -> return () + -- How could this happen? If we're only matching and if + -- we're comparing forall-bound variables. + + _ -> maybeApart -- See Note [Unification with skolems] + }}}} + +uUnrefined tv1 ty2 ty2' kco -- ty2 is not a type variable + = do { occurs <- elemNiSubstSet tv1 (tyCoVarsOfType ty2') + ; unif <- amIUnifying + ; if unif && occurs -- See Note [Self-substitution when matching] + then maybeApart -- Occurs check, see Note [Fine-grained unification] + else do bindTv tv1 (ty2 `mkCastTy` mkSymCo kco) } + -- Bind tyvar to the synonym if poss + +elemNiSubstSet :: TyVar -> TyCoVarSet -> UM Bool +elemNiSubstSet v set + = do { tsubst <- getTvSubstEnv + ; return $ v `elemVarSet` niSubstTvSet tsubst set } bindTv :: TyVar -> Type -> UM () -bindTv tv ty -- ty is not a type variable - = do { b <- tvBindFlag tv +bindTv tv ty -- ty is not a variable + = do { checkRnEnvR ty -- make sure ty mentions no local variables + ; b <- tvBindFlagL tv ; case b of Skolem -> maybeApart -- See Note [Unification with skolems] - BindMe -> extendSubst tv ty + BindMe -> extendTvEnv tv ty } {- -************************************************************************ -* * +%************************************************************************ +%* * Binding decisions * * ************************************************************************ @@ -701,6 +847,7 @@ data BindFlag | Skolem -- This type variable is a skolem constant -- Don't bind it; it only matches itself + deriving Eq {- ************************************************************************ @@ -710,56 +857,336 @@ data BindFlag ************************************************************************ -} -newtype UM a = UM { unUM :: (TyVar -> BindFlag) - -> TvSubstEnv - -> UnifyResultM (a, TvSubstEnv) } +data UMEnv = UMEnv { um_bind_fun :: TyVar -> BindFlag + -- the user-supplied BindFlag function + , um_unif :: Bool -- unification (True) or matching? + , um_inj_tf :: Bool -- checking for injectivity? + -- See (end of) Note [Specification of unification] + , um_rn_env :: RnEnv2 } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv } + +newtype UM a = UM { unUM :: UMEnv -> UMState + -> UnifyResultM (UMState, a) } instance Functor UM where fmap = liftM instance Applicative UM where - pure a = UM (\_tvs subst -> Unifiable (a, subst)) - (<*>) = ap + pure a = UM (\_ s -> pure (s, a)) + (<*>) = ap instance Monad UM where return = pure - fail _ = UM (\_tvs _subst -> SurelyApart) -- failed pattern match - m >>= k = UM (\tvs subst -> case unUM m tvs subst of - Unifiable (v, subst') -> unUM (k v) tvs subst' - MaybeApart (v, subst') -> - case unUM (k v) tvs subst' of - Unifiable (v', subst'') -> MaybeApart (v', subst'') - other -> other - SurelyApart -> SurelyApart) + fail _ = UM (\_ _ -> SurelyApart) -- failed pattern match + m >>= k = UM (\env state -> + do { (state', v) <- unUM m env state + ; unUM (k v) env state' }) + +instance Alternative UM where + empty = UM (\_ _ -> mzero) + m1 <|> m2 = UM (\env state -> + unUM m1 env state <|> + unUM m2 env state) + + -- need this instance because of a use of 'guard' above +instance MonadPlus UM where + mzero = Control.Applicative.empty + mplus = (<|>) #if __GLASGOW_HASKELL__ > 710 instance MonadFail.MonadFail UM where fail _ = UM (\_tvs _subst -> SurelyApart) -- failed pattern match #endif --- returns an idempotent substitution -initUM :: (TyVar -> BindFlag) -> UM () -> UnifyResult -initUM badtvs um = fmap (niFixTvSubst . snd) $ unUM um badtvs emptyTvSubstEnv +initUM :: (TyVar -> BindFlag) + -> Bool -- True <=> unify; False <=> match + -> Bool -- True <=> doing an injectivity check + -> RnEnv2 + -> TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM a -> UnifyResultM a +initUM badtvs unif inj_tf rn_env subst_env cv_subst_env um + = case unUM um env state of + Unifiable (_, subst) -> Unifiable subst + MaybeApart (_, subst) -> MaybeApart subst + SurelyApart -> SurelyApart + where + env = UMEnv { um_bind_fun = badtvs + , um_unif = unif + , um_inj_tf = inj_tf + , um_rn_env = rn_env } + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env } + +tvBindFlagL :: TyVar -> UM BindFlag +tvBindFlagL tv = UM $ \env state -> + Unifiable (state, if inRnEnvL (um_rn_env env) tv + then Skolem + else um_bind_fun env tv) + +tvBindFlagR :: TyVar -> UM BindFlag +tvBindFlagR tv = UM $ \env state -> + Unifiable (state, if inRnEnvR (um_rn_env env) tv + then Skolem + else um_bind_fun env tv) + +getTvSubstEnv :: UM TvSubstEnv +getTvSubstEnv = UM $ \_ state -> Unifiable (state, um_tv_env state) + +getCvSubstEnv :: UM CvSubstEnv +getCvSubstEnv = UM $ \_ state -> Unifiable (state, um_cv_env state) + +extendTvEnv :: TyVar -> Type -> UM () +extendTvEnv tv ty = UM $ \_ state -> + Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) + +extendCvEnv :: CoVar -> Coercion -> UM () +extendCvEnv cv co = UM $ \_ state -> + Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) + +umRnBndr2 :: TyCoVar -> TyCoVar -> UM a -> UM a +umRnBndr2 v1 v2 thing = UM $ \env state -> + let rn_env' = rnBndr2 (um_rn_env env) v1 v2 in + unUM thing (env { um_rn_env = rn_env' }) state + +checkRnEnv :: (RnEnv2 -> Var -> Bool) -> VarSet -> UM () +checkRnEnv inRnEnv varset = UM $ \env state -> + if any (inRnEnv (um_rn_env env)) (varSetElems varset) + then MaybeApart (state, ()) + else Unifiable (state, ()) + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: UM () -> UM () +don'tBeSoSure um = UM $ \env state -> + case unUM um env state of + SurelyApart -> MaybeApart (state, ()) + other -> other -tvBindFlag :: TyVar -> UM BindFlag -tvBindFlag tv = UM (\tv_fn subst -> Unifiable (tv_fn tv, subst)) +checkRnEnvR :: Type -> UM () +checkRnEnvR ty = checkRnEnv inRnEnvR (tyCoVarsOfType ty) --- | Extend the TvSubstEnv in the UM monad -extendSubst :: TyVar -> Type -> UM () -extendSubst tv ty = UM (\_tv_fn subst -> Unifiable ((), extendVarEnv subst tv ty)) +checkRnEnvL :: Type -> UM () +checkRnEnvL ty = checkRnEnv inRnEnvL (tyCoVarsOfType ty) --- | Retrive the TvSubstEnv from the UM monad -umGetTvSubstEnv :: UM TvSubstEnv -umGetTvSubstEnv = UM $ \_tv_fn subst -> Unifiable (subst, subst) +checkRnEnvRCo :: Coercion -> UM () +checkRnEnvRCo co = checkRnEnv inRnEnvR (tyCoVarsOfCo co) --- | Converts any SurelyApart to a MaybeApart -don'tBeSoSure :: UM () -> UM () -don'tBeSoSure um = UM $ \tv_fn subst -> case unUM um tv_fn subst of - SurelyApart -> MaybeApart ((), subst) - other -> other +umRnOccL :: TyVar -> UM TyVar +umRnOccL v = UM $ \env state -> + Unifiable (state, rnOccL (um_rn_env env) v) + +umRnOccR :: TyVar -> UM TyVar +umRnOccR v = UM $ \env state -> + Unifiable (state, rnOccR (um_rn_env env) v) + +umSwapRn :: UM a -> UM a +umSwapRn thing = UM $ \env state -> + let rn_env' = rnSwap (um_rn_env env) in + unUM thing (env { um_rn_env = rn_env' }) state + +amIUnifying :: UM Bool +amIUnifying = UM $ \env state -> Unifiable (state, um_unif env) + +checkingInjectivity :: UM Bool +checkingInjectivity = UM $ \env state -> Unifiable (state, um_inj_tf env) maybeApart :: UM () -maybeApart = UM (\_tv_fn subst -> MaybeApart ((), subst)) +maybeApart = UM (\_ state -> MaybeApart (state, ())) surelyApart :: UM a -surelyApart = UM (\_tv_fn _subst -> SurelyApart) +surelyApart = UM (\_ _ -> SurelyApart) + +{- +%************************************************************************ +%* * + Matching a (lifted) type against a coercion +%* * +%************************************************************************ + +This section defines essentially an inverse to liftCoSubst. It is defined +here to avoid a dependency from Coercion on this module. + +-} + +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 +-- 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 +-- used to produce the given coercion from the given type. +-- Note that this function is incomplete -- it might return Nothing +-- when there does indeed exist a possible lifting context. +-- +-- This function is incomplete in that it doesn't respect the equality +-- in `eqType`. That is, it's possible that this will succeed for t1 and +-- fail for t2, even when t1 `eqType` t2. That's because it depends on +-- there being a very similar structure between the type and the coercion. +-- This incompleteness shouldn't be all that surprising, especially because +-- it depends on the structure of the coercion, which is a silly thing to do. +-- +-- The lifting context produced doesn't have to be exacting in the roles +-- of the mappings. This is because any use of the lifting context will +-- also require a desired role. Thus, this algorithm prefers mapping to +-- nominal coercions where it can do so. +liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext +liftCoMatch tmpls ty co + = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co + ; cenv2 <- ty_co_match menv cenv1 ty co + (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) + ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + + ki = typeKind ty + ki_co = promoteCoercion co + ki_ki_co = mkNomReflCo liftedTypeKind + + Pair co_lkind co_rkind = coercionKind ki_co + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -- ^ ambient helpful info + -> LiftCoEnv -- ^ incoming subst + -> Type -- ^ ty, type to match + -> Coercion -- ^ co, coercion to match against + -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co + -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co + -> Maybe LiftCoEnv +ty_co_match menv subst ty co lkco rkco + | Just ty' <- coreViewOneStarKind ty = ty_co_match menv subst ty' co lkco rkco + + -- handle Refl case: + | tyCoVarsOfType ty `isNotInDomainOf` subst + , Just (ty', _) <- isReflCo_maybe co + , ty `eqType` ty' + = Just subst + + where + isNotInDomainOf :: VarSet -> VarEnv a -> Bool + isNotInDomainOf set env + = noneSet (\v -> elemVarEnv v env) set + + noneSet :: (Var -> Bool) -> VarSet -> Bool + noneSet f = foldVarSet (\v rest -> rest && (not $ f v)) True + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + = ty_co_match menv subst ty' co (co' `mkTransCo` lkco) (co' `mkTransCo` rkco) + + | CoherenceCo co1 co2 <- co + = ty_co_match menv subst ty co1 (lkco `mkTransCo` mkSymCo co2) rkco + + | SymCo co' <- co + = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst (TyVarTy tv1) co lkco rkco + | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 + = if eqCoercionX (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) + then Nothing -- occurs check failed + else Just $ extendVarEnv subst tv1' $ + castCoercionKind co (mkSymCo lkco) (mkSymCo rkco) + + | otherwise + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + + -- just look through SubCo's. We don't really care about roles here. +ty_co_match menv subst ty (SubCo co) lkco rkco + = ty_co_match menv subst ty co lkco rkco + +ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco + | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = ty_co_match_app menv subst ty1a ty1b co2 arg2 +ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + -- yes, the one from Type, not TcType; this is for coercion optimization + = ty_co_match_app menv subst ty1a ty1b co2 arg2 + +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 (ForAllTy (Anon ty1) ty2) (TyConAppCo _ tc cos) _lkco _rkco + = ty_co_match_tc menv subst funTyCon [ty1, ty2] tc cos + +ty_co_match menv subst (ForAllTy (Named tv1 _) ty1) + (ForAllCo tv2 kind_co2 co2) + lkco rkco + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 + ki_ki_co ki_ki_co + ; let rn_env0 = me_env menv + rn_env1 = rnBndr2 rn_env0 tv1 tv2 + menv' = menv { me_env = rn_env1 } + ; ty_co_match menv' subst1 ty1 co2 lkco rkco } + where + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +ty_co_match menv subst ty co lkco rkco + | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco + | otherwise = Nothing + +ty_co_match_tc :: MatchEnv -> LiftCoEnv + -> TyCon -> [Type] + -> TyCon -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_tc menv subst tc1 tys1 tc2 cos2 + = do { guard (tc1 == tc2) + ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } + where + Pair lkcos rkcos + = traverse (fmap mkNomReflCo . coercionKind) cos2 + +ty_co_match_app :: MatchEnv -> LiftCoEnv + -> Type -> Type -> Coercion -> Coercion + -> Maybe LiftCoEnv +ty_co_match_app menv subst ty1a ty1b co2a co2b + = do { -- TODO (RAE): Remove this exponential behavior. + subst1 <- ty_co_match menv subst ki1a ki2a ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2a + ; subst2 <- ty_co_match menv subst1 ty1a co2a lkco rkco + ; ty_co_match menv subst2 ty1b co2b (mkNthCo 0 lkco) (mkNthCo 0 rkco) } + where + ki1a = typeKind ty1a + ki2a = promoteCoercion co2a + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] + -> [Coercion] -> [Coercion] -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_args _ subst [] [] _ _ = Just subst +ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) + = do { subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args lkcos rkcos } +ty_co_match_args _ _ _ _ _ _ = Nothing + +pushRefl :: Coercion -> Maybe Coercion +pushRefl (Refl Nominal (AppTy ty1 ty2)) + = Just (AppCo (Refl Nominal ty1) (mkNomReflCo ty2)) +pushRefl (Refl r (ForAllTy (Anon ty1) ty2)) + = Just (TyConAppCo r funTyCon [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 (Named tv _) ty)) + = Just (mkHomoForAllCos_NoRefl [tv] (Refl r ty)) + -- NB: NoRefl variant. Otherwise, we get a loop! +pushRefl (Refl r (CastTy ty co)) = Just (castCoercionKind (Refl r ty) co co) +pushRefl _ = Nothing diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs index 4a826fbf4a..d85465081b 100644 --- a/compiler/utils/Bag.hs +++ b/compiler/utils/Bag.hs @@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, CPP #-} module Bag ( Bag, -- abstract type diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs index 54faa4f600..207a00cfc1 100644 --- a/compiler/utils/ListSetOps.hs +++ b/compiler/utils/ListSetOps.hs @@ -30,22 +30,9 @@ import Util import Data.List -{- ---------- -#ifndef DEBUG -getNth :: [a] -> Int -> a -getNth xs n = xs !! n -#else -getNth :: Outputable a => [a] -> Int -> a -getNth xs n = ASSERT2( xs `lengthAtLeast` n, ppr n $$ ppr xs ) - xs !! n -#endif ----------- --} - getNth :: Outputable a => [a] -> Int -> a getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) - xs !! n + xs !! n {- ************************************************************************ diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 255a0f50f6..36eb574e78 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -11,8 +11,8 @@ module MonadUtils , liftIO1, liftIO2, liftIO3, liftIO4 - , zipWith3M, zipWith3M_, zipWithAndUnzipM - , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M + , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM , mapSndM , concatMapM @@ -76,6 +76,19 @@ zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () zipWith3M_ f as bs cs = do { _ <- zipWith3M f as bs cs ; return () } +zipWith4M :: Monad m => (a -> b -> c -> d -> m e) + -> [a] -> [b] -> [c] -> [d] -> m [e] +zipWith4M _ [] _ _ _ = return [] +zipWith4M _ _ [] _ _ = return [] +zipWith4M _ _ _ [] _ = return [] +zipWith4M _ _ _ _ [] = return [] +zipWith4M f (x:xs) (y:ys) (z:zs) (a:as) + = do { r <- f x y z a + ; rs <- zipWith4M f xs ys zs as + ; return $ r:rs + } + + zipWithAndUnzipM :: Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) {-# INLINE zipWithAndUnzipM #-} @@ -102,6 +115,13 @@ mapAndUnzip4M f (x:xs) = do (rs1, rs2, rs3, rs4) <- mapAndUnzip4M f xs return (r1:rs1, r2:rs2, r3:rs3, r4:rs4) +mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) +mapAndUnzip5M _ [] = return ([],[],[],[],[]) +mapAndUnzip5M f (x:xs) = do + (r1, r2, r3, r4, r5) <- f x + (rs1, rs2, rs3, rs4, rs5) <- mapAndUnzip5M f xs + return (r1:rs1, r2:rs2, r3:rs3, r4:rs4, r5:rs5) + -- | Monadic version of mapAccumL mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -- ^ combining funcction diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 40acbf1d70..8f30f0076e 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -75,7 +75,7 @@ module Outputable ( -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPgmError, - pprTrace, warnPprTrace, pprSTrace, + pprTrace, pprTraceIt, warnPprTrace, pprSTrace, trace, pgmError, panic, sorry, assertPanic, pprDebugAndThen, ) where @@ -256,6 +256,12 @@ mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug | otherwise = PprUser unqual depth +instance Outputable PprStyle where + ppr (PprUser {}) = text "user-style" + ppr (PprCode {}) = text "code-style" + ppr (PprDump {}) = text "dump-style" + ppr (PprDebug {}) = text "debug-style" + {- Orthogonal to the above printing styles are (possibly) some command-line flags that affect printing (often carried with the @@ -698,6 +704,11 @@ instance Outputable Bool where ppr True = ptext (sLit "True") ppr False = ptext (sLit "False") +instance Outputable Ordering where + ppr LT = text "LT" + ppr EQ = text "EQ" + ppr GT = text "GT" + instance Outputable Int32 where ppr n = integer $ fromIntegral n @@ -1052,6 +1063,10 @@ pprTrace str doc x | opt_NoDebugOutput = x | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x +-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ +pprTraceIt :: Outputable a => String -> a -> a +pprTraceIt desc x = pprTrace desc (ppr x) x + -- | If debug output is on, show some 'SDoc' on the screen along -- with a call stack when available. diff --git a/compiler/utils/Pair.hs b/compiler/utils/Pair.hs index b33ccbac06..8747e619ca 100644 --- a/compiler/utils/Pair.hs +++ b/compiler/utils/Pair.hs @@ -5,7 +5,7 @@ Traversable instances. {-# LANGUAGE CPP #-} -module Pair ( Pair(..), unPair, toPair, swap ) where +module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where #include "HsVersions.h" @@ -37,6 +37,10 @@ instance Foldable Pair where instance Traversable Pair where traverse f (Pair x y) = Pair <$> f x <*> f y +instance Monoid a => Monoid (Pair a) where + mempty = Pair mempty mempty + Pair a1 b1 `mappend` Pair a2 b2 = Pair (a1 `mappend` a2) (b1 `mappend` b2) + instance Outputable a => Outputable (Pair a) where ppr (Pair a b) = ppr a <+> char '~' <+> ppr b @@ -48,3 +52,9 @@ toPair (x,y) = Pair x y swap :: Pair a -> Pair a swap (Pair x y) = Pair y x + +pLiftFst :: (a -> a) -> Pair a -> Pair a +pLiftFst f (Pair a b) = Pair (f a) b + +pLiftSnd :: (a -> a) -> Pair a -> Pair a +pLiftSnd f (Pair a b) = Pair a (f b) diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs index 01fa071cab..41c1cea03f 100644 --- a/compiler/utils/Serialized.hs +++ b/compiler/utils/Serialized.hs @@ -9,10 +9,10 @@ module Serialized ( -- * Main Serialized data type Serialized, seqSerialized, - + -- * Going into and out of 'Serialized' toSerialized, fromSerialized, - + -- * Handy serialization functions serializeWithData, deserializeWithData, ) where diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs index aeb5b34116..e5424f2c5d 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -41,6 +41,7 @@ module UniqDFM ( isNullUDFM, sizeUDFM, intersectUDFM, + intersectsUDFM, disjointUDFM, minusUDFM, partitionUDFM, @@ -228,6 +229,9 @@ intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i -- M.intersection is left biased, that means the result will only have -- a subset of elements from the left set, so `i` is a good upper bound. +intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) + disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs index 85c5126e57..45ed241df1 100644 --- a/compiler/utils/UniqDSet.hs +++ b/compiler/utils/UniqDSet.hs @@ -13,7 +13,7 @@ module UniqDSet ( UniqDSet, -- type synonym for UniqFM a -- ** Manipulating these sets - delOneFromUniqDSet, + delOneFromUniqDSet, delListFromUniqDSet, emptyUniqDSet, unitUniqDSet, mkUniqDSet, @@ -21,6 +21,7 @@ module UniqDSet ( unionUniqDSets, unionManyUniqDSets, minusUniqDSet, intersectUniqDSets, + intersectsUniqDSets, foldUniqDSet, elementOfUniqDSet, filterUniqDSet, @@ -28,8 +29,7 @@ module UniqDSet ( isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, - partitionUniqDSet, - delListFromUniqDSet, + partitionUniqDSet ) where import UniqDFM @@ -55,6 +55,9 @@ addListToUniqDSet = foldl addOneToUniqDSet delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a delOneFromUniqDSet = delFromUDFM +delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +delListFromUniqDSet = delListFromUDFM + unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a unionUniqDSets = plusUDFM @@ -68,6 +71,9 @@ minusUniqDSet = minusUDFM intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a intersectUniqDSets = intersectUDFM +intersectsUniqDSets :: UniqDSet a -> UniqDSet a -> Bool +intersectsUniqDSets = intersectsUDFM + foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b foldUniqDSet = foldUDFM @@ -91,6 +97,3 @@ uniqDSetToList = eltsUDFM partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) partitionUniqDSet = partitionUDFM - -delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a -delListFromUniqDSet = delListFromUDFM diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs index 4ceeec0000..a3d503f6eb 100644 --- a/compiler/utils/UniqSet.hs +++ b/compiler/utils/UniqSet.hs @@ -71,7 +71,7 @@ partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) sizeUniqSet :: UniqSet a -> Int isEmptyUniqSet :: UniqSet a -> Bool -lookupUniqSet :: Uniquable a => UniqSet a -> a -> Maybe a +lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b uniqSetToList :: UniqSet a -> [a] {- diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index d3830c3949..75c0c79ea2 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -14,7 +14,7 @@ module Util ( zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, zipWithAndUnzip, - filterByList, + filterByList, partitionByList, unzipWith, @@ -22,7 +22,7 @@ module Util ( mapAndUnzip, mapAndUnzip3, mapAccumL2, nOfThem, filterOut, partitionWith, splitEithers, - dropWhileEndLE, + dropWhileEndLE, spanEnd, foldl1', foldl2, count, all2, @@ -36,10 +36,11 @@ module Util ( isIn, isn'tIn, -- * Tuples - fstOf3, sndOf3, thirdOf3, + fstOf3, sndOf3, thdOf3, firstM, first3M, - third3, + fst3, snd3, third3, uncurry3, + liftFst, liftSnd, -- * List operations controlled by another list takeList, dropList, splitAtList, split, @@ -215,10 +216,16 @@ nTimes n f = f . nTimes (n-1) f fstOf3 :: (a,b,c) -> a sndOf3 :: (a,b,c) -> b -thirdOf3 :: (a,b,c) -> c +thdOf3 :: (a,b,c) -> c fstOf3 (a,_,_) = a sndOf3 (_,b,_) = b -thirdOf3 (_,_,c) = c +thdOf3 (_,_,c) = c + +fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) +fst3 f (a, b, c) = (f a, b, c) + +snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) +snd3 f (a, b, c) = (a, f b, c) third3 :: (c -> d) -> (a, b, c) -> (a, b, d) third3 f (a, b, c) = (a, b, f c) @@ -226,6 +233,12 @@ third3 f (a, b, c) = (a, b, f c) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c +liftFst :: (a -> b) -> (a, c) -> (b, c) +liftFst f (a,c) = (f a, c) + +liftSnd :: (a -> b) -> (c, a) -> (c, b) +liftSnd f (c,a) = (c, f a) + firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) firstM f (x, y) = liftM (\x' -> (x', y)) (f x) @@ -319,6 +332,19 @@ filterByList (True:bs) (x:xs) = x : filterByList bs xs filterByList (False:bs) (_:xs) = filterByList bs xs filterByList _ _ = [] +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in -- the places where @p@ returns @True@ @@ -601,6 +627,17 @@ dropTail n xs dropWhileEndLE :: (a -> Bool) -> [a] -> [a] dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] +-- | @spanEnd p l == reverse (span p (reverse l))@. The first list +-- returns actually comes after the second list (when you look at the +-- input list). +spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) +spanEnd p l = go l [] [] l + where go yes _rev_yes rev_no [] = (yes, reverse rev_no) + go yes rev_yes rev_no (x:xs) + | p x = go yes (x : rev_yes) rev_no xs + | otherwise = go xs [] (x : rev_yes ++ rev_no) xs + + snocView :: [a] -> Maybe ([a],a) -- Split off the last element snocView [] = Nothing diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 38bd55482a..fa59f0832f 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -62,13 +62,13 @@ vectModule guts@(ModGuts { mg_tcs = tycons , mg_fam_insts = fam_insts , mg_vect_decls = vect_decls }) - = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ + = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ pprCoreBindings binds - + -- Pick out all 'VECTORISE [SCALAR] type' and 'VECTORISE class' pragmas ; let ty_vect_decls = [vd | vd@(VectType _ _ _) <- vect_decls] cls_vect_decls = [vd | vd@(VectClass _) <- vect_decls] - + -- Vectorise the type environment. This will add vectorised -- type constructors, their representaions, and the -- conrresponding data constructors. Moreover, we produce @@ -99,9 +99,9 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- Try to vectorise a top-level binding. If it doesn't vectorise, or if it is entirely scalar, then -- omit vectorisation of that binding. -- --- For example, for the binding +-- For example, for the binding -- --- @ +-- @ -- foo :: Int -> Int -- foo = \x -> x + x -- @ @@ -109,17 +109,17 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- we get -- @ -- foo :: Int -> Int --- foo = \x -> vfoo $: x +-- foo = \x -> vfoo $: x -- -- v_foo :: Closure void vfoo lfoo --- v_foo = closure vfoo lfoo void +-- v_foo = closure vfoo lfoo void -- -- vfoo :: Void -> Int -> Int -- vfoo = ... -- -- lfoo :: PData Void -> PData Int -> PData Int -- lfoo = ... --- @ +-- @ -- -- @vfoo@ is the "vectorised", or scalar, version that does the same as the original function foo, -- but takes an explicit environment. @@ -142,7 +142,7 @@ vectTopBind :: CoreBind -> VM CoreBind vectTopBind b@(NonRec var expr) = do { traceVt "= Vectorise non-recursive top-level variable" (ppr var) - + ; (hasNoVect, vectDecl) <- lookupVectDecl var ; if hasNoVect then do @@ -150,7 +150,7 @@ vectTopBind b@(NonRec var expr) ; traceVt "NOVECTORISE" $ ppr var ; return b } - else do + else do { vectRhs <- case vectDecl of Just (_, expr') -> -- 'VECTORISE' pragma => just use the provided vectorised rhs @@ -166,17 +166,17 @@ vectTopBind b@(NonRec var expr) ; vectTopExpr var expr } ; hs <- takeHoisted -- make sure we clean those out (even if we skip) - ; case vectRhs of + ; case vectRhs of { Nothing -> -- scalar binding => leave this binding as it is - do + do { traceVt "scalar binding [skip]" $ ppr var ; return b } - ; Just (parBind, inline, expr') -> do + ; Just (parBind, inline, expr') -> do { -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map - ; when parBind $ + ; when parBind $ addGlobalParallelVar var ; var' <- vectTopBinder var inline expr' @@ -186,32 +186,32 @@ vectTopBind b@(NonRec var expr) ; return . Rec $ (var, cexpr) : (var', expr') : hs } } } } `orElseErrV` - do + do { emitVt " Could NOT vectorise top-level binding" $ ppr var ; return b } vectTopBind b@(Rec binds) = do { traceVt "= Vectorise recursive top-level variables" $ ppr vars - + ; vectDecls <- mapM lookupVectDecl vars ; let hasNoVects = map fst vectDecls - ; if and hasNoVects + ; if and hasNoVects then do { -- 'NOVECTORISE' pragmas => leave this entire binding group as it is ; traceVt "NOVECTORISE" $ ppr vars ; return b } - else do + else do { if or hasNoVects then do { -- Inconsistent 'NOVECTORISE' pragmas => bail out ; dflags <- getDynFlags ; cantVectorise dflags noVectoriseErr (ppr b) } - else do + else do { traceVt "[Vanilla]" $ vcat [ppr var <+> char '=' <+> ppr expr | (var, expr) <- binds] - + -- For all bindings *with* a pragma, just use the pragma-supplied vectorised expression ; newBindsWPragma <- concat <$> sequence [ vectTopBindAndConvert bind inlineMe expr' @@ -228,7 +228,7 @@ vectTopBind b@(Rec binds) { -- Create appropriate top-level bindings, enter them into the vectorisation map, and -- vectorise the right-hand sides ; newBindsWOPragma <- concat <$> - sequence [vectTopBindAndConvert bind inline expr + sequence [vectTopBindAndConvert bind inline expr | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs'] -- irrefutable pattern and 'zipLazy' to tie the knot; -- hence, can't use 'zipWithM' @@ -239,30 +239,30 @@ vectTopBind b@(Rec binds) Nothing -> -- scalar bindings => skip all bindings except those with pragmas and retract the -- entries into the vectorisation map for the scalar bindings - do + do { traceVt "scalar bindings [skip]" $ ppr vars ; mapM_ (undefGlobalVar . fst) bindsWOPragma ; return (bindsWOPragma ++ newBindsWPragma, exprs') } - Just (parBind, exprs') -> + Just (parBind, exprs') -> -- vanilla case => record parallel variables and return the final bindings do - { when parBind $ + { when parBind $ mapM_ addGlobalParallelVar vars - ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs') + ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs') } } ; return $ Rec newBinds } } } `orElseErrV` - do + do { emitVt " Could NOT vectorise top-level bindings" $ ppr vars ; return b } where vars = map fst binds noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" - + -- Replace the original top-level bindings by a values projected from the vectorised -- closures and add any newly created hoisted top-level bindings to the group. vectTopBindAndConvert (var, expr) inline expr' @@ -279,13 +279,13 @@ vectTopBind b@(Rec binds) -- vectImpBind :: (Id, CoreExpr) -> VM CoreBind vectImpBind (var, expr) - = do + = do { traceVt "= Add vectorised binding to imported variable" (ppr var) ; var' <- vectTopBinder var inlineMe expr ; return $ NonRec var' expr } - + -- |Make the vectorised version of this top level binder, and add the mapping between it and the -- original to the state. For some binder @foo@ the vectorised version is @$v_foo@ -- @@ -299,15 +299,15 @@ vectTopBinder :: Var -- ^ Name of the binding. vectTopBinder var inline expr = do { -- Vectorise the type attached to the var. ; vty <- vectType (idType var) - + -- If there is a vectorisation declartion for this binding, make sure its type matches ; (_, vectDecl) <- lookupVectDecl var ; case vectDecl of Nothing -> return () - Just (vdty, _) + Just (vdty, _) | eqType vty vdty -> return () - | otherwise -> - do + | otherwise -> + do { dflags <- getDynFlags ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ (text "Expected type" <+> ppr vty) @@ -315,7 +315,7 @@ vectTopBinder var inline expr (text "Inferred type" <+> ppr vdty) } -- Make the vectorised version of binding's name, and set the unfolding used for inlining - ; var' <- liftM (`setIdUnfoldingLazily` unfolding) + ; var' <- liftM (`setIdUnfoldingLazily` unfolding) $ mkVectId var vty -- Add the mapping between the plain and vectorised name to the state. @@ -348,9 +348,9 @@ tryConvert :: Var -- ^Name of the original binding (eg @foo@) -> CoreExpr -- ^The original body of the binding. -> VM CoreExpr tryConvert var vect_var rhs - = fromVect (idType var) (Var vect_var) - `orElseErrV` - do + = fromVect (idType var) (Var vect_var) + `orElseErrV` + do { emitVt " Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var) ; return rhs } diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs index a897ad29f4..7fe5b2cecc 100644 --- a/compiler/vectorise/Vectorise/Builtins.hs +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -6,10 +6,10 @@ module Vectorise.Builtins ( -- * Restrictions mAX_DPH_SCALAR_ARGS, - + -- * Builtins Builtins(..), - + -- * Wrapped selectors selTy, selsTy, selReplicate, diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index d5bbd65ee9..30438f0d1a 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -8,10 +8,10 @@ module Vectorise.Builtins.Base ( mAX_DPH_COMBINE, mAX_DPH_SCALAR_ARGS, aLL_DPH_PRIM_TYCONS, - + -- * Builtins Builtins(..), - + -- * Projections selTy, selsTy, selReplicate, @@ -68,8 +68,8 @@ aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doubleP -- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the -- vectoriser. -- -data Builtins - = Builtins +data Builtins + = Builtins { parrayTyCon :: TyCon -- ^ PArray , pdataTyCon :: TyCon -- ^ PData , pdatasTyCon :: TyCon -- ^ PDatas @@ -100,7 +100,7 @@ data Builtins , closureTyCon :: TyCon -- ^ :-> , closureVar :: Var -- ^ closure , liftedClosureVar :: Var -- ^ liftedClosure - , applyVar :: Var -- ^ $: + , applyVar :: Var -- ^ $: , liftedApplyVar :: Var -- ^ liftedApply , closureCtrFuns :: Array Int Var -- ^ closure1 .. closure3 , selTys :: Array Int Type -- ^ Sel2 @@ -127,7 +127,7 @@ selsLength :: Int -> Builtins -> CoreExpr selsLength = indexBuiltin "selLength" selsLengths selReplicate :: Int -> Builtins -> CoreExpr -selReplicate = indexBuiltin "selReplicate" selReplicates +selReplicate = indexBuiltin "selReplicate" selReplicates selTags :: Int -> Builtins -> CoreExpr selTags = indexBuiltin "selTags" selTagss @@ -140,13 +140,13 @@ sumTyCon = indexBuiltin "sumTyCon" sumTyCons prodTyCon :: Int -> Builtins -> TyCon prodTyCon n _ - | n >= 2 && n <= mAX_DPH_PROD + | n >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n | otherwise = pprPanic "prodTyCon" (ppr n) prodDataCon :: Int -> Builtins -> DataCon -prodDataCon n bi +prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of [con] -> con _ -> pprPanic "prodDataCon" (ppr n) @@ -168,7 +168,7 @@ combinePDVar = indexBuiltin "combinePDVar" combinePDVars combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var combinePD_PrimVar i tc bi - = lookupEnvBuiltin "combinePD_PrimVar" + = lookupEnvBuiltin "combinePD_PrimVar" (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc) scalarZip :: Int -> Builtins -> Var @@ -179,18 +179,18 @@ closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns -- | Get an element from one of the arrays of `Builtins`. -- Panic if the indexed thing is not in the array. -indexBuiltin :: (Ix i, Outputable i) +indexBuiltin :: (Ix i, Outputable i) => String -- ^ Name of the selector we've used, for panic messages. -> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`. -> i -- ^ Index into the array. - -> Builtins + -> Builtins -> a indexBuiltin fn f i bi | inRange (bounds xs) i = xs ! i - | otherwise - = pprSorry "Vectorise.Builtins.indexBuiltin" + | otherwise + = pprSorry "Vectorise.Builtins.indexBuiltin" (vcat [ text "" - , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> + , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> text "' is not yet implemented." , text "This function does not appear in your source program, but it is needed" , text "to compile your code in the backend. This is a known, current limitation" @@ -206,10 +206,10 @@ lookupEnvBuiltin :: String -- Function name for error message -> a lookupEnvBuiltin fn env n | Just r <- lookupNameEnv env n = r - | otherwise - = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" + | otherwise + = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" (vcat [ text "" - , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <> + , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <> text "' is not yet implemented." , text "This function does not appear in your source program, but it is needed" , text "to compile your code in the backend. This is a known, current limitation" diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index ee7cf9c2b5..21de8dcb8b 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -32,7 +32,7 @@ initBuiltins :: DsM Builtins initBuiltins = do { -- 'PArray: representation type for parallel arrays ; parrayTyCon <- externalTyCon (fsLit "PArray") - + -- 'PData': type family mapping array element types to array representation types -- Not all backends use `PDatas`. ; pdataTyCon <- externalTyCon (fsLit "PData") @@ -78,7 +78,7 @@ initBuiltins ; scalar_map <- externalVar (fsLit "scalar_map") ; scalar_zip2 <- externalVar (fsLit "scalar_zipWith") ; scalar_zips <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) - ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) + ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips) -- Types and functions for generic type representations @@ -115,9 +115,9 @@ initBuiltins selElementss = array ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements -- Distinct local variable - ; liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique + ; liftingContext <- liftM (\u -> mkSysLocalOrCoVar (fsLit "lc") u intPrimTy) newUnique - ; return $ Builtins + ; return $ Builtins { parrayTyCon = parrayTyCon , pdataTyCon = pdataTyCon , pdatasTyCon = pdatasTyCon @@ -222,11 +222,11 @@ externalType fs -- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name. externalClass :: FastString -> DsM Class -externalClass fs +externalClass fs = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon ; case tyConClass_maybe tycon of - Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ - ptext (sLit "Data.Array.Parallel.Prim.") <> + Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ + ptext (sLit "Data.Array.Parallel.Prim.") <> ftext fs <+> ptext (sLit "is not a type class") Just cls -> return cls } diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs index 84797b139b..af807c8fd7 100644 --- a/compiler/vectorise/Vectorise/Convert.hs +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -10,7 +10,7 @@ import Vectorise.Type.Type import CoreSyn import TyCon import Type -import TypeRep +import TyCoRep import NameSet import FastString import Outputable @@ -24,9 +24,9 @@ import Prelude -- avoid redundant import warning due to AMP -- For functions, we eta expand the function and convert the arguments and result: -- For example --- @ --- \(x :: Double) -> --- \(y :: Double) -> +-- @ +-- \(x :: Double) -> +-- \(y :: Double) -> -- ($v_foo $: x) $: y -- @ -- @@ -35,16 +35,16 @@ import Prelude -- avoid redundant import warning due to AMP fromVect :: Type -- ^ The type of the original binding. -> CoreExpr -- ^ Expression giving the closure to use, eg @$v_foo@. -> VM CoreExpr - + -- Convert the type to the core view if it isn't already. -- -fromVect ty expr - | Just ty' <- coreView ty +fromVect ty expr + | Just ty' <- coreView ty = fromVect ty' expr --- For each function constructor in the original type we add an outer +-- For each function constructor in the original type we add an outer -- lambda to bind the parameter variable, and an inner application of it. -fromVect (FunTy arg_ty res_ty) expr +fromVect (ForAllTy (Anon arg_ty) res_ty) expr = do arg <- newLocalVar (fsLit "x") arg_ty varg <- toVect arg_ty (Var arg) @@ -74,25 +74,26 @@ toVect ty expr = identityConv ty >> return expr -- are not altered by vectorisation as they contain no parallel arrays. -- identityConv :: Type -> VM () -identityConv ty - | Just ty' <- coreView ty +identityConv ty + | Just ty' <- coreView ty = identityConv ty' identityConv (TyConApp tycon tys) = do { mapM_ identityConv tys ; identityConvTyCon tycon } -identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" -identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" -identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" -identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation" -identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" +identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" +identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" +identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" +identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" +identityConv (CastTy {}) = noV $ text "identityConv: not sure about casted types under vectorisation" +identityConv (CoercionTy {}) = noV $ text "identityConv: not sure about coercions under vectorisation" -- |Check that this type constructor is not changed by vectorisation — i.e., it does not embed any -- parallel arrays. -- identityConvTyCon :: TyCon -> VM () identityConvTyCon tc - = do + = do { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons ; parray <- builtin parrayTyCon ; if isParallel && not (tc == parray) diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 098e9c8227..c3b0ee1b02 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -37,8 +37,8 @@ import Data.Maybe -- |Indicates what scope something (a variable) is in. -- -data Scope a b - = Global a +data Scope a b + = Global a | Local b @@ -51,13 +51,13 @@ data LocalEnv { local_vars :: VarEnv (Var, Var) -- ^Mapping from local variables to their vectorised and lifted versions. - , local_tyvars :: [TyVar] + , local_tyvars :: [TyVar] -- ^In-scope type variables. - , local_tyvar_pa :: VarEnv CoreExpr + , local_tyvar_pa :: VarEnv CoreExpr -- ^Mapping from tyvars to their PA dictionaries. - , local_bind_name :: FastString + , local_bind_name :: FastString -- ^Local binding name. This is only used to generate better names for hoisted -- expressions. } @@ -77,7 +77,7 @@ emptyLocalEnv = LocalEnv -- |The global environment: entities that exist at top-level. -- -data GlobalEnv +data GlobalEnv = GlobalEnv { global_vect_avoid :: Bool -- ^'True' implies to avoid vectorisation as far as possible. @@ -113,7 +113,7 @@ data GlobalEnv -- 'global_tycons' (to a type other than themselves) and are still not parallel. An -- example is '(->)'. Moreover, some types have *not* got a mapping in 'global_tycons' -- (because they couldn't be vectorised), but still contain parallel types. - + , global_datacons :: NameEnv DataCon -- ^Mapping from DataCons to their vectorised versions. @@ -146,7 +146,7 @@ initGlobalEnv :: Bool -> FamInstEnvs -> GlobalEnv initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs - = GlobalEnv + = GlobalEnv { global_vect_avoid = vectAvoid , global_vars = mapVarEnv snd $ vectInfoVar info , global_vect_decls = mkVarEnv vects @@ -204,7 +204,7 @@ setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps } -- modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo modVectInfo env mg_ids mg_tyCons vectDecls info - = info + = info { vectInfoVar = mk_env ids (global_vars env) , vectInfoTyCon = mk_env tyCons (global_tycons env) , vectInfoDataCon = mk_env dataCons (global_datacons env) @@ -222,10 +222,10 @@ modVectInfo env mg_ids mg_tyCons vectDecls info tyCons = mg_tyCons ++ vectTypeTyCons dataCons = concatMap tyConDataCons mg_tyCons ++ vectDataCons dataConIds = map dataConWorkId dataCons - selIds = concat [ classAllSelIds cls + selIds = concat [ classAllSelIds cls | tycon <- tyCons , cls <- maybeToList . tyConClass_maybe $ tycon] - + -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv' mk_env decls inspectedEnv = mkNameEnv [(name, (decl, to)) diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 83c87100a2..ffc1b9caf2 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -31,7 +31,7 @@ import DataCon import TyCon import TcType import Type -import TypeRep +import TyCoRep import Var import VarEnv import VarSet @@ -363,7 +363,7 @@ vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) | v == pAT_ERROR_ID = do { (vty, lty) <- vectAndLiftType ty - ; return (mkCoreApps (Var v) [Type vty, err'], mkCoreApps (Var v) [Type lty, err']) + ; return (mkCoreApps (Var v) [Type (getLevity "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err']) } where err' = deAnnotate err @@ -712,11 +712,11 @@ vectScalarDFun var ; return $ mkLams (tvs ++ vThetaBndr) vBody } where - ty = varType var - (tvs, theta, pty) = tcSplitSigmaTy ty -- 'theta' is the instance context - (cls, tys) = tcSplitDFunHead pty -- 'pty' is the instance head - selIds = classAllSelIds cls - dataCon = classDataCon cls + ty = varType var + (tvs, theta, pty) = tcSplitSigmaTy ty -- 'theta' is the instance context + (cls, tys) = tcSplitDFunHead pty -- 'pty' is the instance head + selIds = classAllSelIds cls + dataCon = classDataCon cls -- Build a value of the dictionary before vectorisation from original, unvectorised type and an -- expression computing the vectorised dictionary. @@ -1039,7 +1039,7 @@ unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2 -- * The first argument is the set of free, local variables whose evaluation may entail parallelism. -- vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo -vectAvoidInfo pvs ce@(fvs, AnnVar v) +vectAvoidInfo pvs ce@(_, AnnVar v) = do { gpvs <- globalParallelVars ; vi <- if v `elemVarSet` pvs || v `elemVarSet` gpvs @@ -1052,15 +1052,19 @@ vectAvoidInfo pvs ce@(fvs, AnnVar v) ; return ((udfmToUfm fvs, vi), AnnVar v) } + where + fvs = freeVarsOf ce -vectAvoidInfo _pvs ce@(fvs, AnnLit lit) +vectAvoidInfo _pvs ce@(_, AnnLit lit) = do { vi <- vectAvoidInfoTypeOf ce ; viTrace ce vi [] ; return ((udfmToUfm fvs, vi), AnnLit lit) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs ce@(fvs, AnnApp e1 e2) +vectAvoidInfo pvs ce@(_, AnnApp e1 e2) = do { ceVI <- vectAvoidInfoTypeOf ce ; eVI1 <- vectAvoidInfo pvs e1 @@ -1069,8 +1073,10 @@ vectAvoidInfo pvs ce@(fvs, AnnApp e1 e2) -- ; viTrace ce vi [eVI1, eVI2] ; return ((udfmToUfm fvs, vi), AnnApp eVI1 eVI2) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs (fvs, AnnLam var body) +vectAvoidInfo pvs ce@(_, AnnLam var body) = do { bodyVI <- vectAvoidInfo pvs body ; varVI <- vectAvoidInfoType $ varType var @@ -1078,8 +1084,10 @@ vectAvoidInfo pvs (fvs, AnnLam var body) -- ; viTrace ce vi [bodyVI] ; return ((udfmToUfm fvs, vi), AnnLam var bodyVI) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body) +vectAvoidInfo pvs ce@(_, AnnLet (AnnNonRec var e) body) = do { ceVI <- vectAvoidInfoTypeOf ce ; eVI <- vectAvoidInfo pvs e @@ -1096,8 +1104,10 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body) -- ; viTrace ce vi [eVI, bodyVI] ; return ((udfmToUfm fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body) +vectAvoidInfo pvs ce@(_, AnnLet (AnnRec bnds) body) = do { ceVI <- vectAvoidInfoTypeOf ce ; bndsVI <- mapM (vectAvoidInfoBnd pvs) bnds @@ -1119,6 +1129,7 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body) } } where + fvs = freeVarsOf ce vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e isVIParrBnd (var, eVI) @@ -1127,7 +1138,7 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body) ; return $ isVIParr eVI && not isScalarTy } -vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) +vectAvoidInfo pvs ce@(_, AnnCase e var ty alts) = do { ceVI <- vectAvoidInfoTypeOf ce ; eVI <- vectAvoidInfo pvs e @@ -1138,6 +1149,7 @@ vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) ; return ((udfmToUfm fvs, vi), AnnCase eVI var ty altsVI) } where + fvs = freeVarsOf ce vectAvoidInfoAlt scrutIsPar (con, bndrs, e) = do { allScalar <- allScalarVarType bndrs @@ -1146,24 +1158,31 @@ vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) ; (con, bndrs,) <$> vectAvoidInfo altPvs e } -vectAvoidInfo pvs (fvs, AnnCast e (fvs_ann, ann)) +vectAvoidInfo pvs ce@(_, AnnCast e (fvs_ann, ann)) = do { eVI <- vectAvoidInfo pvs e - ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI) - , AnnCast eVI ((udfmToUfm fvs_ann, VISimple), ann)) + ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI), AnnCast eVI ((udfmToUfm $ freeVarsOfAnn fvs_ann, VISimple), ann)) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs (fvs, AnnTick tick e) +vectAvoidInfo pvs ce@(_, AnnTick tick e) = do { eVI <- vectAvoidInfo pvs e ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI), AnnTick tick eVI) } + where + fvs = freeVarsOf ce -vectAvoidInfo _pvs (fvs, AnnType ty) +vectAvoidInfo _pvs ce@(_, AnnType ty) = return ((udfmToUfm fvs, VISimple), AnnType ty) + where + fvs = freeVarsOf ce -vectAvoidInfo _pvs (fvs, AnnCoercion coe) +vectAvoidInfo _pvs ce@(_, AnnCoercion coe) = return ((udfmToUfm fvs, VISimple), AnnCoercion coe) + where + fvs = freeVarsOf ce -- Compute vectorisation avoidance information for a type. -- @@ -1212,6 +1231,7 @@ maybeParrTy ty then return True else or <$> mapM maybeParrTy ts } + -- must be a Named ForAllTy because anon ones respond to splitTyConApp_maybe maybeParrTy (ForAllTy _ ty) = maybeParrTy ty maybeParrTy _ = return False diff --git a/compiler/vectorise/Vectorise/Generic/Description.hs b/compiler/vectorise/Vectorise/Generic/Description.hs index e6a2ee174e..78a8f2c192 100644 --- a/compiler/vectorise/Vectorise/Generic/Description.hs +++ b/compiler/vectorise/Vectorise/Generic/Description.hs @@ -5,7 +5,7 @@ -- from our generic representation. This module computes a description of what -- that generic representation is. -- -module Vectorise.Generic.Description +module Vectorise.Generic.Description ( CompRepr(..) , ProdRepr(..) , ConRepr(..) @@ -13,7 +13,7 @@ module Vectorise.Generic.Description , tyConRepr , sumReprType , compOrigType - ) + ) where import Vectorise.Utils @@ -31,7 +31,7 @@ import Outputable -- | Describes the generic representation of a data type. -- If the data type has multiple constructors then we bundle them -- together into a generic sum type. -data SumRepr +data SumRepr = -- | Data type has no data constructors. EmptySum @@ -57,7 +57,7 @@ data SumRepr , repr_sels_ty :: Type -- | Function to get the length of a Sels of this type. - , repr_selsLength_v :: CoreExpr + , repr_selsLength_v :: CoreExpr -- | Type of each data constructor. , repr_con_tys :: [Type] @@ -68,16 +68,16 @@ data SumRepr -- | Describes the representation type of a data constructor. -data ConRepr - = ConRepr +data ConRepr + = ConRepr { repr_dc :: DataCon - , repr_prod :: ProdRepr + , repr_prod :: ProdRepr } -- | Describes the representation type of the fields \/ components of a constructor. --- If the data constructor has multiple fields then we bundle them +-- If the data constructor has multiple fields then we bundle them -- together into a generic product type. -data ProdRepr +data ProdRepr = -- | Data constructor has no fields. EmptyProd @@ -115,7 +115,7 @@ data CompRepr -- |Determine the generic representation of a data type, given its tycon. -- tyConRepr :: TyCon -> VM SumRepr -tyConRepr tc +tyConRepr tc = sum_repr (tyConDataCons tc) where -- Build the representation type for a data type with the given constructors. @@ -124,22 +124,22 @@ tyConRepr tc sum_repr :: [DataCon] -> VM SumRepr sum_repr [] = return EmptySum sum_repr [con] = liftM UnarySum (con_repr con) - sum_repr cons + sum_repr cons = do let arity = length cons rs <- mapM con_repr cons tys <- mapM conReprType rs -- Get the 'Sum' tycon of this arity (eg Sum2). sum_tc <- builtin (sumTyCon arity) - + -- Get the 'PData' and 'PDatas' tycons for the sum. psum_tc <- pdataReprTyConExact sum_tc psums_tc <- pdatasReprTyConExact sum_tc - + sel_ty <- builtin (selTy arity) sels_ty <- builtin (selsTy arity) selsLength_v <- builtin (selsLength arity) - return $ Sum + return $ Sum { repr_sum_tc = sum_tc , repr_psum_tc = psum_tc , repr_psums_tc = psums_tc @@ -159,7 +159,7 @@ tyConRepr tc prod_repr :: [Type] -> VM ProdRepr prod_repr [] = return EmptyProd prod_repr [ty] = liftM UnaryProd (comp_repr ty) - prod_repr tys + prod_repr tys = do let arity = length tys rs <- mapM comp_repr tys tys' <- mapM compReprType rs @@ -170,15 +170,15 @@ tyConRepr tc -- Get the 'PData' and 'PDatas' tycons for the product. ptup_tc <- pdataReprTyConExact tup_tc ptups_tc <- pdatasReprTyConExact tup_tc - - return $ Prod + + return $ Prod { repr_tup_tc = tup_tc , repr_ptup_tc = ptup_tc , repr_ptups_tc = ptups_tc , repr_comp_tys = tys' , repr_comps = rs } - + -- Build the representation type for a single data constructor field. comp_repr ty = liftM (Keep ty) (prDictOfReprType ty) `orElseV` return (Wrap ty) @@ -228,7 +228,7 @@ instance Outputable SumRepr where -> sep [text "UnarySum", ppr con] Sum sumtc psumtc psumstc selty selsty selsLength contys cons - -> text "Sum" $+$ braces (nest 4 + -> text "Sum" $+$ braces (nest 4 $ sep [ text "repr_sum_tc = " <> ppr sumtc , text "repr_psum_tc = " <> ppr psumtc , text "repr_psums_tc = " <> ppr psumstc @@ -251,10 +251,10 @@ instance Outputable ProdRepr where = case ss of EmptyProd -> text "EmptyProd" - + UnaryProd cr -> sep [text "UnaryProd", ppr cr] - + Prod tuptcs ptuptcs ptupstcs comptys comps -> sep [text "Prod", ppr tuptcs, ppr ptuptcs, ppr ptupstcs, ppr comptys, ppr comps] @@ -264,7 +264,7 @@ instance Outputable CompRepr where = case ss of Keep t ce -> text "Keep" $+$ sep [ppr t, ppr ce] - + Wrap t -> sep [text "Wrap", ppr t] diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs index 7e70f2dd11..85256cf3ab 100644 --- a/compiler/vectorise/Vectorise/Generic/PADict.hs +++ b/compiler/vectorise/Vectorise/Generic/PADict.hs @@ -38,9 +38,9 @@ import FastString -- -- Example: -- df :: forall a. PR (PRepr a) -> PA a -> PA (T a) --- df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ... +-- df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ... -- $dPR_df :: forall a. PA a -> PR (PRepr (T a)) --- $dPR_df = .... +-- $dPR_df = .... -- $toRepr :: forall a. PA a -> T a -> PRepr (T a) -- $toPRepr = ... -- The "..." stuff is filled in by buildPAScAndMethods @@ -49,7 +49,7 @@ import FastString buildPADict :: TyCon -- ^ tycon of the type being vectorised. -> CoAxiom Unbranched - -- ^ Coercion between the type and + -- ^ Coercion between the type and -- its vectorised representation. -> TyCon -- ^ PData instance tycon -> TyCon -- ^ PDatas instance tycon @@ -62,7 +62,7 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr -- the envt; they don't include the silent superclass args yet do { mod <- liftDs getModule ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name - + -- The superclass dictionary is a (silent) argument if the tycon is polymorphic... ; let mk_super_ty = do { r <- mkPReprType inst_ty ; pr_cls <- builtin prClass @@ -72,7 +72,7 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys ; let val_args = super_args ++ args all_args = tvs ++ val_args - + -- ...it is constant otherwise ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs] @@ -84,13 +84,13 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr ; pa_dc <- builtin paDataCon ; let dict = mkLams all_args (mkConApp pa_dc con_args) con_args = Type inst_ty - : map Var super_args -- the superclass dictionary is either + : map Var super_args -- the superclass dictionary is either ++ super_consts -- lambda-bound or constant ++ map (method_call val_args) method_ids -- Build the type of the dictionary function. ; pa_cls <- builtin paClass - ; let dfun_ty = mkForAllTys tvs + ; let dfun_ty = mkInvForAllTys tvs $ mkFunTys (map varType val_args) (mkClassPred pa_cls [inst_ty]) diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index b5626bd566..d480ea926b 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -1,12 +1,12 @@ -- | Generate methods for the PA class. -- --- TODO: there is a large amount of redundancy here between the +-- TODO: there is a large amount of redundancy here between the -- a, PData a, and PDatas a forms. See if we can factor some of this out. -- module Vectorise.Generic.PAMethods ( buildPReprTyCon - , buildPAScAndMethods + , buildPAScAndMethods ) where import Vectorise.Utils @@ -38,7 +38,7 @@ buildPReprTyCon orig_tc vect_tc repr = do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) rhs_ty <- sumReprType repr prepr_tc <- builtin preprTyCon - let axiom = mkSingleCoAxiom Nominal name tyvars prepr_tc instTys rhs_ty + let axiom = mkSingleCoAxiom Nominal name tyvars [] prepr_tc instTys rhs_ty liftDs $ newFamInst SynFamilyInst axiom where tyvars = tyConTyVars vect_tc @@ -62,7 +62,7 @@ buildPReprTyCon orig_tc vect_tc repr -- @ -- type PAInstanceBuilder - = TyCon -- ^ Vectorised TyCon + = TyCon -- ^ Vectorised TyCon -> CoAxiom Unbranched -- ^ Coercion to the representation TyCon -> TyCon -- ^ 'PData' TyCon @@ -100,7 +100,7 @@ buildToPRepr vect_tc repr_ax _ _ repr where ty_args = mkTyVarTys (tyConTyVars vect_tc) - wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args + wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args [] -- CoreExp to convert the given argument to the generic representation. -- We start by doing a case branch on the possible data constructors. @@ -163,7 +163,7 @@ buildFromPRepr vect_tc repr_ax _ _ repr arg_ty <- mkPReprType res_ty arg <- newLocalVar (fsLit "x") arg_ty - result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args (Var arg)) + result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args [] (Var arg)) repr return $ Lam arg result where @@ -191,7 +191,7 @@ buildFromPRepr vect_tc repr_ax _ _ repr from_prod expr con (UnaryProd r) = do e <- from_comp expr r return $ con `App` e - + from_prod expr con (Prod { repr_tup_tc = tup_tc , repr_comp_tys = tys , repr_comps = comps @@ -218,8 +218,8 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r pdata_co <- mkBuiltinCo pdataTyCon let co = mkAppCo pdata_co - . mkSymCo - $ mkUnbranchedAxInstCo Nominal repr_co ty_args + $ mkSymCo + $ mkUnbranchedAxInstCo Nominal repr_co ty_args [] scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) @@ -235,7 +235,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r to_sum ss = case ss of - EmptySum -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) + EmptySum -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) UnarySum r -> to_con r Sum{} -> do let psum_tc = repr_psum_tc ss @@ -244,7 +244,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) return ( sel : concat vars , wrapFamInstBody psum_tc (repr_con_tys ss) - $ mkConApp psum_con + $ mkConApp psum_con $ map Type (repr_con_tys ss) ++ (Var sel : exprs)) to_prod ss @@ -283,7 +283,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r pdata_co <- mkBuiltinCo pdataTyCon let co = mkAppCo pdata_co - $ mkUnbranchedAxInstCo Nominal repr_co var_tys + $ mkUnbranchedAxInstCo Nominal repr_co var_tys [] let scrut = mkCast (Var arg) co @@ -330,7 +330,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r let scrut = unwrapFamInstScrut ptup_tc (repr_comp_tys ss) expr let body = mkWildCase scrut (exprType scrut) res_ty [(DataAlt ptup_con, vars, res')] - return (body, args) + return (body, args) from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r @@ -342,7 +342,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) where - f' (expr, r) (res, args) + f' (expr, r) (res, args) = do (res', args') <- f res_ty res expr r return (res', args' ++ args) @@ -357,7 +357,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- eg: 'PDatas (Tree a b)' arg_ty <- mkPDatasType el_ty - -- The result type. + -- The result type. -- eg: 'PDatas (PRepr (Tree a b))' res_ty <- mkPDatasType =<< mkPReprType el_ty @@ -368,8 +368,8 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- Coercion to case between the (PRepr a) type and its instance. pdatas_co <- mkBuiltinCo pdatasTyCon let co = mkAppCo pdatas_co - . mkSymCo - $ mkUnbranchedAxInstCo Nominal repr_co ty_args + $ mkSymCo + $ mkUnbranchedAxInstCo Nominal repr_co ty_args [] let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg) (vars, result) <- to_sum r @@ -383,10 +383,10 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- eg: 'Tree a b'. ty_args = mkTyVarTys $ tyConTyVars vect_tc el_ty = mkTyConApp vect_tc ty_args - + -- PDatas data constructor [pdatas_dc] = tyConDataCons pdatas_tc - + to_sum ss = case ss of -- We can't convert data types with no data. @@ -401,7 +401,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r let [psums_con] = tyConDataCons psums_tc sels <- newLocalVar (fsLit "sels") (repr_sels_ty ss) - -- Take the number of selectors to serve as the length of + -- Take the number of selectors to serve as the length of -- and PDatas Void arrays in the product. See Note [Empty PDatas]. let xSums = App (repr_selsLength_v ss) (Var sels) @@ -412,12 +412,12 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r , wrapFamInstBody psums_tc (repr_con_tys ss) $ mkCoreLet (NonRec xSums_var xSums) -- mkCoreLet ensures that the let/app invariant holds - $ mkConApp psums_con - $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) + $ mkConApp psums_con + $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) to_prod xSums ss = case ss of - EmptyProd + EmptyProd -> do pvoids <- builtin pvoidsVar return ([], App (Var pvoids) (Var xSums) ) @@ -447,23 +447,23 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- buildFromArrPReprs --------------------------------------------------------- buildFromArrPReprs :: PAInstanceBuilder buildFromArrPReprs vect_tc repr_co _ pdatas_tc r - = do + = do -- The argument type of the instance. -- eg: 'PDatas (PRepr (Tree a b))' arg_ty <- mkPDatasType =<< mkPReprType el_ty - -- The result type. + -- The result type. -- eg: 'PDatas (Tree a b)' res_ty <- mkPDatasType el_ty - + -- Variable to bind the argument to the instance -- eg: (xss :: PDatas (PRepr (Tree a b))) varg <- newLocalVar (fsLit "xss") arg_ty - + -- Build the coercion between PRepr and the instance type pdatas_co <- mkBuiltinCo pdatasTyCon let co = mkAppCo pdatas_co - $ mkUnbranchedAxInstCo Nominal repr_co var_tys + $ mkUnbranchedAxInstCo Nominal repr_co var_tys [] let scrut = mkCast (Var varg) co @@ -518,7 +518,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r let scrut = unwrapFamInstScrut ptups_tc (repr_comp_tys ss) expr let body = mkWildCase scrut (exprType scrut) res_ty [(DataAlt ptups_con, vars, res')] - return (body, args) + return (body, args) from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r @@ -531,7 +531,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) where - f' (expr, r) (res, args) + f' (expr, r) (res, args) = do (res', args') <- f res_ty res expr r return (res', args' ++ args) @@ -563,12 +563,12 @@ initialise the two (PDatas Void) arrays. However, with this: data Empty1 = MkEmpty1 - + The native and generic representations would be: type instance (PDatas Empty1) = VPDs:Empty1 type instance (PDatas (Repr Empty1)) = PVoids Int - -The 'Int' argument of PVoids is supposed to store the length of the PDatas + +The 'Int' argument of PVoids is supposed to store the length of the PDatas array. When converting the (PDatas Empty1) to a (PDatas (Repr Empty1)) we need to come up with a value for it, but there isn't one. diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index b69a773626..a8bffbe962 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -46,20 +46,20 @@ buildDataFamInst name' fam_tc vect_tc rhs = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' ; (_, tyvars') <- liftDs $ tcInstSigTyVarsLoc (getSrcSpan name') tyvars - ; let ax = mkSingleCoAxiom Representational axiom_name tyvars' fam_tc pat_tys rep_ty + ; let ax = mkSingleCoAxiom Representational axiom_name tyvars' [] fam_tc pat_tys rep_ty tys' = mkTyVarTys tyvars' rep_ty = mkTyConApp rep_tc tys' pat_tys = [mkTyConApp vect_tc tys'] - rep_tc = buildAlgTyCon name' + rep_tc = mkAlgTyCon name' + (mkPiTypesPreferFunTy tyvars' liftedTypeKind) tyvars' (map (const Nominal) tyvars') Nothing [] -- no stupid theta rhs + (DataFamInstTyCon ax fam_tc pat_tys) rec_flag -- FIXME: is this ok? - False -- Not promotable False -- not GADT syntax - (DataFamInstTyCon ax fam_tc pat_tys) ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } where tyvars = tyConTyVars vect_tc @@ -77,9 +77,10 @@ buildPDataDataCon orig_name vect_tc repr_tc repr dc_name <- mkLocalisedName mkPDataDataConOcc orig_name comp_tys <- mkSumTys repr_sel_ty mkPDataType repr fam_envs <- readGEnv global_fam_inst_env + rep_nm <- liftDs $ newTyConRepName dc_name liftDs $ buildDataCon fam_envs dc_name False -- not infix - NotPromoted -- not promotable + rep_nm (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels @@ -120,9 +121,10 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr fam_envs <- readGEnv global_fam_inst_env + rep_nm <- liftDs $ newTyConRepName dc_name liftDs $ buildDataCon fam_envs dc_name False -- not infix - NotPromoted -- not promotable + rep_nm (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 4e9726a598..4e7ee168b7 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -10,12 +10,12 @@ module Vectorise.Monad ( liftBuiltinDs, builtin, builtins, - + -- * Variables lookupVar, lookupVar_maybe, - addGlobalParallelVar, - addGlobalParallelTyCon, + addGlobalParallelVar, + addGlobalParallelTyCon, ) where import Vectorise.Monad.Base @@ -72,13 +72,13 @@ initV hsc_env guts info thing_inside dflags = hsc_dflags hsc_env dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace - + bindsToIds (NonRec v _) = [v] bindsToIds (Rec binds) = map fst binds - + ids = concatMap bindsToIds (mg_binds guts) - go + go = do { -- set up tables of builtin entities ; builtins <- initBuiltins ; builtin_vars <- initBuiltinVars builtins @@ -96,15 +96,15 @@ initV hsc_env guts info thing_inside ; let genv = extendImportedVarsEnv builtin_vars . setPAFunsEnv builtin_pas . setPRFunsEnv builtin_prs - $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags) + $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags) info (mg_vect_decls guts) instEnvs famInstEnvs - + -- perform vectorisation ; r <- runVM thing_inside builtins genv emptyLocalEnv ; case r of Yes genv _ x -> return $ Just (new_info genv, x) No reason -> do { unqual <- mkPrintUnqualifiedDs - ; liftIO $ + ; liftIO $ printOutputForUser dflags unqual $ mkDumpDoc "Warning: vectorisation failure:" reason ; return Nothing @@ -193,6 +193,6 @@ addGlobalParallelVar var addGlobalParallelTyCon :: TyCon -> VM () addGlobalParallelTyCon tycon = do { traceVt "addGlobalParallelTyCon" (ppr tycon) - ; updGEnv $ \env -> + ; updGEnv $ \env -> env{global_parallel_tycons = extendNameSet (global_parallel_tycons env) (tyConName tycon)} } diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs index f043f2552e..da53e8b94d 100644 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -12,10 +12,10 @@ module Vectorise.Monad.Base ( cantVectorise, maybeCantVectorise, maybeCantVectoriseM, - + -- * Debugging emitVt, traceVt, dumpOptVt, dumpVt, - + -- * Control noV, traceNoV, ensureV, traceEnsureV, @@ -43,11 +43,11 @@ import Control.Monad -- |Vectorisation can either succeed with new envionment and a value, or return with failure -- (including a description of the reason for failure). -- -data VResult a - = Yes GlobalEnv LocalEnv a +data VResult a + = Yes GlobalEnv LocalEnv a | No SDoc -newtype VM a +newtype VM a = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) } instance Monad VM where @@ -61,10 +61,10 @@ instance Monad VM where instance Applicative VM where pure x = VM $ \_ genv lenv -> return (Yes genv lenv x) (<*>) = ap - + instance Functor VM where fmap = liftM - + instance MonadIO VM where liftIO = liftDs . liftIO @@ -113,7 +113,7 @@ maybeCantVectoriseM s d p -- |Output a trace message if -ddump-vt-trace is active. -- -emitVt :: String -> SDoc -> VM () +emitVt :: String -> SDoc -> VM () emitVt herald doc = liftDs $ do dflags <- getDynFlags @@ -122,7 +122,7 @@ emitVt herald doc -- |Output a trace message if -ddump-vt-trace is active. -- -traceVt :: String -> SDoc -> VM () +traceVt :: String -> SDoc -> VM () traceVt herald doc = do dflags <- getDynFlags when (1 <= traceLevel dflags) $ @@ -131,17 +131,17 @@ traceVt herald doc -- |Dump the given program conditionally. -- dumpOptVt :: DumpFlag -> String -> SDoc -> VM () -dumpOptVt flag header doc +dumpOptVt flag header doc = do { b <- liftDs $ doptM flag - ; if b - then dumpVt header doc - else return () + ; if b + then dumpVt header doc + else return () } -- |Dump the given program unconditionally. -- dumpVt :: String -> SDoc -> VM () -dumpVt header doc +dumpVt header doc = do { unqual <- liftDs mkPrintUnqualifiedDs ; dflags <- liftDs getDynFlags ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc) @@ -190,7 +190,7 @@ tryErrV (VM p) = VM $ \bi genv lenv -> Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) No reason -> do { unqual <- mkPrintUnqualifiedDs ; dflags <- getDynFlags - ; liftIO $ + ; liftIO $ printInfoForUser dflags unqual $ text "Warning: vectorisation failure:" <+> reason ; return (Yes genv lenv Nothing) diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index 143330554f..2ad0059596 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -4,31 +4,31 @@ module Vectorise.Monad.Global ( readGEnv, setGEnv, updGEnv, - + -- * Configuration isVectAvoidanceAggressive, - + -- * Vars defGlobalVar, undefGlobalVar, - + -- * Vectorisation declarations - lookupVectDecl, - + lookupVectDecl, + -- * Scalars globalParallelVars, globalParallelTyCons, - + -- * TyCons lookupTyCon, defTyConName, defTyCon, globalVectTyCons, - + -- * Datacons lookupDataCon, defDataCon, - + -- * PA Dictionaries lookupTyConPA, defTyConPAs, - + -- * PR Dictionaries lookupTyConPR ) where @@ -85,7 +85,7 @@ isVectAvoidanceAggressive = readGEnv global_vect_avoid -- defGlobalVar :: Var -> Var -> VM () defGlobalVar v v' - = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') + = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v @@ -101,7 +101,7 @@ defGlobalVar v v' where moduleOf var var' | var == var' = ptext (sLit "vectorises to itself") - | Just mod <- nameModule_maybe (Var.varName var') + | Just mod <- nameModule_maybe (Var.varName var') = ptext (sLit "in module") <+> ppr mod | otherwise = ptext (sLit "in the current module") @@ -110,7 +110,7 @@ defGlobalVar v v' -- undefGlobalVar :: Var -> VM () undefGlobalVar v - = do + = do { traceVt "REMOVING global var mapping:" (ppr v) ; updGEnv $ \env -> env { global_vars = delVarEnv (global_vars env) v } } @@ -124,8 +124,8 @@ undefGlobalVar v -- The second component contains the given type and expression in case of a 'VECTORISE' declaration. -- lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr)) -lookupVectDecl var - = readGEnv $ \env -> +lookupVectDecl var + = readGEnv $ \env -> case lookupVarEnv (global_vect_decls env) var of Nothing -> (False, Nothing) Just Nothing -> (True, Nothing) @@ -164,7 +164,7 @@ lookupTyCon tc -- defTyConName :: TyCon -> Name -> TyCon -> VM () defTyConName tc nameOfTc' tc' - = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') + = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) @@ -175,13 +175,13 @@ defTyConName tc nameOfTc' tc' ppr tc <+> moduleOf tc old_tc' Nothing -> return () - ; updGEnv $ \env -> + ; updGEnv $ \env -> env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' } } where moduleOf tc tc' | tc == tc' = ptext (sLit "vectorises to itself") - | Just mod <- nameModule_maybe (tyConName tc') + | Just mod <- nameModule_maybe (tyConName tc') = ptext (sLit "in module") <+> ppr mod | otherwise = ptext (sLit "in the current module") @@ -203,9 +203,9 @@ globalVectTyCons = readGEnv global_tycons -- lookupDataCon :: DataCon -> VM (Maybe DataCon) lookupDataCon dc - | isTupleTyCon (dataConTyCon dc) + | isTupleTyCon (dataConTyCon dc) = return (Just dc) - | otherwise + | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc) -- |Add the mapping between plain and vectorised `DataCon`s to the global environment. diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index a97f319b4f..64b7441235 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} -module Vectorise.Monad.InstEnv +module Vectorise.Monad.InstEnv ( existsInst , lookupInst , lookupFamInst - ) + ) where import Vectorise.Monad.Global @@ -34,8 +34,8 @@ existsInst cls tys -- Look up the dfun of a class instance. -- --- The match must be unique —i.e., match exactly one instance— but the --- type arguments used for matching may be more specific than those of +-- The match must be unique —i.e., match exactly one instance— but the +-- type arguments used for matching may be more specific than those of -- the class instance declaration. The found class instances must not have -- any type variables in the instance context that do not appear in the -- instances head (i.e., no flexi vars); for details for what this means, @@ -53,8 +53,8 @@ lookupInst cls tys -- Look up a family instance. -- --- The match must be unique - ie, match exactly one instance - but the --- type arguments used for matching may be more specific than those of +-- The match must be unique - ie, match exactly one instance - but the +-- type arguments used for matching may be more specific than those of -- the family instance declaration. -- -- Return the family instance and its type instance. For example, if we have @@ -73,7 +73,7 @@ lookupFamInst tycon tys do { instEnv <- readGEnv global_fam_inst_env ; case lookupFamInstEnv instEnv tycon tys of [match] -> return match - _other -> + _other -> do dflags <- getDynFlags cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: " (ppr $ mkTyConApp tycon tys) diff --git a/compiler/vectorise/Vectorise/Monad/Local.hs b/compiler/vectorise/Vectorise/Monad/Local.hs index 6816627fb9..61f55ccd43 100644 --- a/compiler/vectorise/Vectorise/Monad/Local.hs +++ b/compiler/vectorise/Vectorise/Monad/Local.hs @@ -1,4 +1,4 @@ -module Vectorise.Monad.Local +module Vectorise.Monad.Local ( readLEnv , setLEnv , updLEnv @@ -12,7 +12,7 @@ module Vectorise.Monad.Local , localTyVars ) where - + import Vectorise.Monad.Base import Vectorise.Env @@ -43,8 +43,8 @@ updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ()) -- This does not alter the environment of the current state. -- localV :: VM a -> VM a -localV p - = do +localV p + = do { env <- readLEnv id ; x <- p ; setLEnv env @@ -54,7 +54,7 @@ localV p -- |Perform a computation in an empty local environment. -- closedV :: VM a -> VM a -closedV p +closedV p = do { env <- readLEnv id ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env }) @@ -68,7 +68,7 @@ closedV p getBindName :: VM FastString getBindName = readLEnv local_bind_name --- |Run a vectorisation computation in a local environment, +-- |Run a vectorisation computation in a local environment, -- with this id set as the current binding. -- inBind :: Id -> VM a -> VM a @@ -77,13 +77,11 @@ inBind id p p -- |Lookup a PA tyvars from the local environment. --- lookupTyVarPA :: Var -> VM (Maybe CoreExpr) -lookupTyVarPA tv - = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv +lookupTyVarPA tv + = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv -- |Add a tyvar to the local environment. --- defLocalTyVar :: TyVar -> VM () defLocalTyVar tv = updLEnv $ \env -> env { local_tyvars = tv : local_tyvars env @@ -91,7 +89,6 @@ defLocalTyVar tv = updLEnv $ \env -> } -- |Add mapping between a tyvar and pa dictionary to the local environment. --- defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM () defLocalTyVarWithPA tv pa = updLEnv $ \env -> env { local_tyvars = tv : local_tyvars env @@ -99,6 +96,5 @@ defLocalTyVarWithPA tv pa = updLEnv $ \env -> } -- |Get the set of tyvars from the local environment. --- localTyVars :: VM [TyVar] localTyVars = readLEnv (reverse . local_tyvars) diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs index b53324012f..9bb9bd1923 100644 --- a/compiler/vectorise/Vectorise/Monad/Naming.hs +++ b/compiler/vectorise/Vectorise/Monad/Naming.hs @@ -10,6 +10,7 @@ module Vectorise.Monad.Naming , newLocalVars , newDummyVar , newTyVar + , newCoVar ) where @@ -50,11 +51,11 @@ mkLocalisedName mk_occ name mkDerivedName :: (OccName -> OccName) -> Name -> VM Name -- Similar to mkLocalisedName, but assumes the --- incoming name is from this module. +-- incoming name is from this module. -- Works on External names only -mkDerivedName mk_occ name +mkDerivedName mk_occ name = do { u <- liftDs newUnique - ; return (mkExternalName u (nameModule name) + ; return (mkExternalName u (nameModule name) (mk_occ (nameOccName name)) (nameSrcSpan name)) } @@ -69,7 +70,7 @@ mkVectId id ty = do { name <- mkLocalisedName mkVectOcc (getName id) ; let id' | isDFunId id = MkId.mkDictFunId name tvs theta cls tys | isExportedId id = Id.mkExportedLocalId VanillaId name ty - | otherwise = Id.mkLocalId name ty + | otherwise = Id.mkLocalIdOrCoVar name ty ; return id' } where @@ -87,7 +88,7 @@ cloneVar var = liftM (setIdUnique var) (liftDs newUnique) -- |Make a fresh exported variable with the given type. -- newExportedVar :: OccName -> Type -> VM Var -newExportedVar occ_name ty +newExportedVar occ_name ty = do mod <- liftDs getModule u <- liftDs newUnique @@ -101,7 +102,7 @@ newExportedVar occ_name ty newLocalVar :: FastString -> Type -> VM Var newLocalVar fs ty = do u <- liftDs newUnique - return $ mkSysLocal fs u ty + return $ mkSysLocalOrCoVar fs u ty -- |Make several fresh local variables with the given types. -- The variable's names are formed using the given string as the prefix. @@ -121,3 +122,9 @@ newTyVar :: FastString -> Kind -> VM Var newTyVar fs k = do u <- liftDs newUnique return $ mkTyVar (mkSysTvName u fs) k + +-- |Mkae a fresh coercion variable with the given kind. +newCoVar :: FastString -> Kind -> VM Var +newCoVar fs k + = do u <- liftDs newUnique + return $ mkCoVar (mkSystemVarName u fs) k diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 21a221d968..55eb459e8e 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -13,9 +13,9 @@ -- types. As '([::])' is being vectorised, any type constructor whose definition involves -- '([::])', either directly or indirectly, will be vectorised. -module Vectorise.Type.Classify +module Vectorise.Type.Classify ( classifyTyCons - ) + ) where import NameSet @@ -23,12 +23,11 @@ import UniqSet import UniqFM import DataCon import TyCon -import TypeRep -import Type hiding (tyConsOfType) +import TyCoRep +import qualified Type import PrelNames import Digraph - -- |From a list of type constructors, extract those that can be vectorised, returning them in two -- sets, where the first result list /must be/ vectorised and the second result list /need not be/ -- vectorised. The third result list are those type constructors that we cannot convert (either @@ -66,14 +65,14 @@ classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyC = classify conv keep (par ++ tcs_par) (tcs ++ novect) cs pts' rs where refs = ds `delListFromUniqSet` tcs - + -- the tycons that directly or indirectly depend on parallel arrays tcs_par | any ((`elemNameSet` parTyCons) . tyConName) . eltsUFM $ refs = tcs | otherwise = [] pts' = pts `extendNameSetList` map tyConName tcs_par - can_convert = (isNullUFM (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `minusUFM` cs)) + can_convert = (isNullUFM (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `minusUFM` cs)) && all convertable tcs) || isShowClass tcs must_convert = foldUFM (||) False (intersectUFM_C const cs refs) @@ -81,10 +80,10 @@ classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyC -- We currently admit Haskell 2011-style data and newtype declarations as well as type -- constructors representing classes. - convertable tc + convertable tc = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc) || isClassTyCon tc - + -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a -- vectorised definition (to be able to vectorise 'Num') isShowClass [tc] = tyConName tc == showClassName @@ -120,18 +119,6 @@ tyConsOfTypes = unionManyUniqSets . map tyConsOfType -- |Collect the set of TyCons that occur in this type. -- tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - | Just ty' <- coreView ty = tyConsOfType ty' -tyConsOfType (TyVarTy _) = emptyUniqSet -tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) - where - extend | isUnLiftedTyCon tc - || isTupleTyCon tc = id - - | otherwise = (`addOneToUniqSet` tc) +tyConsOfType ty = filterUniqSet not_tuple_or_unlifted $ Type.tyConsOfType ty + where not_tuple_or_unlifted tc = not (isUnLiftedTyCon tc || isTupleTyCon tc) -tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b -tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) - `addOneToUniqSet` funTyCon -tyConsOfType (LitTy _) = emptyUniqSet -tyConsOfType (ForAllTy _ ty) = tyConsOfType ty diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 8396e2cafa..e4b538ac34 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -5,10 +5,10 @@ -- This produces new type constructors and family instances top be included in the module toplevel -- as well as bindings for worker functions, dfuns, and the like. -module Vectorise.Type.Env ( +module Vectorise.Type.Env ( vectTypeEnv, ) where - + #include "HsVersions.h" import Vectorise.Env @@ -84,7 +84,7 @@ import Data.List -- -- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an -- explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code (i.e., the --- constructors of 'T' may not occur in vectorised code). +-- constructors of 'T' may not occur in vectorised code). -- -- An example is the treatment of '[::]'. The type '[::]' can be used in vectorised code and is -- vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised @@ -123,7 +123,7 @@ import Data.List -- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated -- by the vectoriser). -- --- Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this +-- Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this -- manner. (The vectoriser never treats a type constructor automatically in this manner.) -- -- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}. @@ -173,21 +173,21 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls] ++ [tycon | VectClass tycon <- vectClassDecls]) \\ tycons - + -- {-# VECTORISE type T = Tv -#} (imported & local tycons with an /RHS/) vectTyConsWithRHS = [ (tycon, rhs) | VectType False tycon (Just rhs) <- vectTypeDecls] -- {-# VECTORISE SCALAR type T = Tv -#} (imported & local tycons with an /RHS/) - scalarTyConsWithRHS = [ (tycon, rhs) + scalarTyConsWithRHS = [ (tycon, rhs) | VectType True tycon (Just rhs) <- vectTypeDecls] -- {-# VECTORISE SCALAR type T -#} (imported & local /scalar/ tycons without an RHS) scalarTyConsNoRHS = [tycon | VectType True tycon Nothing <- vectTypeDecls] -- Check that is not a VECTORISE SCALAR tycon nor VECTORISE tycons with explicit rhs? - vectSpecialTyConNames = mkNameSet . map tyConName $ - scalarTyConsNoRHS ++ + vectSpecialTyConNames = mkNameSet . map tyConName $ + scalarTyConsNoRHS ++ map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS) notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames @@ -197,14 +197,14 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ; vectTyCons <- globalVectTyCons ; let vectTyConBase = mapUFM_Directly isDistinct vectTyCons -- 'True' iff tc /= V[[tc]] isDistinct u tc = u /= getUnique tc - vectTyConFlavour = vectTyConBase - `plusNameEnv` - mkNameEnv [ (tyConName tycon, True) + vectTyConFlavour = vectTyConBase + `plusNameEnv` + mkNameEnv [ (tyConName tycon, True) | (tycon, _) <- vectTyConsWithRHS ++ scalarTyConsWithRHS] `plusNameEnv` mkNameEnv [ (tyConName tycon, False) -- original representation | tycon <- scalarTyConsNoRHS] - + -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2) -- that we could, but don't need to vectorise. Type constructors that are not data @@ -230,19 +230,19 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty ; traceVt " reuse : " $ ppr keep_tcs ; traceVt " convert : " $ ppr conv_tcs - + -- warn the user about unvectorised type constructors ; let explanation = ptext (sLit "(They use unsupported language extensions") $$ ptext (sLit "or depend on type constructors that are not vectorised)") drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) . filter (not . isTypeSynonymTyCon) $ drop_tcs ; unless (null drop_tcs_nosyn) $ - emitVt "Warning: cannot vectorise these type constructors:" $ + emitVt "Warning: cannot vectorise these type constructors:" $ pprQuotedList drop_tcs_nosyn $$ explanation ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS - ; let mapping = + ; let mapping = -- Type constructors that we found we don't need to vectorise and those -- declared VECTORISE SCALAR /without/ an explicit right-hand side, use the same -- representation in both unvectorised and vectorised code; they are not @@ -256,7 +256,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Vectorise all the data type declarations that we can and must vectorise (enter the -- type and data constructors into the vectorisation map on-the-fly.) ; new_tcs <- vectTyConDecls conv_tcs - + ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$ ppr vTc <+> text "::" <+> ppr (dataConSig vTc)) dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc @@ -280,7 +280,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls repr_axs = map famInstAxiom repr_fis pdata_tcs = famInstsRepTyCons pdata_fis pdatas_tcs = famInstsRepTyCons pdatas_fis - + ; updGEnv $ extendFamEnv fam_insts -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of @@ -328,7 +328,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Ignoring the promoted tycon; hope that's ok } - -- Add a mapping from the original to vectorised type constructor to the vectorisation map. + -- Add a mapping from the original to vectorised type constructor to the vectorisation map. -- Unless the type constructor is abstract, also mappings from the orignal's data constructors -- to the vectorised type's data constructors. -- @@ -343,7 +343,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls { canonName <- mkLocalisedName mkVectTyConOcc origName ; if origName == vectName -- Case (1) || vectName == canonName -- Case (2) - then do + then do { defTyCon origTyCon vectTyCon -- T --> vT ; defDataCons -- Ci --> vCi ; return Nothing @@ -360,10 +360,10 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls vectName = tyConName vectTyCon mkSyn canonName ty = mkSynonymTyCon canonName (typeKind ty) [] [] ty - + defDataCons | isAbstract = return () - | otherwise + | otherwise = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon)) ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon) } @@ -386,7 +386,7 @@ buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () vectDataConWorkers orig_tc vect_tc arr_tc = do { traceVt "Building vectorised worker for datatype" (ppr orig_tc) - + ; bs <- sequence . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys $ zipWith4 mk_data_con (tyConDataCons vect_tc) diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index e462d0fac1..859df3749b 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -6,7 +6,7 @@ module Vectorise.Type.TyConDecl ( import Vectorise.Type.Type import Vectorise.Monad import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) -import BuildTyCl( TcMethInfo, buildClass, buildDataCon ) +import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName ) import OccName import Class import Type @@ -64,6 +64,7 @@ vectTyConDecl tycon name' (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety theta' -- superclasses + (tyConKind tycon) -- keep original kind (snd . classTvsFds $ cls) -- keep the original functional dependencies [] -- no associated types (for the moment) methods' -- method info @@ -100,17 +101,17 @@ vectTyConDecl tycon name' -- build the vectorised type constructor ; tc_rep_name <- mkDerivedName mkTyConRepUserOcc name' - ; return $ buildAlgTyCon + ; return $ mkAlgTyCon name' -- new name + (tyConKind tycon) -- keep original kind (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety Nothing [] -- no stupid theta rhs' -- new constructor defs + (VanillaAlgTyCon tc_rep_name) rec_flag -- whether recursive - False -- Not promotable gadt_flag -- whether in GADT syntax - (VanillaAlgTyCon tc_rep_name) } -- some other crazy thing that we don't handle @@ -181,10 +182,11 @@ vectDataCon dc ; arg_tys <- mapM vectType rep_arg_tys ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs) ; fam_envs <- readGEnv global_fam_inst_env + ; rep_nm <- liftDs $ newTyConRepName name' ; liftDs $ buildDataCon fam_envs name' (dataConIsInfix dc) -- infix if the original is - NotPromoted -- Vectorised type is not promotable + rep_nm (dataConSrcBangs dc) -- strictness as original constructor (Just $ dataConImplBangs dc) [] -- no labelled fields for now diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index 77b5b17e5f..088269130f 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -4,7 +4,7 @@ module Vectorise.Type.Type ( vectTyCon , vectAndLiftType , vectType - ) + ) where import Vectorise.Utils @@ -12,11 +12,12 @@ import Vectorise.Monad import Vectorise.Builtins import TcType import Type -import TypeRep +import TyCoRep import TyCon import Control.Monad import Control.Applicative import Data.Maybe +import Outputable import Prelude -- avoid redundant import warning due to AMP -- |Vectorise a type constructor. Unless there is a vectorised version (stripped of embedded @@ -41,12 +42,12 @@ vectAndLiftType ty } where (tyvars, phiTy) = splitForAllTys ty - (theta, mono_ty) = tcSplitPhiTy phiTy + (theta, mono_ty) = tcSplitPhiTy phiTy -- |Vectorise a type. -- -- For each quantified var we need to add a PA dictionary out the front of the type. --- So forall a. C a => a -> a +-- So forall a. C a => a -> a -- turns into forall a. PA a => Cv a => a :-> a -- vectType :: Type -> VM Type @@ -57,12 +58,12 @@ vectType (TyVarTy tv) = return $ TyVarTy tv vectType (LitTy l) = return $ LitTy l vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys -vectType (FunTy ty1 ty2) +vectType (ForAllTy (Anon ty1) ty2) | isPredTy ty1 - = FunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction + = mkFunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction | otherwise = TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2] -vectType ty@(ForAllTy _ _) +vectType ty@(ForAllTy {}) = do { -- strip off consecutive foralls ; let (tyvars, tyBody) = splitForAllTys ty @@ -75,8 +76,12 @@ vectType ty@(ForAllTy _ _) -- add the PA dictionaries after the foralls ; return $ abstractType tyvars dictsPA vtyBody } +vectType ty@(CastTy {}) + = pprSorry "Vectorise.Type.Type.vectType: CastTy" (ppr ty) +vectType ty@(CoercionTy {}) + = pprSorry "Vectorise.Type.Type.vectType: CoercionTy" (ppr ty) -- |Add quantified vars and dictionary parameters to the front of a type. -- abstractType :: [TyVar] -> [Type] -> Type -> Type -abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts +abstractType tyvars dicts = mkInvForAllTys tyvars . mkFunTys dicts diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs index fafce7a67d..733eeb9cfd 100644 --- a/compiler/vectorise/Vectorise/Utils.hs +++ b/compiler/vectorise/Vectorise/Utils.hs @@ -48,7 +48,7 @@ collectAnnTypeArgs expr = go expr [] collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann]) collectAnnDictArgs expr = go expr [] where - go e@(_, AnnApp f arg) dicts + go e@(_, AnnApp f arg) dicts | isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts) | otherwise = (e, dicts) go e dicts = (e, dicts) @@ -64,7 +64,7 @@ collectAnnTypeBinders expr = go [] expr collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) collectAnnValBinders expr = go [] expr where - go bs (_, AnnLam b e) | isId b + go bs (_, AnnLam b e) | isId b && (not . isPredTy . idType $ b) = go (b : bs) e go bs e = (reverse bs, e) @@ -75,7 +75,7 @@ isAnnTypeArg _ = False -- PD "Parallel Data" Functions ----------------------------------------------- -- --- Given some data that has a PA dictionary, we can convert it to its +-- Given some data that has a PA dictionary, we can convert it to its -- representation type, perform some operation on the data, then convert it back. -- -- In the DPH backend, the types of these functions are defined @@ -92,14 +92,14 @@ emptyPD = paMethod emptyPDVar emptyPD_PrimVar replicatePD :: CoreExpr -- ^ Number of copies in the resulting array. -> CoreExpr -- ^ Value to replicate. -> VM CoreExpr -replicatePD len x +replicatePD len x = liftM (`mkApps` [len,x]) $ paMethod replicatePDVar replicatePD_PrimVar (exprType x) -- |Select some elements from an array that correspond to a particular tag value and pack them into a new -- array. -- --- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 +-- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 -- > ==> [:42, 50, 49:] -- packByTagPD :: Type -- ^ Element type. @@ -146,7 +146,7 @@ isScalar ty zipScalars :: [Type] -> Type -> VM CoreExpr zipScalars arg_tys res_ty - = do + = do { scalar <- builtin scalarClass ; (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args ; zipf <- builtin (scalarZip $ length arg_tys) diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 9c603807d6..0b8cb7099b 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module Vectorise.Utils.Base +module Vectorise.Utils.Base ( voidType , newLocalVVar @@ -18,12 +18,12 @@ module Vectorise.Utils.Base , unwrapNewTypeBodyOfPDataWrap , wrapNewTypeBodyOfPDatasWrap , unwrapNewTypeBodyOfPDatasWrap - + , pdataReprTyCon , pdataReprTyConExact , pdatasReprTyConExact , pdataUnwrapScrut - + , preprFamInst ) where @@ -206,10 +206,10 @@ unwrapNewTypeBodyOfPDatasWrap e ty -- The type for which we look up a 'PData' instance may be more specific than the type in the -- instance declaration. In that case the second component of the result will be more specific than -- a set of distinct type variables. --- +-- pdataReprTyCon :: Type -> VM (TyCon, [Type]) -pdataReprTyCon ty - = do +pdataReprTyCon ty + = do { FamInstMatch { fim_instance = famInst , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) ; return (dataFamInstRepTyCon famInst, tys) diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index 335b34b909..118f34dfbf 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -100,7 +100,7 @@ buildClosure :: [TyVar] -- ^Type variables passed during closure constru -> [VVar] -- ^Variables in the environment. -> Type -- ^Type of the closure argument. -> Type -- ^Type of the result. - -> VM VExpr + -> VM VExpr -> VM VExpr buildClosure tvs vars vvars arg_ty res_ty mk_body = do { (env_ty, env, bind) <- buildEnv vvars @@ -122,7 +122,7 @@ buildClosure tvs vars vvars arg_ty res_ty mk_body -- Build the environment for a single closure. -- buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) -buildEnv [] +buildEnv [] = do ty <- voidType void <- builtin voidVar diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs index 105c8210ae..7bca567d1b 100644 --- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs +++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs @@ -2,7 +2,7 @@ module Vectorise.Utils.Hoisting ( Inline(..) , addInlineArity , inlineMe - + , hoistBinding , hoistExpr , hoistVExpr @@ -31,7 +31,7 @@ import Prelude -- avoid redundant import warning due to AMP -- |Records whether we should inline a particular binding. -- -data Inline +data Inline = Inline Arity | DontInline diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index c2ca20a683..ca2006b91f 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -15,7 +15,7 @@ import CoreUtils import FamInstEnv import Coercion import Type -import TypeRep +import TyCoRep import TyCon import CoAxiom import Var @@ -31,16 +31,18 @@ import Control.Monad -- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a) -- paDictArgType :: TyVar -> VM (Maybe Type) -paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) +paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv) where - go ty (FunTy k1 k2) + go ty (ForAllTy (Anon k1) k2) = do - tv <- newTyVar (fsLit "a") k1 - mty1 <- go (TyVarTy tv) k1 + tv <- if isCoercionType k1 + then newCoVar (fsLit "c") k1 + else newTyVar (fsLit "a") k1 + mty1 <- go (mkTyVarTy tv) k1 case mty1 of Just ty1 -> do - mty2 <- go (AppTy ty (TyVarTy tv)) k2 - return $ fmap (ForAllTy tv . FunTy ty1) mty2 + mty2 <- go (mkAppTy ty (mkTyVarTy tv)) k2 + return $ fmap (mkNamedForAllTy tv Invisible . mkFunTy ty1) mty2 Nothing -> go ty k2 go ty k @@ -55,20 +57,20 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) -- |Get the PA dictionary for some type -- paDictOfType :: Type -> VM CoreExpr -paDictOfType ty +paDictOfType ty = paDictOfTyApp ty_fn ty_args where (ty_fn, ty_args) = splitAppTys ty paDictOfTyApp :: Type -> [Type] -> VM CoreExpr paDictOfTyApp ty_fn ty_args - | Just ty_fn' <- coreView ty_fn + | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args -- for type variables, look up the dfun and apply to the PA dictionaries -- of the type arguments paDictOfTyApp (TyVarTy tv) ty_args - = do + = do { dfun <- maybeCantVectoriseM "No PA dictionary for type variable" (ppr tv <+> text "in" <+> ppr ty) $ lookupTyVarPA tv @@ -79,7 +81,7 @@ paDictOfType ty -- for tycons, we also need to apply the dfun to the PR dictionary of -- the representation type if the tycon is polymorphic paDictOfTyApp (TyConApp tc []) ty_args - = do + = do { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) $ lookupTyConPA tc ; super <- super_dict tc ty_args @@ -95,7 +97,7 @@ paDictOfType ty { pr <- prDictOfPReprInst (TyConApp tycon ty_args) ; return [pr] } - + paDictOfTyApp _ _ = getDynFlags >>= failure failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty) @@ -141,12 +143,12 @@ prDictOfPReprInst ty prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr prDictOfPReprInstTyCon _ty prepr_ax prepr_args = do - let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args + let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args [] dict <- prDictOfReprType' rhs pr_co <- mkBuiltinCo prTyCon let co = mkAppCo pr_co $ mkSymCo - $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args + $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args [] return $ mkCast dict co -- |Get the PR dictionary for a type. The argument must be a representation @@ -163,9 +165,9 @@ prDictOfReprType ty pa <- paDictOfType ty' sel <- builtin paPRSel return $ Var sel `App` Type ty' `App` pa - else do + else do -- a representation tycon must have a PR instance - dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ + dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ lookupTyConPR tycon prDFunApply dfun tyargs @@ -200,7 +202,7 @@ prDFunApply dfun tys , length tycons == length tys = do pa <- builtin paTyCon - pr <- builtin prTyCon + pr <- builtin prTyCon dflags <- getDynFlags args <- zipWithM (dictionary dflags pa pr) tys tycons return $ Var dfun `mkTyApps` tys `mkApps` args @@ -225,4 +227,3 @@ prDFunApply dfun tys | otherwise = invalid dflags invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) - diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs index e943313be9..d9f657f950 100644 --- a/compiler/vectorise/Vectorise/Utils/Poly.hs +++ b/compiler/vectorise/Vectorise/Utils/Poly.hs @@ -5,7 +5,7 @@ module Vectorise.Utils.Poly , polyApply , polyVApply , polyArity - ) + ) where import Vectorise.Vect @@ -36,7 +36,7 @@ polyAbstract tvs p ; p (mk_args mdicts) } where - mk_dict_var tv + mk_dict_var tv = do { r <- paDictArgType tv ; case r of Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty) @@ -49,7 +49,7 @@ polyAbstract tvs p -- on their kinds). -- polyArity :: [TyVar] -> VM Int -polyArity tvs +polyArity tvs = do { tys <- mapM paDictArgType tvs ; return $ length [() | Just _ <- tys] } @@ -62,7 +62,7 @@ polyApply expr tys ; return $ expr `mkTyApps` tys `mkApps` dicts } --- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for +-- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for -- these type arguments. -- polyVApply :: VExpr -> [Type] -> VM VExpr diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs index 09daf76368..5cfc8415f7 100644 --- a/compiler/vectorise/Vectorise/Var.hs +++ b/compiler/vectorise/Vectorise/Var.hs @@ -2,7 +2,7 @@ -- |Vectorise variables and literals. -module Vectorise.Var +module Vectorise.Var ( vectBndr , vectBndrNew , vectBndrIn diff --git a/compiler/vectorise/Vectorise/Vect.hs b/compiler/vectorise/Vectorise/Vect.hs index b64f956185..fac1ab46f4 100644 --- a/compiler/vectorise/Vectorise/Vect.hs +++ b/compiler/vectorise/Vectorise/Vect.hs @@ -19,7 +19,7 @@ module Vectorise.Vect , vCaseDEFAULT ) where - + import CoreSyn import Type ( Type ) import Var @@ -97,7 +97,7 @@ vLams :: Var -- ^ Var bound to the lifting context. -> [VVar] -- ^ Parameter vars for the abstraction. -> VExpr -- ^ Body of the abstraction. -> VExpr -vLams lc vs (ve, le) +vLams lc vs (ve, le) = (mkLams vvs ve, mkLams (lc:lvs) le) where (vvs, lvs) = unzip vs @@ -107,10 +107,10 @@ vLams lc vs (ve, le) -- The lifted version is also applied to the variable of the lifting context. -- vVarApps :: Var -> VExpr -> [VVar] -> VExpr -vVarApps lc (ve, le) vvs +vVarApps lc (ve, le) vvs = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls)) where - (vs, ls) = unzip vvs + (vs, ls) = unzip vvs vCaseDEFAULT :: VExpr -- scrutiniy diff --git a/docs/core-spec/.gitignore b/docs/core-spec/.gitignore index a1958037ad..dac3bd2547 100644 --- a/docs/core-spec/.gitignore +++ b/docs/core-spec/.gitignore @@ -3,3 +3,4 @@ *.fdb_latexmk CoreOtt.tex core-spec.tex +*.fls diff --git a/docs/core-spec/CoreLint.ott b/docs/core-spec/CoreLint.ott index 7058e8a113..50b11ce7e7 100644 --- a/docs/core-spec/CoreLint.ott +++ b/docs/core-spec/CoreLint.ott @@ -51,7 +51,7 @@ defn G |- tm e : t :: :: lintCoreExpr :: 'Tm_' by x_t elt G -not (t is_a_coercion) +not (t is_a_coercion_type) ------------------ :: Var G |-tm x_t : t @@ -60,7 +60,8 @@ t = literalType lit G |-tm lit : t G |-tm e : s -G |-co g : s ~Rep k t +G |-co g : s k1~Rep k2 t +k2 elt { *, # } ------------------- :: Cast G |-tm e |> g : t @@ -77,12 +78,14 @@ G |-tm let alpha_k = s in e : t G |-sbind x_s <- u G |-ty s : k +k = * \/ k = # G, x_s |-tm e : t ------------------------- :: LetNonRec G |-tm let x_s = u in e : t -</ G'i @ // i /> = inits(</ zi_si // i />) +</ G'i $ // i /> = inits(</ zi_si // i />) </ G, G'i |-ty si : ki // i /> +</ ki = * \/ ki = # // i /> no_duplicates </ zi // i /> G' = G, </ zi_si // i /> </ G' |-sbind zi_si <- ui // i /> @@ -92,10 +95,10 @@ G |-tm let rec </ zi_si = ui // i /> in e : t % lintCoreArg is incorporated in these next two rules -G |-tm e1 : forall alpha_k.t +G |-tm e : forall alpha_k.t G |-subst alpha_k |-> s ok ---------------- :: AppType -G |-tm e1 s : t[alpha_k |-> s] +G |-tm e s : t[alpha_k |-> s] not (e2 is_a_type) G |-tm e1 : t1 -> t2 @@ -103,31 +106,37 @@ G |-tm e2 : t1 ---------------- :: AppExpr G |-tm e1 e2 : t2 +not (k is_a_coercion_type) G |-ty t : k G, x_t |-tm e : s ----------------- :: LamId G |-tm \x_t.e : t -> s -G' = G, alpha_k G |-ki k ok -G' |-tm e : t +G,alpha_k |-tm e : t --------------------------- :: LamTy G |-tm \alpha_k.e : forall alpha_k. t +phi = s1 k1~#k2 s2 +G |-ki phi ok +G,c_phi |-tm e : t +-------------------------------- :: LamCo +G |-tm \c_phi.e : forall c_phi.t + G |-tm e : s -G |-ty s : k1 -G |-ty t : k2 +s = * \/ s = # +G |-ty t : TYPE s2 </ G, z_s; s |-altern alti : t // i /> ---------------------------------------------------- :: Case G |-tm case e as z_s return t of </ alti // i /> : t -G |-co g : t1 ~Nom k t2 --------------------- :: CoercionNom -G |-tm g : t1 ~#k t2 +G |-co g : t1 k1~Nom k2 t2 +-------------------- :: Coercion +G |-tm g : t1 k1~#k2 t2 -G |-co g : t1 ~Rep k t2 +G |-co g : t1 k1~Rep k2 t2 ----------------------- :: CoercionRep -G |-tm g : (~R#) k t1 t2 +G |-tm g : (~Rep#) k1 k2 t1 t2 defn G |- name n ok :: :: lintSingleBinding_lintBinder :: 'Name_' {{ com Name consistency check, \coderef{coreSyn/CoreLint.lhs}{lintSingleBinding\#lintBinder} }} @@ -135,6 +144,7 @@ defn G |- name n ok :: :: lintSingleBinding_lintBinder :: 'Name_' by G |-ty t : k +k = * \/ k = # ----------------- :: Id G |-name x_t ok @@ -147,6 +157,7 @@ defn G |- bnd n ok :: :: lintBinder :: 'Binding_' by G |-ty t : k +k = * \/ k = # --------------------------------- :: Id G |-bnd x_t ok @@ -154,125 +165,169 @@ G |-ki k ok ---------------------------------------- :: TyVar G |-bnd alpha_k ok -defn G |- co g : t1 ~ R k t2 :: :: lintCoercion :: 'Co_' +defn G |- co g : t1 k1 ~ R k2 t2 :: :: lintCoercion :: 'Co_' {{ com Coercion typing, \coderef{coreSyn/CoreLint.lhs}{lintCoercion} }} - {{ tex [[G]] \labeledjudge{co} [[g]] : [[t1]] \mathop{\sim_{[[R]]}^{[[k]]} } [[t2]] }} + {{ tex [[G]] \labeledjudge{co} [[g]] : [[t1]] \mathop{ {}^{[[k1]]} {\sim}_{[[R]]}^{[[k2]]} } [[t2]] }} by G |-ty t : k ---------------------- :: Refl -G |-co <t>_R : t ~R k t +G |-co <t>_R : t k~R k t -G |-co g1 : s1 ~R k1 t1 -G |-co g2 : s2 ~R k2 t2 +G |-co g1 : s1 k1~R k'1 t1 +G |-co g2 : s2 k2~R k'2 t2 G |-arrow k1 -> k2 : k +G |-arrow k'1 -> k'2 : k' ------------------------- :: TyConAppCoFunTy -G |-co (->)_R g1 g2 : (s1 -> s2) ~R k (t1 -> t2) +G |-co (->)_R g1 g2 : (s1 -> s2) k~R k' (t1 -> t2) T /= (->) </ Ri // i /> = take(length </ gi // i />, tyConRolesX R T) -</ G |-co gi : si ~Ri ki ti // i /> -G |-app </ (si : ki) // i /> : tyConKind T ~> k +</ G |-co gi : si k'i~Ri ki ti // i /> +G |-app </ (si : k'i) // i /> : tyConKind T ~> k' +G |-app </ (ti : ki) // i /> : tyConKind T ~> k --------------------------------- :: TyConAppCo -G |-co T_R </ gi // i /> : T </ si // i /> ~R k T </ ti // i /> +G |-co T_R </ gi // i /> : T </ si // i /> k'~R k T </ ti // i /> -G |-co g1 : s1 ~R k1 t1 -G |-co g2 : s2 ~Nom k2 t2 -G |-app (s2 : k2) : k1 ~> k +G |-co g1 : s1 k1~R k2 s2 +G |-co g2 : t1 k1'~Nom k2' t2 +G |-app (t1 : k1') : k1 ~> k3 +G |-app (t2 : k2') : k2 ~> k4 --------------------- :: AppCo -G |-co g1 g2 : (s1 s2) ~R k (t1 t2) +G |-co g1 g2 : (s1 t1) k3~R k4 (s2 t2) -G |-co g1 : s1 ~Ph k1 t1 -G |-co g2 : s2 ~Ph k2 t2 -G |-app (s2 : k2) : k1 ~> k +G |-co g1 : s1 k1 ~Ph k2 s2 +G |-co g2 : t1 k1' ~Ph k2' t2 +G |-app (t1 : k1') : k1 ~> k3 +G |-app (t2 : k2') : k2 ~> k4 --------------------- :: AppCoPhantom -G |-co g1 g2 : (s1 s2) ~Ph k (t1 t2) - -G |-ki k1 ok -G, z_k1 |-co g : s ~R k2 t ---------------------------- :: ForAllCo -G |-co forall z_k1. g : (forall z_k1.s) ~R k2 (forall z_k1.t) +G |-co g1 g2 : (s1 t1) k3~Ph k4 (s2 t2) -z_(t ~#BOX t) elt G ------------------------ :: CoVarCoBox -G |-co z_(t ~#BOX t) : t ~Nom BOX t +G |-co h : k1 *~Nom * k2 +G, z_k1 |-co g : t1 k3~R k4 t2 +------------------------------------------------------------------ :: ForAllCo +G |-co forall z:h. g : (forall z_k1. t1) k3~R k4 (forall z_k2. (t2[z |-> z_k2 |> sym h])) -z_(s ~#k t) elt G -k /= BOX +z_phi elt G +phi = t1 k1~#k2 t2 ----------------------- :: CoVarCoNom -G |-co z_(s ~#k t) : s ~Nom k t +G |-co z_phi : t1 k1 ~Nom k2 t2 -z_(s ~R#k t) elt G -k /= BOX ------------------------ :: CoVarCoRepr -G |-co z_(s ~R#k t) : s ~Rep k t +z_phi elt G +phi = t1 k1 ~Rep# k2 t2 +--------------------- :: CoVarCoRepr +G |-co z_phi : t1 k1 ~Rep k2 t2 +G |-co h : k1 *~Nom * k2 G |-ty t1 : k1 G |-ty t2 : k2 -R <= Ph \/ not (k1 <: OpenKind) \/ not (k2 <: OpenKind) \/ compatibleUnBoxedTys t1 t2 ------------------------------------------------------------------------- :: UnivCo -G |-co t1 ==>!_R t2 : t1 ~R k2 t2 +(R <= Ph \/ not (classifiesTypeWithValues k1)) \\/ (not (classifiesTypeWithValues k2) \/ compatibleUnBoxedTys t1 t2) +------------------------------------------------------ :: UnivCoUnsafe +G |-co UnsafeCoerceProv <t1, t2>_R^(h) : t1 k1~R k2 t2 + +G |-co h : k1 *~Nom * k2 +G |-ty t1 : k1 +G |-ty t2 : k2 +-------------------------------------------------- :: UnivCoPhantom +G |-co PhantomProv <t1,t2>_Ph^(h) : t1 k1~Ph k2 t2 + +G |-co h : phi1 *~Nom * phi2 +G |-ty g1 : phi1 +G |-ty g2 : phi2 +-------------------------------------------------- :: UnivCoProofIrrel +G |-co ProofIrrelProv <g1,g2>_R^(h) : g1 phi1~R phi2 g2 -G |-co g : t1 ~R k t2 +G |-co g : t1 k1~R k2 t2 ------------------------- :: SymCo -G |-co sym g : t2 ~R k t1 +G |-co sym g : t2 k2~R k1 t1 -G |-co g1 : t1 ~R k t2 -G |-co g2 : t2 ~R k t3 +G |-co g1 : t1 k1~R k2 t2 +G |-co g2 : t2 k2~R k3 t3 ----------------------- :: TransCo -G |-co g1 ; g2 : t1 ~R k t3 +G |-co g1 ; g2 : t1 k1~R k3 t3 -G |-co g : (T </ sj // j />) ~R k (T </ tj // j />) +G |-co g : (T </ sj // j />) k1~R k1' (T </ tj // j />) length </ sj // j /> = length </ tj // j /> i < length </ sj // j /> -G |-ty si : k +G |-ty si : k2 +G |-ty ti : k2' +not (si is_a_coercion) +not (ti is_a_coercion) R' = (tyConRolesX R T)[i] ----------------------- :: NthCo -G |-co nth i g : si ~R' k ti +---------------------- :: NthCoTyCon +G |-co nth i g : si k2~R' k2' ti -G |-co g : (s1 s2) ~Nom k' (t1 t2) -G |-ty s1 : k +G |-co g : (forall z1_k1.t1) k3~R k4 (forall z2_k2.t2) +--------------------------- :: NthCoForAll +G |-co nth 0 g : k1 *~Nom * k2 + +G |-co g : (s1 s2) k~Nom k' (t1 t2) +G |-ty s1 : k1 +G |-ty t1 : k1' ----------------------- :: LRCoLeft -G |-co Left g : s1 ~Nom k t1 +G |-co Left g : s1 k1~Nom k1' t1 -G |-co g : (s1 s2) ~Nom k' (t1 t2) -G |-ty s2 : k +G |-co g : (s1 s2) k~Nom k' (t1 t2) +G |-ty s2 : k2 +G |-ty t2 : k2' +not (s2 is_a_coercion) +not (t2 is_a_coercion) ----------------------- :: LRCoRight -G |-co Right g : s2 ~Nom k t2 +G |-co Right g : s2 k2~Nom k2' t2 -G |-co g : forall m.s ~R k forall n.t -G |-ty t0 : k0 -m = z_k1 -k0 <: k1 +G |-co g : (forall z1_k1.t1) k3~R k4 (forall z2_k2.t2) +G |-co h : s1 k1~Nom k2 s2 --------------------- :: InstCo -G |-co g t0 : s[m |-> t0] ~R k t[n |-> t0] +G |-co g @ h : (t1[z1_k1 |-> s1]) k3~R k4 (t2[z2_k2 |-> s2]) C = T_R0 </ axBranchkk // kk /> 0 <= ind < length </ axBranchkk // kk /> forall </ ni_^^Ri // i />. (</ s1j // j /> ~> t1) = (</ axBranchkk // kk />)[ind] -</ G |-co gi : s'i ~Ri k'i t'i // i /> -</ substi @ // i /> = inits(</ [ ni |-> s'i ] // i />) -</ ni = zi_ki // i /> -</ k'i <: substi(ki) // i /> +G |-axk [ </ ni_Ri // i /> |-> </ gi // i /> ] ~> (subst1, subst2) +</ s2j = subst1(s1j) // j /> no_conflict(C, </ s2j // j />, ind, ind-1) -</ s2j = s1j </ [ni |-> s'i] // i/> // j /> -t2 = t1 </ [ni |-> t'i] // i /> -G |-ty t2 : k +t2 = subst2(t1) +s2 = T </ s2j // j /> +G |-ty s2 : k +G |-ty t2 : k' ------------------------------------------------------ :: AxiomInstCo -G |-co C ind </ gi // i /> : T </ s2j // j /> ~R0 k t2 +G |-co C ind </ gi // i /> : s2 k~R0 k' t2 + +G |-co g : t1 k1~R k2 t2 +G |-ty t1 |> h : k1' +---------------------------------- :: CoherenceCo +G |-co g |> h : t1 |> h k1'~R k2 t2 + +G |-co g : t1 k1~R k2 t2 +-------------------------- :: KindCo +G |-co kind g : k1 *~Nom * k2 -G |-co g : s ~Nom k t +G |-co g : s k' ~Nom k t ------------------------- :: SubCo -G |-co sub g : s ~Rep k t +G |-co sub g : s k' ~Rep k t mu = M(i, </ Rj // j />, R') </ G |-ty ti : ki // i /> -</ G |-co gj : sj ~Rj k'j s'j // j /> +</ G |-co gj : sj k''j ~Rj k'j s'j // j /> Just (t'1, t'2) = coaxrProves mu </ ti // i /> </ (sj, s'j) // j /> G |-ty t'1 : k0 -G |-ty t'2 : k0 +G |-ty t'2 : k0' --------------------------------------------------------------------- :: AxiomRuleCo -G |-co mu </ ti // i /> </ gj // j /> : t'1 ~R' k0 t'2 +G |-co mu </ ti // i /> $ </ gj // j /> : t'1 k0 ~R' k0' t'2 + +defn G |- axk [ namesroles |-> gs ] ~> ( subst1 , subst2 ) :: :: check_ki :: 'AxiomKind_' + {{ com Axiom argument kinding, \coderef{coreSyn/CoreLint.lhs}{check\_ki} }} + {{ tex [[G]] \labeledjudge{axk} [ [[namesroles]] [[|->]] [[gs]] ] [[~>]] ([[subst1]], [[subst2]]) }} +by + +--------------------------------------- :: Empty +G |-axk [empty |-> empty] ~> (empty, empty) + +G |-axk [namesroles |-> gs] ~> (subst1, subst2) +n = z_k +G |-co g0 : t1 {subst1(k)}~R subst2(k) t2 +----------------------------- :: Arg +G |-axk [ namesroles, n_R |-> gs, g0 ] ~> (subst1 [n |-> t1], subst2 [n |-> t2]) defn validRoles T :: :: checkValidRoles :: 'Cvr_' {{ com Type constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{checkValidRoles} }} @@ -288,7 +343,7 @@ defn validDcRoles </ Raa // aa /> K :: :: check_dc_roles :: 'Cdr_' {{ com Data constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{check\_dc\_roles} }} by -forall </ naa // aa />. forall </ mbb // bb />. </ tcc // cc /> @ -> T </ naa // aa /> = dataConRepType K +forall </ naa // aa />. forall </ mbb // bb />. </ tcc // cc /> $ -> T </ naa // aa /> = dataConRepType K </ </ naa : Raa // aa />, </ mbb : Nom // bb /> |- tcc : Rep // cc /> --------------------------------- :: Args validDcRoles </ Raa // aa /> K @@ -329,6 +384,13 @@ O |- forall n. t : R ------------------ :: LitTy O |- lit : R +O |- t : R +--------------- :: CastTy +O |- t |> g : R + +------------ :: CoercionTy +O |- g : Ph + defn R1 <= R2 :: :: ltRole :: 'Rlt_' {{ com Sub-role relation, \coderef{types/Coercion.lhs}{ltRole} }} {{ tex [[R1]] \leq [[R2]] }} @@ -348,8 +410,12 @@ defn G |- ki k ok :: :: lintKind :: 'K_' {{ tex [[G]] \labeledjudge{k} [[k]] [[ok]] }} by -G |-ty k : BOX --------------- :: Box +G |-ty k : * +-------------- :: Star +G |-ki k ok + +G |-ty k : # +-------------- :: Hash G |-ki k ok defn G |- ty t : k :: :: lintType :: 'Ty_' @@ -380,28 +446,36 @@ G |-app </ (ti : ki) // i /> : tyConKind T ~> k G |-ty T </ ti // i /> : k G |-ki k1 ok -G, z_k1 |-ty t : k2 +G, z_k1 |-ty t : TYPE s +not (z elt fv(s)) ------------------------ :: ForAllTy -G |-ty forall z_k1. t : k2 +G |-ty forall z_k1. t : TYPE s G |-tylit lit : k -------------- :: LitTy G |-ty lit : k -defn G |- subst n |-> t ok :: :: checkTyKind :: 'Subst_' - {{ com Substitution consistency, \coderef{coreSyn/CoreLint.lhs}{checkTyKind} }} +G |-ty t : k1 +G |-co g : k1 *~Nom * k2 +--------------------- :: CastTy +G |-ty t |> g : k2 + +G |-co g : t1 k1 ~Nom k2 t2 +-------------- :: CoercionTy_Nom +G |-ty g : t1 k1 ~# k2 t2 + +G |-co g : t1 k1 ~Rep k2 t2 +------------------- :: CoercionTy_Repr +G |-ty g : (~Rep#) k1 k2 t1 t2 + +defn G |- subst n |-> t ok :: :: lintTyKind :: 'Subst_' + {{ com Substitution consistency, \coderef{coreSyn/CoreLint.lhs}{lintTyKind} }} {{ tex [[G]] \labeledjudge{subst} [[n]] [[|->]] [[t]] [[ok]] }} by -G |-ki k ok ------------------------- :: Kind -G |-subst z_BOX |-> k ok - -k1 /= BOX -G |-ty t : k2 -k2 <: k1 +G |-ty t : k ---------------------- :: Type -G |-subst z_k1 |-> t ok +G |-subst z_k |-> t ok defn G ; s |- altern alt : t :: :: lintCoreAlt :: 'Alt_' {{ com Case alternative consistency, \coderef{coreSyn/CoreLint.lhs}{lintCoreAlt} }} @@ -453,8 +527,12 @@ G |-altbnd </ ni // i /> : t[beta_k' |-> alpha_k] ~> s ------------------------------------------------------ :: TyVar G |-altbnd alpha_k, </ ni // i /> : (forall beta_k'.t) ~> s +G |-altbnd </ ni // i /> : t[z_phi |-> c_phi] ~> s +------------------------------------------------------- :: IdCoercion +G |-altbnd c_phi, </ ni // i /> : (forall z_phi.t) ~> s + G |-altbnd </ ni // i /> : t2 ~> s ------------------------------------------------ :: Id +----------------------------------------------- :: IdTerm G |-altbnd x_t1, </ ni // i /> : (t1 -> t2) ~> s defn G |- arrow k1 -> k2 : k :: :: lintArrow :: 'Arrow_' @@ -462,11 +540,8 @@ defn G |- arrow k1 -> k2 : k :: :: lintArrow :: 'Arrow_' {{ tex [[G]] \labeledjudge{\rightarrow} [[k1]] [[->]] [[k2]] : [[k]] }} by -------------------------- :: Box -G |-arrow BOX -> k2 : BOX - -k1 elt { *, #, Constraint } -k2 elt { *, #, Constraint } +k1 elt { *, # } +k2 = TYPE s ------------------------- :: Kind G |-arrow k1 -> k2 : * @@ -478,37 +553,13 @@ by --------------------- :: Empty G |-app empty : k ~> k -k <: k1 G |-app </ (ti : ki) // i /> : k2 ~> k' ---------------------------------------------------- :: FunTy -G |-app (t : k), </ (ti : ki) // i /> : (k1 -> k2) ~> k' +G |-app (t : k1), </ (ti : ki) // i /> : (k1 -> k2) ~> k' -k <: k1 G |-app </ (ti : ki) // i /> : k2[z_k1 |-> t] ~> k' -------------------------------------------------------- :: ForAllTy -G |-app (t : k), </ (ti : ki) // i /> : (forall z_k1. k2) ~> k' - -defn k1 <: k2 :: :: isSubKind :: 'SubKind_' - {{ com Sub-kinding, \coderef{types/Kind.lhs}{isSubKind} }} -by - ------- :: Refl -k <: k - --------------------- :: UnliftedTypeKind -# <: OpenKind - -------------------- :: LiftedTypeKind -* <: OpenKind - ----------------------- :: Constraint -Constraint <: OpenKind - -------------------- :: ConstraintLifted -Constraint <: * - ------------------- :: LiftedConstraint -* <: Constraint +G |-app (t : k1), </ (ti : ki) // i /> : (forall z_k1. k2) ~> k' defn no_conflict ( C , </ sj // j /> , ind1 , ind2 ) :: :: check_no_conflict :: 'NoConflict_' {{ com \parbox{5in}{Branched axiom conflict checking, \coderef{types/OptCoercion.lhs}{checkAxInstCo} \\ and \coderef{types/FamInstEnv.lhs}{compatibleBranches} } }} diff --git a/docs/core-spec/CoreSyn.ott b/docs/core-spec/CoreSyn.ott index 247fd05ae3..f96666185e 100644 --- a/docs/core-spec/CoreSyn.ott +++ b/docs/core-spec/CoreSyn.ott @@ -10,17 +10,18 @@ embed {{ tex-preamble } \newcommand{\keyword}[1]{\textbf{#1} } \newcommand{\labeledjudge}[1]{\vdash_{\!\!\mathsf{#1} } } + \newcommand{\ctor}[1]{\texttt{#1}% +} }} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Metavariables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -metavar x ::= {{ com Term-level variable names }} +metavar x, c ::= {{ com Term-level variable names }} metavar alpha {{ tex \alpha }}, beta {{ tex \beta }} ::= {{ com Type-level variable names }} metavar N ::= {{ com Type-level constructor names }} -metavar K ::= {{ com Term-level data constructor names }} metavar M ::= {{ com Axiom rule names }} indexvar i, j, kk {{ tex k }}, aa {{ tex a }}, bb {{ tex b }}, cc {{ tex c }} ::= {{ com Indices to be used in lists }} @@ -38,9 +39,10 @@ z :: 'Name_' ::= {{ com Term or type name }} | alpha :: :: Type {{ com Type-level name }} | x :: :: Term {{ com Term-level name }} -n, m :: 'Var_' ::= {{ com Variable names, \coderef{basicTypes/Var.lhs}{Var} }} +n, m, aname {{ tex \alpha }}, xname {{ tex x }} :: 'Var_' ::= {{ com Variable names, \coderef{basicTypes/Var.lhs}{Var} }} | z _ t :: :: IdOrTyVar {{ com Name, labeled with type/kind }} {{ tex {[[z]]}^{[[t]]} }} + | z $ :: M :: NoSupScript {{ com Name without an explicit type/kind }} | K :: M :: DataCon {{ com Data constructor }} vars :: 'Vars_' ::= {{ com List of variables }} @@ -54,18 +56,18 @@ vars :: 'Vars_' ::= {{ com List of variables }} {{ tex [[vars1]] \cap [[vars2]] }} e, u :: 'Expr_' ::= {{ com Expressions, \coderef{coreSyn/CoreSyn.lhs}{Expr} }} - | n :: :: Var {{ com Variable }} - | lit :: :: Lit {{ com Literal }} - | e1 e2 :: :: App {{ com Application }} - | \ n . e :: :: Lam {{ com Abstraction }} - | let binding in e :: :: Let {{ com Variable binding }} - | case e as n return t of </ alti // | // i /> :: :: Case {{ com Pattern match }} - | e |> g :: :: Cast {{ com Cast }} - | e { tick } :: :: Tick {{ com Internal note }} + | n :: :: Var {{ com \ctor{Var}: Variable }} + | lit :: :: Lit {{ com \ctor{Lit}: Literal }} + | e1 e2 :: :: App {{ com \ctor{App}: Application }} + | \ n . e :: :: Lam {{ com \ctor{Lam}: Abstraction }} + | let binding in e :: :: Let {{ com \ctor{Let}: Variable binding }} + | case e as n return t of </ alti // | // i /> :: :: Case {{ com \ctor{Case}: Pattern match }} + | e |> g :: :: Cast {{ com \ctor{Cast}: Cast }} + | e { tick } :: :: Tick {{ com \ctor{Tick}: Internal note }} {{ tex {[[e]]}_{\{[[tick]]\} } }} - | t :: :: Type {{ com Type }} - | g :: :: Coercion {{ com Coercion }} - | e subst :: M :: Subst {{ com Substitution }} + | t :: :: Type {{ com \ctor{Type}: Type }} + | g :: :: Coercion {{ com \ctor{Coercion}: Coercion }} + | e subst :: M :: Subst {{ com Substitution }} | ( e ) :: M :: Parens {{ com Parenthesized expression }} | e </ ui // i /> :: M :: Apps {{ com Nested application }} | S ( n ) :: M :: Lookup {{ com Lookup in the runtime store }} @@ -73,8 +75,8 @@ e, u :: 'Expr_' ::= {{ com Expressions, \coderef{coreSyn/CoreSyn.lhs}{Expr} }} {{ tex \qquad \\ \multicolumn{1}{r}{[[e]]} }} binding :: 'Bind_' ::= {{ com Let-bindings, \coderef{coreSyn/CoreSyn.lhs}{Bind} }} - | n = e :: :: NonRec {{ com Non-recursive binding }} - | rec </ ni = ei // ;; // i /> :: :: Rec {{ com Recursive binding }} + | n = e :: :: NonRec {{ com \ctor{NonRec}: Non-recursive binding }} + | rec </ ni = ei // ;; // i /> :: :: Rec {{ com \ctor{Rec}: Recursive binding }} alt :: 'Alt_' ::= {{ com Case alternative, \coderef{coreSyn/CoreSyn.lhs}{Alt} }} | Kp </ ni // i /> -> e :: :: Alt {{ com Constructor applied to fresh names }} @@ -82,68 +84,84 @@ alt :: 'Alt_' ::= {{ com Case alternative, \coderef{coreSyn/CoreSyn.lhs}{Alt} }} tick :: 'Tickish_' ::= {{ com Internal notes, \coderef{coreSyn/CoreSyn.lhs}{Tickish} }} Kp {{ tex \mathbb{K} }} :: 'AltCon_' ::= {{ com Constructors used in patterns, \coderef{coreSyn/CoreSyn.lhs}{AltCon} }} - | K :: :: DataAlt {{ com Data constructor }} - | lit :: :: LitAlt {{ com Literal (such as an integer or character) }} - | _ :: :: DEFAULT {{ com Wildcard }} + | K :: :: DataAlt {{ com \ctor{DataAlt}: Data constructor }} + | lit :: :: LitAlt {{ com \ctor{LitAlt}: Literal (such as an integer or character) }} + | _ :: :: DEFAULT {{ com \ctor{DEFAULT}: Wildcard }} program :: 'CoreProgram_' ::= {{ com A System FC program, \coderef{coreSyn/CoreSyn.lhs}{CoreProgram} }} | </ bindingi // i /> :: :: CoreProgram {{ com List of bindings }} %% TYPES %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -t {{ tex \tau }}, k {{ tex \kappa }}, s {{ tex \sigma }} - :: 'Type_' ::= {{ com Types/kinds, \coderef{types/TypeRep.lhs}{Type} }} - | n :: :: TyVarTy {{ com Variable }} - | t1 t2 :: :: AppTy {{ com Application }} - | T </ ti // i /> :: :: TyConApp {{ com Application of type constructor }} - | t1 -> t2 :: :: FunTy {{ com Function }} - | forall n . t :: :: ForAllTy {{ com Polymorphism }} - | lit :: :: LitTy {{ com Type-level literal }} +t {{ tex \tau }}, k {{ tex \kappa }}, s {{ tex \sigma }}, phi {{ tex \phi }} + :: 'Type_' ::= {{ com Types/kinds, \coderef{types/TyCoRep.lhs}{Type} }} + | n :: :: TyVarTy {{ com \ctor{TyVarTy}: Variable }} + | t1 t2 :: :: AppTy {{ com \ctor{AppTy}: Application }} + | T </ ti // i /> :: :: TyConApp {{ com \ctor{TyConApp}: Application of type constructor }} + | t1 -> t2 :: :: FunTy {{ com \ctor{ForAllTy (Anon ...) ...}: Function }} + | forall n . t :: :: ForAllTy {{ com \ctor{ForAllTy (Named ...) ...}: Type and coercion polymorphism }} + | lit :: :: LitTy {{ com \ctor{LitTy}: Type-level literal }} + | t |> g :: :: CastTy {{ com \ctor{CastTy}: Kind cast }} + | g :: :: CoercionTy {{ com \ctor{CoercionTy}: Coercion used in type }} | tyConKind T :: M :: tyConKind {{ com \coderef{types/TyCon.lhs}{tyConKind} }} - | t1 ~# k t2 :: M :: unliftedEq {{ com Metanotation for coercion types }} - {{ tex [[t1]] \mathop{\sim_{\#}^{[[k]]} } [[t2]] }} - | t1 ~R# k t2 :: M :: unliftedREq {{ com Metanotation for coercion types }} - {{ tex [[t1]] \mathop{\sim_{\mathsf{R}\#}^{[[k]]} } [[t2]] }} - | literalType t :: M :: literalType {{ com \coderef{basicTypes/Literal.lhs}{literalType} }} + | t1 k1 ~# k2 t2 :: M :: unliftedEq {{ com Metanotation for coercion types }} + {{ tex [[t1]] \mathop{ {}^{[[k1]]}\!\! \sim_{\#}^{[[k2]]} } [[t2]] }} + | t1 k1 ~Rep# k2 t2 :: M :: unliftedREq {{ com Metanotation for coercion types }} + {{ tex [[t1]] \mathop{ {}^{[[k1]]}\!\! \sim_{\mathsf{R}\#}^{[[k2]]} } [[t2]] }} + | literalType lit :: M :: literalType {{ com \coderef{basicTypes/Literal.lhs}{literalType} }} | ( t ) :: M :: parens {{ com Parentheses }} + | { t } :: M :: IParens {{ com Invisible parentheses }} + {{ tex [[t]] }} | t [ n |-> s ] :: M :: TySubst {{ com Type substitution }} | subst ( k ) :: M :: TySubstList {{ com Type substitution list }} | t subst :: M :: TySubstListPost {{ com Type substitution list }} | dataConRepType K :: M :: dataConRepType {{ com Type of DataCon }} | forall </ ni // , // i /> . t :: M :: ForAllTys {{ com Nested polymorphism }} - | </ ti // i /> @ -> t' :: M :: FunTys {{ com Nested arrows }} + | </ ti // i /> $ -> t' :: M :: FunTys {{ com Nested arrows }} %% COERCIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -g {{ tex \gamma }} :: 'Coercion_' ::= {{ com Coercions, \coderef{types/Coercion.lhs}{Coercion} }} - | < t > _ R :: :: Refl {{ com Reflexivity }} +g {{ tex \gamma }}, h {{ tex \eta }} :: 'Coercion_' ::= {{ com Coercions, \coderef{types/TyCoRep.lhs}{Coercion} }} + | < t > _ R :: :: Refl {{ com \ctor{Refl}: Reflexivity }} {{ tex {\langle [[t]] \rangle}_{[[R]]} }} - | T RA </ gi // i /> :: :: TyConAppCo {{ com Type constructor application }} - | g1 g2 :: :: AppCo {{ com Application }} - | forall n . g :: :: ForAllCo {{ com Polymorphism }} - | n :: :: CoVarCo {{ com Variable }} - | C ind </ gj // j /> :: :: AxiomInstCo {{ com Axiom application }} - | t1 ==>! RA t2 :: :: UnivCo {{ com Universal coercion }} - | sym g :: :: SymCo {{ com Symmetry }} - | g1 ; g2 :: :: TransCo {{ com Transitivity }} - | mu </ ti // i /> </ gj // j /> - :: :: AxiomRuleCo {{ com Axiom-rule application (for type-nats) }} - | nth I g :: :: NthCo {{ com Projection (0-indexed) }} - {{ tex \textsf{nth}_{[[I]]}\,[[g]] }} - | LorR g :: :: LRCo {{ com Left/right projection }} - | g t :: :: InstCo {{ com Type application }} - | sub g :: :: SubCo {{ com Sub-role --- convert nominal to representational }} + | T RA </ gi // i /> :: :: TyConAppCo {{ com \ctor{TyConAppCo}: Type constructor application }} + | g1 g2 :: :: AppCo {{ com \ctor{AppCo}: Application }} + | forall z : h . g :: :: ForAllCo {{ com \ctor{ForAllCo}: Polymorphism }} + {{ tex [[forall]] [[z]]{:}[[h]].[[g]] }} + | n :: :: CoVarCo {{ com \ctor{CoVarCo}: Variable }} + | C ind </ gi // i /> :: :: AxiomInstCo {{ com \ctor{AxiomInstCo}: Axiom application }} + | prov < t1 , t2 > _ R ^ ( h ) :: :: UnivCo {{ com \ctor{UnivCo}: Universal coercion }} + {{ tex {}_{[[prov]]}{\langle [[t1]], [[t2]] \rangle}_{[[R]]}^{[[h]]} }} + | sym g :: :: SymCo {{ com \ctor{SymCo}: Symmetry }} + | g1 ; g2 :: :: TransCo {{ com \ctor{TransCo}: Transitivity }} + | mu </ ti // i /> $ </ gj // j /> + :: :: AxiomRuleCo {{ com \ctor{AxiomRuleCo}: Axiom-rule application (for type-nats) }} + | nth I g :: :: NthCo {{ com \ctor{NthCo}: Projection (0-indexed) }} + {{ tex \textsf{nth}^{[[I]]}\,[[g]] }} + | LorR g :: :: LRCo {{ com \ctor{LRCo}: Left/right projection }} + | g @ h :: :: InstCo {{ com \ctor{InstCo}: Instantiation }} + | g |> h :: :: CoherenceCo {{ com \ctor{CoherenceCo}: Coherence }} + | kind g :: :: KindCo {{ com \ctor{KindCo}: Kind extraction }} + | sub g :: :: SubCo {{ com \ctor{SubCo}: Sub-role --- convert nominal to representational }} | ( g ) :: M :: Parens {{ com Parentheses }} - | t @ liftingsubst :: M :: Lifted {{ com Type lifted to coercion }} + | t $ liftingsubst :: M :: Lifted {{ com Type lifted to coercion }} + +prov :: 'UnivCoProvenance_' ::= {{ com \ctor{UnivCo} provenance, \coderef{types/TyCoRep.lhs}{UnivCoProvenance} }} + | UnsafeCoerceProv :: :: UnsafeCoerceProv {{ com From \texttt{unsafeCoerce\#} }} + {{ tex \mathsf{unsafe} }} + | PhantomProv :: :: PhantomProv {{ com From the need for a phantom coercion }} + {{ tex \mathsf{phant} }} + | ProofIrrelProv :: :: ProofIrrelProv {{ com From proof irrelevance }} + {{ tex \mathsf{irrel} }} -LorR :: 'LeftOrRight_' ::= {{ com left or right deconstructor, \coderef{types/Coercion.lhs}{LeftOrRight} }} - | Left :: :: CLeft {{ com Left projection }} - | Right :: :: CRight {{ com Right projection }} +LorR :: 'LeftOrRight_' ::= {{ com left or right deconstructor, \coderef{types/TyCoRep.lhs}{LeftOrRight} }} + | Left :: :: CLeft {{ com \ctor{CLeft}: Left projection }} + | Right :: :: CRight {{ com \ctor{CRight}: Right projection }} C :: 'CoAxiom_' ::= {{ com Axioms, \coderef{types/TyCon.lhs}{CoAxiom} }} - | T RA </ axBranchi // ; // i /> :: :: CoAxiom {{ com Axiom }} - | ( C ) :: M :: Parens {{ com Parentheses }} + | T RA </ axBranchi // ; // i /> :: :: CoAxiom {{ com \ctor{CoAxiom}: Axiom }} + | ( C ) :: M :: Parens {{ com Parentheses }} R {{ tex \rho }} :: 'Role_' ::= {{ com Roles, \coderef{types/CoAxiom.lhs}{Role} }} | Nom :: :: Nominal {{ com Nominal }} @@ -155,8 +173,8 @@ R {{ tex \rho }} :: 'Role_' ::= {{ com Roles, \coderef{types/CoAxiom.lhs}{Role} | role_list [ i ] :: M :: RoleListIndex {{ com Look up in list }} axBranch, b :: 'CoAxBranch_' ::= {{ com Axiom branches, \coderef{types/TyCon.lhs}{CoAxBranch} }} - | forall </ ni RAi // i /> . ( </ tj // j /> ~> s ) :: :: CoAxBranch {{ com Axiom branch }} - | ( </ axBranchi // i /> ) [ ind ] :: M :: lookup {{ com List lookup }} + | forall </ ni RAi // i /> . ( </ tj // j /> ~> s ) :: :: CoAxBranch {{ com \ctor{CoAxBranch}: Axiom branch }} + | ( </ axBranchi // i /> ) [ ind ] :: M :: lookup {{ com List lookup }} mu {{ tex \mu }} :: 'CoAxiomRule_' ::= {{ com CoAxiomRules, \coderef{types/CoAxiom.lhs}{CoAxiomRule} }} | M ( I , role_list , R' ) :: :: CoAxiomRule {{ com Named rule, with parameter info }} @@ -165,25 +183,29 @@ mu {{ tex \mu }} :: 'CoAxiomRule_' ::= {{ com CoAxiomRules, \coderef{types/CoAxi %% TYCONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% T :: 'TyCon_' ::= {{ com Type constructors, \coderef{types/TyCon.lhs}{TyCon} }} - | ( -> ) :: :: FunTyCon {{ com Arrow }} + | ( -> ) :: :: FunTyCon {{ com \ctor{FunTyCon}: Arrow }} % the following also includes TupleTyCon, SynTyCon - | N _ k :: :: AlgTyCon {{ com Named tycon: algebraic, tuples, and synonyms }} + | N _ k :: :: AlgTyCon {{ com \ctor{AlgTyCon}, \ctor{TupleTyCon}, \ctor{SynTyCon}: algebraic, tuples, families, and synonyms }} {{ tex {[[N]]}^{[[k]]} }} - | H :: :: PrimTyCon {{ com Primitive tycon }} - | ' K :: :: PromotedDataCon {{ com Promoted data constructor }} - | ' T :: :: PromotedTyCon {{ com Promoted type constructor }} + | H :: :: PrimTyCon {{ com \ctor{PrimTyCon}: Primitive tycon }} + | ' K :: :: PromotedDataCon {{ com \ctor{PromotedDataCon}: Promoted data constructor }} | dataConTyCon K :: M :: dataConTyCon {{ com TyCon extracted from DataCon }} H :: 'PrimTyCon_' ::= {{ com Primitive type constructors, \coderef{prelude/TysPrim.lhs}{} }} | Int# :: :: intPrimTyCon {{ com Unboxed Int (\texttt{intPrimTyCon}) }} | ( ~# ) :: :: eqPrimTyCon {{ com Unboxed equality (\texttt{eqPrimTyCon}) }} - | ( ~R# ) :: :: eqReprPrimTyCon {{ com Unboxed representational equality (\texttt{eqReprPrimTyCon}) }} - | BOX :: :: superKindTyCon {{ com Sort of kinds (\texttt{superKindTyCon}) }} + | ( ~Rep# ) :: :: eqReprPrimTyCon {{ com Unboxed representational equality (\texttt{eqReprPrimTyCon}) }} | * :: :: liftedTypeKindTyCon {{ com Kind of lifted types (\texttt{liftedTypeKindTyCon}) }} | # :: :: unliftedTypeKindTyCon {{ com Kind of unlifted types (\texttt{unliftedTypeKindTyCon}) }} | OpenKind :: :: openTypeKindTyCon {{ com Either $*$ or $\#$ (\texttt{openTypeKindTyCon}) }} | Constraint :: :: constraintTyCon {{ com Constraint (\texttt{constraintTyCon}) }} + | TYPE :: :: TYPE {{ com TYPE (\texttt{tYPETyCon}) }} + | Levity :: :: Levity {{ com Levity (\texttt{LevityTyCon}) }} + +K :: 'DataCon_' ::= {{ com Data constructors, \coderef{basicTypes/DataCon.lhs}{DataCon} }} + | Lifted :: :: Lifted {{ com \ctor{Lifted}, a lifted type }} + | Unlifted :: :: Unlifted {{ com \ctor{Unlifted}, an unlifted type }} %% CONTEXTS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -213,7 +235,9 @@ kinded_types {{ tex \overline{(\sigma_i : \kappa_i)}^i }} :: 'Kinded_Types_' ::= subst :: 'Subst_' ::= {{ com List of substitutions }} | [ n |-> t ] :: :: TyMapping | [ n |-> e ] :: :: TmMapping + | [ z |-> t ] :: :: TyMapping_Raw | </ substi // i /> :: :: List + | empty :: M :: Empty liftingsubst :: 'LiftSubst_' ::= {{ com List of lifting substitutions }} | [ n |-> g ] :: :: Mapping @@ -231,12 +255,27 @@ ind, I {{ tex i }} :: 'Ind_' ::= {{ com Indices, numbers }} | 1 :: M :: one | 2 :: M :: two -type_list :: 'TypeList_' ::= {{ com List of types }} - | </ si // i /> :: :: List +types :: 'Types_' ::= {{ com List of types }} + | </ ti // i /> :: :: List + +names {{ tex \overline{n_i}^i }} :: 'Names_' ::= {{ com List of names }} + | </ ni // , // i /> :: :: List + | empty :: M :: Empty + | names , n :: M :: Snoc + +namesroles {{ tex \overline{n_i \!\! {}_{\rho_i} }^i }} :: 'NamesRoles_' ::= {{ com List of names, annotated with roles }} + | </ ni RAi // , // i /> :: :: List + | empty :: M :: Empty + | namesroles , n RA :: M :: Snoc + +gs {{ tex \overline{\gamma} }} :: 'Cos_' ::= {{ com List of coercions }} + | </ gi // , // i /> :: :: List + | empty :: M :: Empty + | gs , g :: M :: Snoc -RA {{ tex {\!\!\!{}_{\rho} } }} :: 'RoleAnnot_' ::= {{ com Role annotation }} +RA {{ tex {\!\!{}_{\rho} } }} :: 'RoleAnnot_' ::= {{ com Role annotation }} | _ R :: M :: annotation - {{ tex {\!\!\!{}_{[[R]]} } }} + {{ tex {\!\!{}_{[[R]]} } }} | _ ^^ R :: M :: spaced_annotation {{ tex {}_{[[R]]} }} @@ -271,10 +310,9 @@ terminals :: 'terminals_' ::= | Left :: :: Left {{ tex \textsf{left} }} | Right :: :: Right {{ tex \textsf{right} }} | _ :: :: wildcard {{ tex \text{\textvisiblespace} }} - | BOX :: :: BOX {{ tex \Box }} | Int# :: :: int_hash {{ tex {\textsf{Int} }_{\#} }} | ~# :: :: eq_hash {{ tex \mathop{ {\sim}_{\#} } }} - | ~R# :: :: eq_repr_hash {{ tex \mathop{ {\sim}_{\mathsf{R}\#} } }} + | ~Rep# :: :: eq_repr_hash {{ tex \mathop{ {\sim}_{\mathsf{R}\#} } }} | OpenKind :: :: OpenKind {{ tex \textsf{OpenKind} }} | ok :: :: ok {{ tex \textsf{ ok} }} | no_duplicates :: :: no_duplicates {{ tex \textsf{no\_duplicates } }} @@ -291,21 +329,30 @@ terminals :: 'terminals_' ::= | literalType :: :: literalType {{ tex \textsf{literalType} }} | |-> :: :: mapsto {{ tex \mapsto }} | <- :: :: assignment {{ tex \leftarrow }} - | @ :: :: marker {{ tex }} + | $ :: :: marker {{ tex }} | inits :: :: inits {{ tex \textsf{inits} }} | ~> :: :: squigarrow {{ tex \rightsquigarrow }} | tyConKind :: :: tyConKind {{ tex \mathop{\textsf{tyConKind} } }} | empty :: :: empty {{ tex \cdot }} | length :: :: length {{ tex \mathsf{length} }} - | <: :: :: subkind {{ tex \mathop{ {<} {:}\, } }} | ~ :: :: eq {{ tex \sim }} | tyConArity :: :: tyConArity {{ tex \textsf{tyConArity} }} | dataConTyCon :: :: dataConTyCon {{ tex \textsf{dataConTyCon} }} | dataConRepType :: :: dataConRepType {{ tex \textsf{dataConRepType} }} | isNewTyCon :: :: isNewTyCon {{ tex \textsf{isNewTyCon} }} | Constraint :: :: Constraint {{ tex \textsf{Constraint} }} + | TYPE :: :: TYPE {{ tex \textsf{TYPE} }} + | Levity :: :: Levity {{ tex \textsf{Levity} }} + | Lifted :: :: Lifted {{ tex \textsf{Lifted} }} + | Unlifted :: :: Unlifted {{ tex \textsf{Unlifted} }} | no_conflict :: :: no_conflict {{ tex \textsf{no\_conflict} }} | apart :: :: apart {{ tex \textsf{apart} }} + | kind :: :: kind {{ tex \textsf{kind} }} + | kapp :: :: kapp {{ tex \textsf{kapp} }} + | sub :: :: sub {{ tex \textsf{sub} }} + | # :: :: free {{ tex \mathop{ \# } }} + | BOX :: :: BOX {{ tex \square }} + | * :: :: star {{ tex \star }} | unify :: :: unify {{ tex \textsf{unify} }} | tyConRolesX :: :: tyConRolesX {{ tex \textsf{tyConRolesX} }} | tyConRoles :: :: tyConRoles {{ tex \textsf{tyConRoles} }} @@ -318,6 +365,7 @@ terminals :: 'terminals_' ::= | coaxrProves :: :: coaxrProves {{ tex \textsf{coaxrProves} }} | Just :: :: Just {{ tex \textsf{Just} }} | \\ :: :: newline {{ tex \\ }} + | classifiesTypeWithValues :: :: ctwv {{ tex \textsf{classifiesTypeWithValues} }} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Formulae %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -341,11 +389,15 @@ formula :: 'formula_' ::= | compatibleUnBoxedTys t1 t2 :: :: compatibleUnBoxedTys | formula1 /\ formula2 :: :: and | formula1 \/ formula2 :: :: or + | ( formula1 ) \\/ ( formula2 ) :: :: newline + {{ tex \begin{array}{@{}l@{}% +}[[formula1]] \vee \\ \multicolumn{1}{@{}r@{}% +}{\quad [[formula2]]} \end{array} }} | ( formula ) :: :: parens | n elt G :: :: context_inclusion | vars1 = vars2 :: :: vars_rewrite - | </ Gi @ // i /> = inits ( </ nj // j /> ) :: :: context_folding - | </ substi @ // i /> = inits ( </ [ nj |-> tj ] // j /> ) :: :: subst_folding + | </ Gi $ // i /> = inits ( </ nj // j /> ) :: :: context_folding + | </ substi $ // i /> = inits ( </ [ nj |-> tj ] // j /> ) :: :: subst_folding | ind1 = ind2 :: :: eq_ind | ind1 < ind2 :: :: lt | G |- tylit lit : k :: :: lintTyLit @@ -354,6 +406,9 @@ formula :: 'formula_' ::= | k1 elt { </ ki // , // i /> } :: :: kind_elt | e is_a_type :: :: is_a_type {{ tex \exists \tau \text{ s.t.~} [[e]] = \tau }} + | t is_a_coercion_type :: :: is_a_coercion_type + {{ tex \exists \tau_1, \tau_2, \kappa_1, \kappa_2 \text{ s.t.~} [[t]] = + \tau_1 \mathop{ {}^{\kappa_1} {\sim}_{\#}^{\kappa_2} } \tau_2 }} | e is_a_coercion :: :: is_a_coercion {{ tex \exists \gamma \text{ s.t.~} [[e]] = \gamma }} | t is_a_prop :: :: is_a_prop @@ -378,7 +433,9 @@ formula :: 'formula_' ::= | t = coercionKind g :: :: coercionKind | Just ( t1 , t2 ) = coaxrProves mu </ si // i /> </ ( s'j , s''j ) // j /> :: :: coaxrProves - + | mu1 = mu2 :: :: mu_rewrite + | classifiesTypeWithValues k :: :: classifies_type_with_values + | z elt vars :: :: in_vars %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Subrules and Parsing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -390,13 +447,11 @@ TyCon_FunTyCon right Type_AppTy TyCon_PrimTyCon right Type_AppTy TyCon_AlgTyCon right Type_AppTy TyCon_PromotedDataCon right Type_AppTy -TyCon_PromotedTyCon right Type_AppTy TyCon_FunTyCon right Coercion_AppCo TyCon_PrimTyCon right Coercion_AppCo TyCon_AlgTyCon right Coercion_AppCo TyCon_PromotedDataCon right Coercion_AppCo -TyCon_PromotedTyCon right Coercion_AppCo Subst_TyMapping <= Type_TySubstList Subst_TmMapping <= Type_TySubstList @@ -409,4 +464,12 @@ Expr_Type <= formula_e_rewrite Coercion_TyConAppCo <= Coercion_AppCo +Coercion_TyConAppCo <= Type_CoercionTy +Coercion_CoVarCo <= Type_CoercionTy + +Type_unliftedEq left Var_IdOrTyVar + Expr_Coercion <= Subst_TmMapping + +Type_CastTy <= Var_IdOrTyVar + diff --git a/docs/core-spec/Makefile b/docs/core-spec/Makefile index 402f9dbe4e..de0cac6e24 100644 --- a/docs/core-spec/Makefile +++ b/docs/core-spec/Makefile @@ -15,4 +15,4 @@ $(OTT_TEX): $(OTT_FILES) .PHONY: clean clean: - rm -f $(TARGET).pdf $(TARGET).tex $(OTT_TEX) *.aux *.fdb_latexmk *.log + rm -f $(TARGET).pdf $(TARGET).tex $(OTT_TEX) *.aux *.fdb_latexmk *.log *.fls diff --git a/docs/core-spec/OpSem.ott b/docs/core-spec/OpSem.ott index ed59e9538b..db8ce1cf5e 100644 --- a/docs/core-spec/OpSem.ott +++ b/docs/core-spec/OpSem.ott @@ -79,9 +79,9 @@ no other case matches ------------------------------------------------------------ :: MatchDefault S |- case e as n return t of </ alti // i /> --> u[n |-> e] -T </ taa // aa /> ~#k T </ t'aa // aa /> = coercionKind g -forall </ alphaaa_kaa // aa />. forall </ betabb_k'bb // bb />. </ t1cc // cc /> @-> T </ alphaaa_kaa // aa /> = dataConRepType K -</ e'cc = ecc |> (t1cc @ </ [alphaaa_kaa |-> nth aa g] // aa /> </ [betabb_k'bb |-> <sbb>_Nom] // bb />) // cc /> +T </ taa // aa /> k'~#k T </ t'aa // aa /> = coercionKind g +forall </ alphaaa_kaa // aa />. forall </ betabb_k'bb // bb />. </ t1cc // cc /> $ -> T </ alphaaa_kaa // aa /> = dataConRepType K +</ e'cc = ecc |> (t1cc $ </ [alphaaa_kaa |-> nth aa g] // aa /> </ [betabb_k'bb |-> <sbb>_Nom] // bb />) // cc /> --------------------------- :: CasePush S |- case (K </ taa // aa /> </ sbb // bb /> </ ecc // cc />) |> g as n return t2 of </ alti // i /> --> \\ case K </ t'aa // aa /> </ sbb // bb /> </ e'cc // cc /> as n return t2 of </ alti // i /> diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng index 7830e890e1..0eec2eb38c 100644 --- a/docs/core-spec/core-spec.mng +++ b/docs/core-spec/core-spec.mng @@ -30,7 +30,7 @@ System FC, as implemented in GHC\footnote{This document was originally prepared by Richard Eisenberg (\texttt{eir@cis.upenn.edu}), but it should be maintained by anyone who edits the functions or data structures mentioned in this file. Please feel free to contact Richard for more information.}\\ -\Large 23 April 2015 +\Large 23 October, 2015 \end{center} \section{Introduction} @@ -89,6 +89,8 @@ variables: \ottn } +We sometimes omit the type/kind annotation to a variable when it is obvious from context. + \subsection{Expressions} The datatype that represents expressions: @@ -106,6 +108,9 @@ is ok-for-speculation. See \verb|#let_app_invariant#| in \ghcfile{coreSyn/CoreSy \item The $[[_]]$ case for a $[[case]]$ must come first. \item The list of case alternatives must be exhaustive. \item Types and coercions can only appear on the right-hand-side of an application. +\item The $[[t]]$ form of an expression must not then turn out to be a coercion. +In other words, the payload inside of a \texttt{Type} constructor must not turn out +to be built with \texttt{CoercionTy}. \end{itemize} Bindings for $[[let]]$ statements: @@ -132,19 +137,37 @@ A program is just a list of bindings: \gram{\ottt} +\ctor{ForAllTy}s are represented in two different ways, depending on whether +the \ctor{ForAllTy} is anonymous (written $[[t1 -> t2]]$) or +named (written $[[forall n . t]]$). + There are some invariants on types: \begin{itemize} +\item The name used in a type must be a type-level name (\ctor{TyVar}). \item The type $[[t1]]$ in the form $[[t1 t2]]$ must not be a type constructor $[[T]]$. It should be another application or a type variable. \item The form $[[T </ ti // i /> ]]$ (\texttt{TyConApp}) does \emph{not} need to be saturated. \item A saturated application of $[[(->) t1 t2]]$ should be represented as $[[t1 -> t2]]$. This is a different point in the grammar, not just pretty-printing. -The constructor for a saturated $[[(->)]]$ is \texttt{FunTy}. +The constructor for a saturated $[[(->)]]$ is \texttt{ForAllTy}. \item A type-level literal is represented in GHC with a different datatype than a term-level literal, but we are ignoring this distinction here. +\item A coercion used as a type should appear only in the right-hand side of + an application. \end{itemize} +Note that the use of the $[[T </ ti // i />]]$ form and the $[[t1 -> t2]]$ form +are purely representational. The metatheory would remain the same if these forms +were removed in favor of $[[t1 t2]]$. Nevertheless, we keep all three forms in +this documentation to accurately reflect the implementation. + +The \texttt{Named} variant of a \texttt{Binder} (the first argument to a +\texttt{ForAllTy}) also tracks visibility of arguments. Visibility affects +only source Haskell, and is omitted from this presentation. + +We use the notation $[[t1 k1~#k2 t2]]$ to stand for $[[(~#) k1 k2 t1 t2]]$. + \subsection{Coercions} \gram{\ottg} @@ -156,12 +179,22 @@ Invariants on coercions: reflexive, use $[[T_R </ gi // i />]]$, never $[[<T>_R g1 g2]] \ldots$. \item The $[[T]]$ in $[[T_R </gi//i/>]]$ is never a type synonym, though it could be a type function. +\item Every non-reflexive coercion coerces between two distinct types. +\item The name in a coercion must be a term-level name (\ctor{Id}). +\item The contents of $[[<t>_R]]$ must not be a coercion. In other words, +the payload in a \texttt{Refl} must not be built with \texttt{CoercionTy}. \end{itemize} +The \texttt{UnivCo} constructor takes several arguments: the two types coerced +between, a coercion relating these types' kinds, a role for the universal coercion, +and a provenance. The provenance states what created the universal coercion: + +\gram{\ottprov} + Roles label what equality relation a coercion is a witness of. Nominal equality means that two types are identical (have the same name); representational equality means that two types have the same representation (introduced by newtypes); and -phantom equality includes all types. See \url{http://ghc.haskell.org/trac/ghc/wiki/Roles} +phantom equality includes all types. See \url{http://ghc.haskell.org/trac/ghc/wiki/Roles} and \url{http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf} for more background. \gram{\ottR} @@ -177,6 +210,9 @@ Axioms: \ottaxBranch } +The left-hand sides $[[ </ tj // j /> ]]$ of different branches of one axiom must +all have the same length. + The definition for $[[axBranch]]$ above does not include the list of incompatible branches (field \texttt{cab\_incomps} of \texttt{CoAxBranch}), as that would unduly clutter this presentation. Instead, as the list @@ -219,6 +255,21 @@ We include some representative primitive type constructors. There are many more \gram{\ottH} +Note that although GHC contains distinct type constructors $[[*]]$ +and $[[Constraint]]$, this formalism treats only $[[*]]$. These two type +constructors are considered wholly equivalent. In particular the function +\texttt{eqType} returns \texttt{True} when comparing $[[*]]$ and $[[Constraint]]$. +We need them both because they serve different functions in source Haskell. + +\paragraph{$[[TYPE]]$} +The type system is rooted at the special constant $[[TYPE]]$ and the +(quite normal) datatype \texttt{data Levity = Lifted | Unlifted}. +The type of $[[TYPE]]$ is $[[Levity -> TYPE 'Lifted]]$. The idea is that +$[[TYPE 'Lifted]]$ classifies lifted types and $[[TYPE 'Unlifted]]$ +classifies unlifted types. Indeed $[[*]]$ is just a plain old type +synonym for $[[TYPE 'Lifted]]$, and $[[#]]$ is just a plain old type +synonym for $[[TYPE 'Unlifted]]$. + \section{Contexts} The functions in \ghcfile{coreSyn/CoreLint.lhs} use the \texttt{LintM} monad. @@ -275,19 +326,13 @@ as for strictness and exportability. See the source code for further information \begin{itemize} \item Some explication of \ottdrulename{Tm\_LetRec} is helpful: The idea behind the -second premise ($[[</ G, G'i |-ty s'i : ki // i />]]$) is that we wish +second premise ($[[</ G, G'i |-ty si : ki // i />]]$) is that we wish to check each substituted type $[[s'i]]$ in a context containing all the types that come before it in the list of bindings. The $[[G'i]]$ are contexts containing the names and kinds of all type variables (and term variables, for that matter) up to the $i$th binding. This logic is extracted from \coderef{coreSyn/CoreLint.lhs}{lintAndScopeIds}. -\item There is one more case for $[[G |-tm e : t]]$, for type expressions. -This is included in the GHC code but is elided -here because the case is never used in practice. Type expressions -can only appear in arguments to functions, and these are handled -in \ottdrulename{Tm\_AppType}. - \item The GHC source code checks all arguments in an application expression all at once using \coderef{coreSyn/CoreSyn.lhs}{collectArgs} and \coderef{coreSyn/CoreLint.lhs}{lintCoreArgs}. The operation @@ -318,17 +363,13 @@ a dead id and for one-tuples. These checks are omitted here. In the coercion typing judgment, the $\#$ marks are left off the equality operators to reduce clutter. This is not actually inconsistent, because the GHC function that implements this check, \texttt{lintCoercion}, actually -returns four separate values (the kind, the two types, and the role), not -a type with head $[[(~#)]]$ or $[[(~R#)]]$. Note that the difference between +returns five separate values (the two kinds, the two types, and the role), not +a type with head $[[(~#)]]$ or $[[(~Rep#)]]$. Note that the difference between these two forms of equality is interpreted in the rules \ottdrulename{Co\_CoVarCoNom} and \ottdrulename{Co\_CoVarCoRepr}. \ottdefnlintCoercion{} -In \ottdrulename{Co\_AxiomInstCo}, the use of $[[inits]]$ creates substitutions from -the first $i$ mappings in $[[ </ [ni |-> si] // i /> ]]$. This has the effect of -folding the substitution over the kinds for kind-checking. - See Section~\ref{sec:tyconroles} for more information about $[[tyConRolesX]]$, and see Section~\ref{sec:axiom_rules} for more information about $[[coaxrProves]]$. @@ -342,7 +383,7 @@ There are two very similar checks for names, one declared as a local function: \subsection{Substitution consistency} -\ottdefncheckTyKind{} +\ottdefnlintTyKind{} \subsection{Case alternative consistency} @@ -364,9 +405,9 @@ There are two very similar checks for names, one declared as a local function: \ottdefnlintXXapp{} -\subsection{Sub-kinding} +\subsection{Axiom argument kinding} -\ottdefnisSubKind{} +\ottdefncheckXXki{} \subsection{Roles} \label{sec:tyconroles} @@ -462,7 +503,7 @@ algebraic datatype. Coercions (say, in a GADT) are considered term arguments. \begin{itemize} \item The logic in this rule is implemented in \coderef{coreSyn/CoreSubst.lhs}{exprIsConApp\_maybe}. \item The $[[coercionKind]]$ function (\coderef{types/Coercion.lhs}{coercionKind}) -extracts the two types (and their kind) from +extracts the two types (and their kinds) from a coercion. It does not require a typing context, as it does not \emph{check} the coercion, just extracts its types. \item The $[[dataConRepType]]$ function (\coderef{basicTypes/DataCon.lhs}{dataConRepType}) extracts the full type of a data constructor. Following the notation for @@ -472,6 +513,8 @@ groups: universally quantified types, existentially quantified types, and terms. \emph{type} variables with \emph{coercions}. This substitution is called lifting and is implemented in \coderef{types/Coercion.lhs}{liftCoSubst}. The notation is essentially a pun on the fact that types and coercions have such similar structure. +This operation is quite non-trivial. Please see \emph{System FC with Explicit +Kind Equality} for details. \item Note that the types $[[ </ sbb // bb /> ]]$---the existentially quantified types---do not change during this step. \end{itemize} diff --git a/docs/core-spec/core-spec.pdf b/docs/core-spec/core-spec.pdf Binary files differindex 93242e9f72..ac548f63c1 100644 --- a/docs/core-spec/core-spec.pdf +++ b/docs/core-spec/core-spec.pdf diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 9993618103..ca30bddf26 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -7000,9 +7000,6 @@ Note the following specific points: ghci> :k T T :: forall (k :: BOX). (k -> *) -> k -> * - Here the kind variable ``k`` itself has a kind annotation "``BOX``". - This is just GHC's way of saying "``k`` is a kind variable". - - Just as in the world of terms, you can restrict polymorphism using a kind signature (sometimes called a kind annotation) diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst index 6964ce48a1..bf9cbd0e8f 100644 --- a/docs/users_guide/using.rst +++ b/docs/users_guide/using.rst @@ -597,11 +597,13 @@ See also the ``--help``, ``--version``, ``--numeric-version``, and list of some in the instances it knows about. With this flag it prints *all* the instances it knows about. -``-fprint-explicit-foralls, -fprint-explicit-kinds, -fprint-unicode-syntax`` +``-fprint-explicit-foralls, -fprint-explicit-kinds, -fprint-unicode-syntax, -fprint-explicit-coercions, -fprint-equality-relations`` .. index:: single: -fprint-explicit-foralls single: -fprint-explicit-kinds single: -fprint-unicode-syntax + single: -fprint-explicit-coercions + single: -fprint-equality-relations These three flags control the way in which GHC displays types, in error messages and in GHCi. Using ``-fprint-explicit-foralls`` makes @@ -662,6 +664,21 @@ See also the ``--help``, ``--version``, ``--numeric-version``, and ghci> :t (>>) (>>) :: ∀ (m :: * → *) a b. Monad m ⇒ m a → m b → m b + Using ``-fprint-explicit-coercions`` makes GHC print coercions in + types. When trying to prove the equality between types of different + kinds, GHC uses type-level coercions. Users will rarely need to + see these, as they are meant to be internal. + + Using ``-fprint-equality-relations`` tells GHC to distinguish between + its equality relations when printing. For example, ``~`` is homogeneous + lifted equality (the kinds of its arguments are the same) while + ``~~`` is heterogeneous lifted equality (the kinds of its arguments + might be different) and ``~#`` is heterogeneous unlifted equality, + the internal equality relation used in GHC's solver. Generally, + users should not need to worry about the subtleties here; ``~`` is + probably what you want. Without ``-fprint-equality-relations``, GHC + prints all of these as ``~``. + ``-fprint-expanded-synonyms`` .. index:: single: -fprint-expanded-synonyms diff --git a/libraries/base/Data/Coerce.hs b/libraries/base/Data/Coerce.hs index 23c37967df..bb98393210 100644 --- a/libraries/base/Data/Coerce.hs +++ b/libraries/base/Data/Coerce.hs @@ -26,5 +26,4 @@ module Data.Coerce import GHC.Prim (coerce) import GHC.Types (Coercible) -import GHC.Base () -- for build ordering - +import GHC.Base () -- for build ordering; see Notes in GHC.Base for more info diff --git a/libraries/base/Data/Kind.hs b/libraries/base/Data/Kind.hs new file mode 100644 index 0000000000..348301347c --- /dev/null +++ b/libraries/base/Data/Kind.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Trustworthy, ExplicitNamespaces #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Kind +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : not portable +-- +-- Basic kinds +-- +-- @since 4.9.0.0 +----------------------------------------------------------------------------- + +module Data.Kind ( Type, Constraint, type (*), type (★) ) where + +import GHC.Types diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index f60a15fb58..0a33c27cac 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -235,4 +235,3 @@ prop_mconcatLast x = where listLastToMaybe [] = Nothing listLastToMaybe lst = Just (last lst) -- -} - diff --git a/libraries/base/Data/Type/Coercion.hs b/libraries/base/Data/Type/Coercion.hs index f9f64c1439..c85af5b282 100644 --- a/libraries/base/Data/Type/Coercion.hs +++ b/libraries/base/Data/Type/Coercion.hs @@ -52,19 +52,17 @@ data Coercion a b where -- Steenbergen for 'type-equality', Edward Kmett for 'eq', and Gabor Greif -- for 'type-eq' -newtype Sym a b = Sym { unsym :: Coercion b a } - -- | Type-safe cast, using representational equality coerceWith :: Coercion a b -> a -> b coerceWith Coercion x = coerce x -- | Symmetry of representational equality -sym :: forall a b. Coercion a b -> Coercion b a -sym Coercion = unsym (coerce (Sym Coercion :: Sym a a)) +sym :: Coercion a b -> Coercion b a +sym Coercion = Coercion -- | Transitivity of representational equality trans :: Coercion a b -> Coercion b c -> Coercion a c -trans c Coercion = coerce c +trans Coercion Coercion = Coercion -- | Convert propositional (nominal) equality to representational equality repr :: (a Eq.:~: b) -> Coercion a b @@ -98,4 +96,4 @@ instance TestCoercion ((Eq.:~:) a) where testCoercion Eq.Refl Eq.Refl = Just Coercion instance TestCoercion (Coercion a) where - testCoercion c Coercion = Just $ coerce (sym c) + testCoercion Coercion Coercion = Just Coercion diff --git a/libraries/base/Data/Type/Equality.hs b/libraries/base/Data/Type/Equality.hs index 59d4ea3455..a021fa7b9a 100644 --- a/libraries/base/Data/Type/Equality.hs +++ b/libraries/base/Data/Type/Equality.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} ----------------------------------------------------------------------------- -- | @@ -29,9 +31,9 @@ module Data.Type.Equality ( - -- * The equality type - (:~:)(..), - + -- * The equality types + (:~:)(..), type (~~), + -- * Working with equality sym, trans, castWith, gcastWith, apply, inner, outer, @@ -49,6 +51,16 @@ import GHC.Read import GHC.Base import Data.Type.Bool +-- | Lifted, homogeneous equality. By lifted, we mean that it can be +-- bogus (deferred type error). By homogeneous, the two types @a@ +-- and @b@ must have the same kind. +class a ~~ b => (a :: k) ~ (b :: k) | a -> b, b -> a + -- NB: Not exported, as (~) is magical syntax. That's also why there's + -- no fixity. +instance {-# INCOHERENT #-} a ~~ b => a ~ b + -- incoherent because we want to use this instance eagerly, even when + -- the tyvars are partially unknown. + infix 4 :~: -- | Propositional equality. If @a :~: b@ is inhabited by some terminating diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 4379155c57..86ced96b12 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -44,9 +44,10 @@ module Data.Typeable.Internal ( tcBool, tc'True, tc'False, tcOrdering, tc'LT, tc'EQ, tc'GT, tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun, - tcIO, tcSPEC, tcTyCon, tcModule, - tcCoercible, tcList, tcEq, - tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK, + tcIO, tcSPEC, tcTyCon, tcModule, tcTrName, + tcCoercible, tcList, tcHEq, + tcConstraint, + tcTYPE, tcLevity, tc'Lifted, tc'Unlifted, funTc, -- ToDo @@ -403,8 +404,8 @@ mkGhcTypesTyCon name = mkTyCon3# "ghc-prim"# "GHC.Types"# name tcBool, tc'True, tc'False, tcOrdering, tc'GT, tc'EQ, tc'LT, tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun, - tcIO, tcSPEC, tcTyCon, tcModule, - tcCoercible, tcEq, tcList :: TyCon + tcIO, tcSPEC, tcTyCon, tcModule, tcTrName, + tcCoercible, tcHEq, tcList :: TyCon tcBool = mkGhcTypesTyCon "Bool"# -- Bool is promotable tc'True = mkGhcTypesTyCon "'True"# @@ -415,28 +416,28 @@ tc'EQ = mkGhcTypesTyCon "'EQ"# tc'LT = mkGhcTypesTyCon "'LT"# -- None of the rest are promotable (see TysWiredIn) -tcChar = mkGhcTypesTyCon "Char"# -tcInt = mkGhcTypesTyCon "Int"# -tcWord = mkGhcTypesTyCon "Word"# -tcFloat = mkGhcTypesTyCon "Float"# -tcDouble = mkGhcTypesTyCon "Double"# -tcSPEC = mkGhcTypesTyCon "SPEC"# -tcIO = mkGhcTypesTyCon "IO"# -tcTyCon = mkGhcTypesTyCon "TyCon"# -tcModule = mkGhcTypesTyCon "Module"# -tcCoercible = mkGhcTypesTyCon "Coercible"# +tcChar = mkGhcTypesTyCon "Char"# +tcInt = mkGhcTypesTyCon "Int"# +tcWord = mkGhcTypesTyCon "Word"# +tcFloat = mkGhcTypesTyCon "Float"# +tcDouble = mkGhcTypesTyCon "Double"# +tcSPEC = mkGhcTypesTyCon "SPEC"# +tcIO = mkGhcTypesTyCon "IO"# +tcTyCon = mkGhcTypesTyCon "TyCon"# +tcModule = mkGhcTypesTyCon "Module"# +tcTrName = mkGhcTypesTyCon "TrName"# +tcCoercible = mkGhcTypesTyCon "Coercible"# tcFun = mkGhcTypesTyCon "->"# tcList = mkGhcTypesTyCon "[]"# -- Type rep for the list type constructor -tcEq = mkGhcTypesTyCon "~"# -- Type rep for the (~) type constructor - -tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK :: TyCon -tcLiftedKind = mkGhcTypesTyCon "*"# -tcUnliftedKind = mkGhcTypesTyCon "#"# -tcOpenKind = mkGhcTypesTyCon "#"# -tcBOX = mkGhcTypesTyCon "BOX"# -tcAnyK = mkGhcTypesTyCon "AnyK"# +tcHEq = mkGhcTypesTyCon "~~"# -- Type rep for the (~~) type constructor + +tcConstraint, tcTYPE, tcLevity, tc'Lifted, tc'Unlifted :: TyCon tcConstraint = mkGhcTypesTyCon "Constraint"# +tcTYPE = mkGhcTypesTyCon "TYPE"# +tcLevity = mkGhcTypesTyCon "Levity"# +tc'Lifted = mkGhcTypesTyCon "'Lifted"# +tc'Unlifted = mkGhcTypesTyCon "'Unlifted"# funTc :: TyCon funTc = tcFun -- Legacy @@ -463,4 +464,3 @@ typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) -- | An internal function, to make representations for type literals. typeLitTypeRep :: String -> TypeRep typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) [] - diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 199664d9db..90eaaf0a1e 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -1,4 +1,17 @@ {- + +NOTA BENE: Do NOT use ($) anywhere in this module! The type of ($) is +slightly magical (it can return unlifted types), and it is wired in. +But, it is also *defined* in this module, with a non-magical type. +GHC gets terribly confused (and *hangs*) if you try to use ($) in this +module, because it has different types in different scenarios. + +This is not a problem in general, because the type ($), being wired in, is not +written out to the interface file, so importing files don't get confused. +The problem is only if ($) is used here. So don't! + +--------------------------------------------- + The overall structure of the GHC Prelude is a bit tricky. a) We want to avoid "orphan modules", i.e. ones with instance @@ -1086,13 +1099,13 @@ instance Alternative IO where instance MonadPlus IO returnIO :: a -> IO a -returnIO x = IO $ \ s -> (# s, x #) +returnIO x = IO (\ s -> (# s, x #)) bindIO :: IO a -> (a -> IO b) -> IO b -bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s +bindIO (IO m) k = IO (\ s -> case m s of (# new_s, a #) -> unIO (k a) new_s) thenIO :: IO a -> IO b -> IO b -thenIO (IO m) k = IO $ \ s -> case m s of (# new_s, _ #) -> unIO k new_s +thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s) unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) unIO (IO a) = a diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index ffc27d11eb..032e650c1e 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -53,6 +53,12 @@ module GHC.Exts -- @since 4.7.0.0 Data.Coerce.coerce, Data.Coerce.Coercible, + -- * Equality + type (~~), + + -- * Levity polymorphism + GHC.Prim.TYPE, Levity(..), + -- * Transform comprehensions Down(..), groupWith, sortWith, the, @@ -72,8 +78,9 @@ module GHC.Exts IsList(..) ) where -import GHC.Prim hiding (coerce, Constraint) -import GHC.Base hiding (coerce) -- implicitly comes from GHC.Prim +import GHC.Prim hiding ( coerce, TYPE ) +import qualified GHC.Prim +import GHC.Base hiding ( coerce ) import GHC.Word import GHC.Int import GHC.Ptr diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs index 0d9f4fe61f..a51ba910e0 100644 --- a/libraries/base/GHC/TypeLits.hs +++ b/libraries/base/GHC/TypeLits.hs @@ -284,5 +284,3 @@ withSNat f x y = magicDict (WrapN f) x y withSSymbol :: (KnownSymbol a => Proxy a -> b) -> SSymbol a -> Proxy a -> b withSSymbol f x y = magicDict (WrapS f) x y - - diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 684fabb14e..6261c446b8 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -148,6 +148,7 @@ Library Data.IORef Data.Int Data.Ix + Data.Kind Data.List Data.List.NonEmpty Data.Maybe diff --git a/libraries/base/tests/CatEntail.hs b/libraries/base/tests/CatEntail.hs index bc2d8d2f55..c980a2db73 100644 --- a/libraries/base/tests/CatEntail.hs +++ b/libraries/base/tests/CatEntail.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeOperators, KindSignatures #-} module CatEntail where import Prelude hiding (id, (.)) -import GHC.Prim (Constraint) +import GHC.Exts (Constraint) import Control.Category -- One dictionary to rule them all. diff --git a/libraries/ghc-prim/GHC/Classes.hs b/libraries/ghc-prim/GHC/Classes.hs index 12fe65f322..d4c6697652 100644 --- a/libraries/ghc-prim/GHC/Classes.hs +++ b/libraries/ghc-prim/GHC/Classes.hs @@ -678,4 +678,3 @@ class (c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11, c12, c13, c14, c15, c16, c31, c32, c33, c34, c35, c36, c37, c38, c39, c40, c41, c42, c43, c44, c45, c46, c47, c48, c49, c50, c51, c52, c53, c54, c55, c56, c57, c58, c59, c60, c61, c62) - diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 63b4f0508f..04aecbf37f 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples, - MultiParamTypeClasses, RoleAnnotations, CPP #-} + MultiParamTypeClasses, RoleAnnotations, CPP, TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Types @@ -29,7 +29,12 @@ module GHC.Types ( isTrue#, SPEC(..), Nat, Symbol, - Coercible, + type (~~), Coercible, + TYPE, Levity(..), Type, type (*), type (★), Constraint, + -- The historical type * should ideally be written as + -- `type *`, without the parentheses. But that's a true + -- pain to parse, and for little gain. + -- * Runtime type representation Module(..), TrName(..), TyCon(..) ) where @@ -40,6 +45,24 @@ infixr 5 : {- ********************************************************************* * * + Kinds +* * +********************************************************************* -} + +-- | The kind of constraints, like @Show a@ +data Constraint + +-- | The kind of types with values. For example @Int :: Type@. +type Type = TYPE 'Lifted + +-- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' +type * = TYPE 'Lifted + +-- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' +type ★ = TYPE 'Lifted + +{- ********************************************************************* +* * Nat and Symbol * * ********************************************************************* -} @@ -51,7 +74,6 @@ data Nat -- Declared here because class IP needs it data Symbol - {- ********************************************************************* * * Lists @@ -164,12 +186,10 @@ inside GHC, to change the kind and type. -} --- | A data constructor used to box up all unlifted equalities --- --- The type constructor is special in that GHC pretends that it --- has kind (? -> ? -> Fact) rather than (* -> * -> *) -data (~) a b = Eq# ((~#) a b) - +-- | Lifted, heterogeneous equality. By lifted, we mean that it +-- can be bogus (deferred type error). By heterogeneous, the two +-- types @a@ and @b@ might have different kinds. +class a ~~ b -- | This two-parameter class has instances for types @a@ and @b@ if -- the compiler can infer that they have the same representation. This class @@ -218,15 +238,7 @@ data (~) a b = Eq# ((~#) a b) -- by Joachim Breitner, Richard A. Eisenberg, Simon Peyton Jones and Stephanie Weirich. -- -- @since 4.7.0.0 -data Coercible a b = MkCoercible ((~#) a b) --- It's really ~R# (representational equality), not ~#, --- but * we don't yet have syntax for ~R#, --- * the compiled code is the same either way --- * TysWiredIn has the truthful types --- Also see Note [Kind-changing of (~) and Coercible] - --- | Alias for 'tagToEnum#'. Returns True if its parameter is 1# and False --- if it is 0#. +class Coercible a b {- ********************************************************************* * * @@ -237,6 +249,8 @@ data Coercible a b = MkCoercible ((~#) a b) data {-# CTYPE "HsBool" #-} Bool = False | True {-# INLINE isTrue# #-} +-- | Alias for 'tagToEnum#'. Returns True if its parameter is 1# and False +-- if it is 0#. isTrue# :: Int# -> Bool -- See Note [Optimizing isTrue#] isTrue# x = tagToEnum# x @@ -310,6 +324,18 @@ you're reading this in 2023 then things went wrong). See #8326. -- loops should be aggressively specialized. data SPEC = SPEC | SPEC2 +-- | GHC divides all proper types (that is, types that can perhaps be +-- inhabited, as distinct from type constructors or type-level data) +-- into two worlds: lifted types and unlifted types. For example, +-- @Int@ is lifted while @Int#@ is unlifted. Certain operations need +-- to be polymorphic in this distinction. A classic example is 'unsafeCoerce#', +-- which needs to be able to coerce between lifted and unlifted types. +-- To achieve this, we use kind polymorphism: lifted types have kind +-- @TYPE Lifted@ and unlifted ones have kind @TYPE Unlifted@. 'Levity' +-- is the kind of 'Lifted' and 'Unlifted'. @*@ is a synonym for @TYPE Lifted@ +-- and @#@ is a synonym for @TYPE Unlifted@. +data Levity = Lifted | Unlifted + {- ********************************************************************* * * Runtime represntation of TyCon diff --git a/rae.txt b/rae.txt new file mode 100644 index 0000000000..03971da171 --- /dev/null +++ b/rae.txt @@ -0,0 +1,319 @@ +stack: + +BUGS TO POST: +1. perfomance bug in OptCoercion: #11195 +2. defer-type-errors are now more eager. need to float in. #11197 + Test cases: Defer02, T7861 (but that's impredicative) +3. The irreducible hetero wanteds story: #11198 + - suboptimal error messages: + T9196 + T8262 + T8603 + tcfail122 + +4. Performance: #11196 + T3064 (14%) + T5030 (61.8%) + T5837 (13%) + T5321Fun (11%) + T5631 (39%) + T9872d (-91.8%) + T9872a (33.6%) + T9872c (59.4%) + T9872b (49.4%) + T9675 (29.7%) (and 28.4% peak_megabytes_allocated) + haddock.base (12.4%) + haddock.Cabal (9.5%) + + +PERFORMANCE STUFF: + T5030: I think the root of the problem is that I have a lot more coercions than + the baseline. And, I think, the reason for that is that I have a + (sym (a;b;c;...;zz)) where HEAD has it the right way round. During optimization, + the sym is pushed into the trans, and the individual pieces are axioms, which + resist the sym. So I get a *lot* of syms! Moving on. + + T3738: I have no clue. The core appears to be the same. Is the problem + further down the pipeline? Ditto T5536. + + T10370: + + + + +- BUG: match_ty needs to be more delicate looking under TyConApps: + match_ty (Just (x :: Age)) (Just 5 |> Maybe Int ~ Maybe Age) won't work + +- flattening foralls is inadequate (though not quite wrong). The tyvar + kind isn't flattened. Also see go_bndr in flatten_co. + +fix toHsType w.r.t. implicit parameters (typecheck/should_compile/T8565.hs) + +FAILURES: +typecheck/should_compile/T6018: + - TF injectivity solver fails here. The problem is that we end up with s0 ~ s1 and s0 ~ s2 in the inert + set, where we want to find s1 ~ s2. And, because we process deriveds last, the model doesn't get updated + accordingly until the end, and then there isn't the right kick-out to re-process TF injectivity stuff. + I would like Simon's advice. + + + +TICKETS: +#9017: +#9173: mention expression in error +#7961: main ticket. +#10524: Typeable k +#8566: about dropping Given kind equalities +#11142: skolem escape + +QUESTIONS: +- Should TYPE / Levity / Lifted / Unlifted be in the Prelude? If not, +how to deal with :info, which suppresses output that mentions un-imported things. +Current sol'n: make these things BuiltInSyntax. + +- think about induction recursion +- TH will need some updating -- in particular, its treatment of quantification + over kinds (quantification forbidden) and types (quantification required) + is problematic. + +- Writing a bogus GADT return type causes a panic. The problem is that +checkValidDataCon is supposed to check if rejigConRes was valid. To do +this, checkValidDataCon needs the user-specified result type. Normally, +this is retrieved from dataConOrigResTy. The problem is that, now, +the dataConOrigResTy is substed by the kind substitution produced in +rejigConRes. This is an ugly circular dependency. We could (1) store the +original, unsubsted result ty in the DataCon for just this reason, or +(2) install lots of ugly plumbing in TcTyClsDecls to carry the unsubsted +result ty, or (3) do something else. I want SPJ's input, as both (1) +and (2) are terrible. + +- I'm deeply disturbed by match_co. It's looking into coercions! Can we fix? + +fix: + - Make better use of TcTyCon. It could be used to remove AThing, for example. + Also: zonking a type could replace a TcTyCon with the same-named TyCon from + the monad. We'd still need a knot, but the knot would only have to surround + the final zonks, *not* constraint generation/solving. Vast improvement. + + - DsMeta:mk_extra_tvs needs an overhaul. + + - zonk_eq_types could do better with synonym expansion and injectivity tracking + + - We should deprecate some old kind behavior. Specifically, consider + foo :: forall a. (a :: k) -> * + vs + bar :: forall a. a -> b + + The first works, while the second doesn't. That's a bit inconsistent. + + - better use of new VarSet features (CoreFVs using accumulators, FloatIn not converting from det + maps to nondet maps) + + - Parser improvement ideas: + 1. Have HsAppsTy contain alternating non-symbolic regions and symbols. + 2. Change the _no_ops versions only to exclude dataconops, allowing * to appear. + + - Refactor noThing + + - Change OccurrenceOf to take a list of instantiating types. Perhaps + easier after visible types. + + - break out NthCo into ForAllKindCo + - change optCoercion to take a Role hint (or perhaps a Maybe Role) + + - implement better dependency checking + + - Fix #15 by refusing to have kind family applications inferred in type + patterns. + + - unifyWantedLikeEv handles coercions. But make sure other, similar scenarios + do too. + + - Make sure coercions in types get optimised, too. + + - look for uses of eqType. The typechecker should really stick to tcEqType! + BUT: consider making Constraint ~R *. Then, tcEqType & eqType are the same. + - when -fprint-explicit-coercions is on, make sure to print any types + of printed coboxes. + - make use of uo_thing in more error messages + - write optType. Use it instead of substTy in OptCoercion and other places. + - check out typecheck/should_compile/tc167.hs. It might be possible to + do better here. (About weird typing rule for (->)) + - do we need to annotate kind variables to have a proper CUSK? I think so. + Here is Doel's example from Hac Phi of this problem at the term level: + + type family Wat (t :: k) :: * + type instance Wat (t :: *) = Int + type instance Wat (t :: * -> *) = Double + + data T (t :: k) = forall (t' :: k). T (Proxy t') (Wat t') + + -- foo :: forall f. T f + foo = T (Proxy :: Proxy Maybe) 1.0 + + + type family Wat (k :: *) (t :: k) :: * + type instance Wat * t = Int + type instance Wat (* -> *) t = Double + + data T (k :: *) (t :: k) :: * where + T :: forall (k :: *) (t :: k). + forall (t' :: k). + Proxy k t' -> Wat k t' -> T k t + + foo = T (* -> *) (Any (* -> *)) Maybe Proxy 1.0 + ??? + + + - mkExpectedActualMsg has a lot of backward-compatibility stuff +- Are there uses of the `OrCoVar` functions that could be streamlined? + Also, look at uses of isCoercionType in module Id + - consider re-engineering the boxity problems in solver. look for the "LikeEv" functions + + - Do we need special rule for boxity of ($)? I don't think so, anymore. SPJ agrees. Maybe. + - hsq_implict --> hsq_undeclared; hsq_explicit --> hsq_declared + - APromotionErr (?) + - :kind in GHCi is unhappy with + data Sg (s :: *) (t :: TyFun s * -> *) :: * where + (:&) :: Pi (fst :: s) -> t @@ fst -> Sg s t + + - the kind-var finder in zonkRule only looks in tyvars. look in covars? how + to identify type-level covars? does this matter? + - add VisibilityFlag to Anon... see if we can sort out some constraint/* nonsense. Also, add relevance info to Anon, and work Binders into Lam and Case. This also allows us to get rid of DFunTy in iface/* stuff. + - perhaps change promoteCoercion --> promoteCoercion_maybe that fails if + it can't do any optimization. + +check out usages of: + +changed functions: + +removed functions: + +please remove: +-------------------------------- +- See https://ghc.haskell.org/trac/ghc/wiki/DependentHaskell/Internal#User-facingdesignissues about constrained family instances. + +- znokCtEvidence now does more zonking, because I needed that in simplifyInfer. + +- dataConWrappers now are rejigged w.r.t. GADTs. This is just simpler and + has no user effect. + +- Some interesting stuff is in TcHsType.splitTelescopeTvs, in particular see +Note [Typechecking telescopes]. + +- We are now instantiating tycons at application sites, not var sites. Very +interesting from a theoretical standpoint. + +- There is a general assumption that all types are implicit in terms. This will have + to be revisited. In particular, all usages of the splitForAllTys functions will + need to be re-checked. Also, I think the following functions will need to be changed: + - mkLams + - tcInstType + - tcSplitDFunTy + - toIfaceClassOp + +- Why isn't CPush implemented near Simplify.lhs:1200? + +- Poly-kinded typeable goes to lengths to ensure that only *kind* variables + are around. This seems unnecessary. I've removed the code. Let's see if + anything breaks -- it should break rather obviously. + +- (Removed) Note [Do not create Given kind equalities] says + "But the Right Thing is to add kind equalities!" + +- *ALL* types are now kinds (of course). Including things like Double and IO. + +- No kind unification algorithm (separate from that for types) + +- No two coercions of the same type are ever apart. + +- Promoted covar arguments in promoted datacons have role P. + +- flattening a coercion flattens the types it coerces. + +(old): +After compiling: +- consider adding full definition of lifting to core-spec. +- use optType throughout code +- make CoVar constructor of Var +- merge tcView and coreView?? + + +Notes: + +---------------------------------------- +Stuff for implementing Π: + +RAE is taking a break. + - deeplySkolemise and its one use in tcGen have different types. Sort this out. + - deeplyInstantiate needs to be just like deeplySkolemise, but different. + - Phase information flows *up*, never *down*. That is, we always infer + phase information and then check when necessary. We don't try to check + phases top-down. This avoids the need for dependence meta-variables. + - How to deal with unifying Ids? This will be a problem in deeplyInstantiate. + - We'll need a new EvTerm (and possibly a new HsWrapper) which stores a tyvar + to be demoted. + +stack: + - iface stuff + - ForAllTy --> PiTy + - ForAllCo --> PiCo + - function coercions are now PiCo + - changes in PiCoBndr + - matchExpectedFunTys now returns DependenceFlags + - unifyOpFunTysWrap returns TcPhaseType + - tcMatchesCase takes TcArgType + - tcArg takes TcArgType + - tcArgs does too + - matchFunTys callback does + - tcSplitSigmaTy is strange: it separates dependent things from non-dependent ones in a weird way. Remove? + - newSysLocalIds --> newSysLocals + - liftCoSubstVarBndr --> liftCoSubstBinder + - fix Coercion.applyCo, which shouldn't be necessary + - coBndrBoundVars --> coBndrBinders + - normalise_tycovar_bndr --> normalise_binder + - coreFlattenVarBndr --> coreFlattenBinder + - optTyVarBndr --> optBinder + - substTyVarBndr[Callback] -->(?) substBinder[Callback] + - substTyCoVarBndr2 --> substBinder2 + - ppr_forall_type --> ppr_pi_type + - tidyTyCoVarBndr --> tidyBinder + - mkForAllTy[s] --> mkPiTy[s] + - removed mkNamedForAllTy + - mkCoercionBinder now takes a BinderVar, not a CoVar + - splitForAllTys --> splitPiTys + - splitForAllTys[B] --> splitDepPiTys + - tcSplitNamedForAllTysB --> tcSplitDepPiTys + - isForAllTy --> isPiTy, and check usages + - isNamedForAllTy --> isDepPiTy + - splitForAllTy --> splitPiTy + - check usages of dropForAlls: it keeps dependent products! + - splitForAllTysInvisible --> splitPiTysInvis; now returns Binders + - write cmpBinderInfo + - use rnBinder2 instead of rnBinderVar2 + - nonDependentType_maybe --> nonDependentBinder_maybe + - prefer nonDependentType_maybe over not (isDependentBinder + - paDictArgType should take a Binder + - abstractType takes Binders + - fixed Named/Anon + - write splitPiTy_maybe + - write promoteExpr_maybe + - TyVarTy can now contain Ids! + - Lam takes a Binder + - pattern arguments are Binders + - fix TyCoRep.pprForAll: very broken right now. Also, see Outputable BinderVar. + + + - will need to modify FloatIn.fiExpr#mk_arg_fvs to use splitPiType instead of + splitFunTy + - will need to update DmdAnal.addDataConPatDmds to deal with strictness on + dependent ids + + +BEFORE MERGING: +Restore: + - README.md + - .gitmodules + +Remove: + - rae.txt diff --git a/testsuite/tests/ado/ado004.stderr b/testsuite/tests/ado/ado004.stderr index 5177765c86..a5fe638fea 100644 --- a/testsuite/tests/ado/ado004.stderr +++ b/testsuite/tests/ado/ado004.stderr @@ -18,9 +18,9 @@ TYPE SIGNATURES (Monad m, Num a2) => (a2 -> m a1) -> (a1 -> a1 -> m a) -> m a test6 :: - forall t (m :: * -> *) a. + forall r (m :: * -> *) a. (Monad m, Num (m a)) => - (m a -> m (m a)) -> t -> m a + (m a -> m (m a)) -> r -> m a TYPE CONSTRUCTORS COERCION AXIOMS Dependent modules: [] diff --git a/testsuite/tests/annotations/should_fail/annfail10.stderr b/testsuite/tests/annotations/should_fail/annfail10.stderr index 1e77541499..5c6f71b486 100644 --- a/testsuite/tests/annotations/should_fail/annfail10.stderr +++ b/testsuite/tests/annotations/should_fail/annfail10.stderr @@ -18,7 +18,7 @@ annfail10.hs:9:11: error: prevents the constraint ‘(Num a0)’ from being solved. Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: - instance forall (k :: BOX) (f :: k -> *) (a :: k). + instance forall k (f :: k -> *) (a :: k). Num (f a) => Num (Alt f a) -- Defined in ‘Data.Monoid’ diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index b4aa53d787..b89b3a868d 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -1,8 +1,8 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 27, types: 24, coercions: 1} +Result size of Tidy Core = {terms: 36, types: 30, coercions: 1} --- RHS size: {terms: 2, types: 3, coercions: 1} +-- RHS size: {terms: 2, types: 4, coercions: 1} T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a [GblId[DataConWrapper], Caf=NoCafRefs, @@ -31,17 +31,27 @@ T2431.$trModule = Module a a1 -- RHS size: {terms: 2, types: 0, coercions: 0} a2 :: TrName [GblId, Caf=NoCafRefs, Str=DmdType] -a2 = TrNameS ":~:"# +a2 = TrNameS "'Refl"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +T2431.$tc'Refl :: TyCon +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +T2431.$tc'Refl = TyCon 0## 0## T2431.$trModule a2 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a3 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a3 = TrNameS ":~:"# -- RHS size: {terms: 5, types: 0, coercions: 0} T2431.$tc:~: :: TyCon [GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] -T2431.$tc:~: = TyCon 0## 0## T2431.$trModule a2 +T2431.$tc:~: = TyCon 0## 0## T2431.$trModule a3 --- RHS size: {terms: 4, types: 7, coercions: 0} +-- RHS size: {terms: 4, types: 8, coercions: 0} absurd :: forall a. Int :~: Bool -> a [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>b] -absurd = \ (@ a3) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { } +absurd = \ (@ a4) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { } diff --git a/testsuite/tests/deSugar/should_compile/T4488.stderr b/testsuite/tests/deSugar/should_compile/T4488.stderr index fee802e213..f3a70cd586 100644 --- a/testsuite/tests/deSugar/should_compile/T4488.stderr +++ b/testsuite/tests/deSugar/should_compile/T4488.stderr @@ -1,20 +1,20 @@ -T4488.hs:11:11: - Warning: Call of fromIntegral :: Int -> Int - can probably be omitted - (Use -fno-warn-identities to suppress this message) +T4488.hs:11:11: Warning: + Call of fromIntegral :: Int -> Int + can probably be omitted + (Use -fno-warn-identities to suppress this message) -T4488.hs:17:11: - Warning: Call of toInteger :: Integer -> Integer - can probably be omitted - (Use -fno-warn-identities to suppress this message) +T4488.hs:17:11: Warning: + Call of toInteger :: Integer -> Integer + can probably be omitted + (Use -fno-warn-identities to suppress this message) -T4488.hs:23:11: - Warning: Call of toRational :: Rational -> Rational - can probably be omitted - (Use -fno-warn-identities to suppress this message) +T4488.hs:23:11: Warning: + Call of toRational :: Rational -> Rational + can probably be omitted + (Use -fno-warn-identities to suppress this message) -T4488.hs:29:11: - Warning: Call of realToFrac :: Float -> Float - can probably be omitted - (Use -fno-warn-identities to suppress this message) +T4488.hs:29:11: Warning: + Call of realToFrac :: Float -> Float + can probably be omitted + (Use -fno-warn-identities to suppress this message) diff --git a/testsuite/tests/dependent/Makefile b/testsuite/tests/dependent/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/dependent/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/dependent/should_compile/Dep1.hs b/testsuite/tests/dependent/should_compile/Dep1.hs new file mode 100644 index 0000000000..6f8fe0720d --- /dev/null +++ b/testsuite/tests/dependent/should_compile/Dep1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeInType #-} + +module Dep1 where + +import Data.Kind + +data Proxy k (a :: k) = P + +x :: Proxy * Int +x = P + +y :: Proxy Bool True +y = P diff --git a/testsuite/tests/dependent/should_compile/Dep2.hs b/testsuite/tests/dependent/should_compile/Dep2.hs new file mode 100644 index 0000000000..34be3cffc6 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/Dep2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds, GADTs #-} + +module Dep2 where + +data G (a :: k) where + G1 :: G Int + G2 :: G Maybe diff --git a/testsuite/tests/dependent/should_compile/Dep3.hs b/testsuite/tests/dependent/should_compile/Dep3.hs new file mode 100644 index 0000000000..cba5043a08 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/Dep3.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} + +module Dep3 where + +import Data.Kind +import GHC.Exts ( Constraint ) + +type Star1 = * + +data Id1 (a :: Star1) where + Id1 :: a -> Id1 a + +data Id1' :: Star1 -> * where + Id1' :: a -> Id1' a + +type family Star2 x where + Star2 x = * + +data Id2a (a :: Star2 Constraint) = Id2a a + + +data Id2 (a :: Star2 Constraint) where + Id2 :: a -> Id2 a + +data Id2' :: Star2 Constraint -> * where + Id2' :: a -> Id2' a diff --git a/testsuite/tests/dependent/should_compile/KindEqualities.hs b/testsuite/tests/dependent/should_compile/KindEqualities.hs new file mode 100644 index 0000000000..1f2e82c302 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/KindEqualities.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module KindEqualities where + +data TyRep1 :: * -> * where + TyInt1 :: TyRep1 Int + TyBool1 :: TyRep1 Bool + +zero1 :: forall a. TyRep1 a -> a +zero1 TyInt1 = 0 +zero1 TyBool1 = False + +data Proxy (a :: k) = P + +data TyRep :: k -> * where + TyInt :: TyRep Int + TyBool :: TyRep Bool + TyMaybe :: TyRep Maybe + TyApp :: TyRep a -> TyRep b -> TyRep (a b) + +zero :: forall (a :: *). TyRep a -> a +zero TyInt = 0 +zero TyBool = False +zero (TyApp TyMaybe _) = Nothing diff --git a/testsuite/tests/dependent/should_compile/KindEqualities2.hs b/testsuite/tests/dependent/should_compile/KindEqualities2.hs new file mode 100644 index 0000000000..5a6f60d40b --- /dev/null +++ b/testsuite/tests/dependent/should_compile/KindEqualities2.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, + TemplateHaskell, UndecidableInstances, ScopedTypeVariables, + TypeInType #-} + +module KindEqualities2 where + +import Data.Kind +import GHC.Exts ( Any ) + +data Kind = Star | Arr Kind Kind + +data Ty :: Kind -> * where + TInt :: Ty Star + TBool :: Ty Star + TMaybe :: Ty (Arr Star Star) + TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 + + +data TyRep (k :: Kind) (t :: Ty k) where + TyInt :: TyRep Star TInt + TyBool :: TyRep Star TBool + TyMaybe :: TyRep (Arr Star Star) TMaybe + TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) + +type family IK (k :: Kind) +type instance IK Star = * +type instance IK (Arr k1 k2) = IK k1 -> IK k2 + +$(return []) -- necessary because the following instances depend on the + -- previous ones. + +type family I (t :: Ty k) :: IK k +type instance I TInt = Int +type instance I TBool = Bool +type instance I TMaybe = Maybe +type instance I (TApp a b) = (I a) (I b) + +zero :: forall (a :: Ty 'Star). TyRep Star a -> I a +zero TyInt = 0 +zero TyBool = False +zero (TyApp TyMaybe TyInt) = Nothing + +main = print $ zero (TyApp TyMaybe TyInt) diff --git a/testsuite/tests/dependent/should_compile/KindLevels.hs b/testsuite/tests/dependent/should_compile/KindLevels.hs new file mode 100644 index 0000000000..80762978b2 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/KindLevels.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, PolyKinds #-} + +module KindLevels where + +data A +data B :: A -> * +data C :: B a -> * +data D :: C b -> * +data E :: D c -> * diff --git a/testsuite/tests/dependent/should_compile/Makefile b/testsuite/tests/dependent/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/dependent/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/dependent/should_compile/RAE_T32b.hs b/testsuite/tests/dependent/should_compile/RAE_T32b.hs new file mode 100644 index 0000000000..7e067099c9 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/RAE_T32b.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, + RankNTypes, TypeOperators, TypeInType #-} + +module RAE_T32b where + +import Data.Kind + +data family Sing (k :: *) :: k -> * + +data TyArr (a :: *) (b :: *) :: * +type family (a :: TyArr k1 k2 -> *) @@ (b :: k1) :: k2 +$(return []) + +data Sigma (p :: *) (r :: TyArr p * -> *) :: * where + Sigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a). + Sing * p -> Sing (TyArr p * -> *) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r +$(return []) + +data instance Sing (Sigma p r) (x :: Sigma p r) :: * where + SSigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a) + (sp :: Sing * p) (sr :: Sing (TyArr p * -> *) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). + Sing (Sing (r @@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) diff --git a/testsuite/tests/dependent/should_compile/Rae31.hs b/testsuite/tests/dependent/should_compile/Rae31.hs new file mode 100644 index 0000000000..cedc019cf3 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/Rae31.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, + TypeFamilies, TypeInType #-} + +module A where + +import Data.Kind + +data family Sing (k :: *) :: k -> * +type Sing' (x :: k) = Sing k x +data TyFun' (a :: *) (b :: *) :: * +type TyFun (a :: *) (b :: *) = TyFun' a b -> * +type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: *) (b :: TyFun a *) :: * +type TyPi (a :: *) (b :: TyFun a *) = TyPi' a b -> * +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data A (a :: *) (b :: a) (c :: TyFun' a *) -- A :: forall a -> a -> a ~> * +type instance (@@) (A a b) c = * +$(return []) +data B (a :: *) (b :: TyFun' a *) -- B :: forall a -> a ~> * +type instance (@@) (B a) b = TyPi a (A a b) +$(return []) +data C (a :: *) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) *) diff --git a/testsuite/tests/dependent/should_compile/RaeBlogPost.hs b/testsuite/tests/dependent/should_compile/RaeBlogPost.hs new file mode 100644 index 0000000000..e99c7b5dd5 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/RaeBlogPost.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, + TypeInType #-} +{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} + +module RaeBlogPost where + +import Data.Kind + +-- a Proxy type with an explicit kind +data Proxy k (a :: k) = P +prox :: Proxy * Bool +prox = P + +prox2 :: Proxy Bool 'True +prox2 = P + +-- implicit kinds still work +data A +data B :: A -> * +data C :: B a -> * +data D :: C b -> * +data E :: D c -> * +-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> * + +-- a kind-indexed GADT +data TypeRep (a :: k) where + TInt :: TypeRep Int + TMaybe :: TypeRep Maybe + TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + +zero :: TypeRep a -> a +zero TInt = 0 +zero (TApp TMaybe _) = Nothing + +data Nat = Zero | Succ Nat +type family a + b where + 'Zero + b = b + ('Succ a) + b = 'Succ (a + b) + +data Vec :: * -> Nat -> * where + Nil :: Vec a 'Zero + (:>) :: a -> Vec a n -> Vec a ('Succ n) +infixr 5 :> + +-- promoted GADT, and using + as a "kind family": +type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where + 'Nil ++ y = y + (h ':> t) ++ y = h ':> (t ++ y) + +-- datatype that mentions * +data U = Star (*) + | Bool Bool + +-- kind synonym +type Monadish = * -> * +class MonadTrans (t :: Monadish -> Monadish) where + lift :: Monad m => m a -> t m a +data Free :: Monadish where + Return :: a -> Free a + Bind :: Free a -> (a -> Free b) -> Free b + +-- yes, * really does have type *. +type Star = (* :: (* :: (* :: *))) diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T new file mode 100644 index 0000000000..0f231db699 --- /dev/null +++ b/testsuite/tests/dependent/should_compile/all.T @@ -0,0 +1,10 @@ +test('Dep1', only_ways('normal'), compile, ['']) +test('Dep2', only_ways('normal'), compile, ['']) +test('Dep3', only_ways('normal'), compile, ['']) +test('KindEqualities', only_ways('normal'), compile, ['']) +test('KindEqualities2', only_ways('normal'), compile, ['']) +test('Rae31', only_ways('normal'), compile, ['']) +test('RAE_T32b', only_ways('normal'), compile, ['']) +test('KindLevels', normal, compile, ['']) +test('RaeBlogPost', normal, compile, ['']) +test('mkGADTVars', normal, compile, ['']) diff --git a/testsuite/tests/dependent/should_compile/mkGADTVars.hs b/testsuite/tests/dependent/should_compile/mkGADTVars.hs new file mode 100644 index 0000000000..1e74c6980a --- /dev/null +++ b/testsuite/tests/dependent/should_compile/mkGADTVars.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, TypeInType #-} + +module GADTVars where + +import Data.Kind +import Data.Proxy + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: T x1 * (Proxy (y :: x1), z) z diff --git a/testsuite/tests/dependent/should_fail/BadTelescope.hs b/testsuite/tests/dependent/should_fail/BadTelescope.hs new file mode 100644 index 0000000000..acabffec54 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType #-} + +module BadTelescope where + +import Data.Kind + +data SameKind :: k -> k -> * + +data X a k (b :: k) (c :: SameKind a b) diff --git a/testsuite/tests/dependent/should_fail/BadTelescope.stderr b/testsuite/tests/dependent/should_fail/BadTelescope.stderr new file mode 100644 index 0000000000..2fbc35a9ba --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope.stderr @@ -0,0 +1,9 @@ + +BadTelescope.hs:9:1: error: + • These kind and type variables: (a :: k) + k + (b :: k) + (c :: SameKind a b) + are out of dependency order. Perhaps try this ordering: + k (a :: k) (b :: k) (c :: SameKind a b) + • In the data type declaration for ‘X’ diff --git a/testsuite/tests/dependent/should_fail/BadTelescope2.hs b/testsuite/tests/dependent/should_fail/BadTelescope2.hs new file mode 100644 index 0000000000..6237df4488 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope2 where + +import Data.Kind +import Data.Proxy + +data SameKind :: k -> k -> * + +foo :: forall a k (b :: k). SameKind a b +foo = undefined + +bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d +bar = undefined diff --git a/testsuite/tests/dependent/should_fail/BadTelescope2.stderr b/testsuite/tests/dependent/should_fail/BadTelescope2.stderr new file mode 100644 index 0000000000..2a9dc76310 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope2.stderr @@ -0,0 +1,16 @@ + +BadTelescope2.hs:10:8: error: + • These kind and type variables: a k (b :: k) + are out of dependency order. Perhaps try this ordering: + k (a :: k) (b :: k) + • In the type signature: + foo :: forall a k (b :: k). SameKind a b + +BadTelescope2.hs:13:8: error: + • The kind of variable ‘b’, namely ‘Proxy a’, + depends on variable ‘a’ from an inner scope + Perhaps bind ‘b’ sometime after binding ‘a’ + NB: Implicitly-bound variables always come before other ones. + • In the type signature: + bar :: forall a (c :: Proxy b) (d :: Proxy a). + Proxy c -> SameKind b d diff --git a/testsuite/tests/dependent/should_fail/BadTelescope3.hs b/testsuite/tests/dependent/should_fail/BadTelescope3.hs new file mode 100644 index 0000000000..807479f634 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope3.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope3 where + +import Data.Kind + +data SameKind :: k -> k -> * + +type S a k (b :: k) = SameKind a b diff --git a/testsuite/tests/dependent/should_fail/BadTelescope3.stderr b/testsuite/tests/dependent/should_fail/BadTelescope3.stderr new file mode 100644 index 0000000000..4ea7458bb2 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope3.stderr @@ -0,0 +1,6 @@ + +BadTelescope3.hs:9:1: error: + • These kind and type variables: (a :: k) k (b :: k) + are out of dependency order. Perhaps try this ordering: + k (a :: k) (b :: k) + • In the type synonym declaration for ‘S’ diff --git a/testsuite/tests/dependent/should_fail/BadTelescope4.hs b/testsuite/tests/dependent/should_fail/BadTelescope4.hs new file mode 100644 index 0000000000..566922a4a0 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope4.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ExistentialQuantification, TypeInType #-} +module BadTelescope4 where + +import Data.Proxy +import Data.Kind + +data SameKind :: k -> k -> * + +data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +data Borked a (b :: k) = forall (c :: k). B (Proxy c) + -- this last one is OK. But there was a bug involving renaming + -- that failed here, so the test case remains. diff --git a/testsuite/tests/dependent/should_fail/BadTelescope4.stderr b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr new file mode 100644 index 0000000000..158aec650d --- /dev/null +++ b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr @@ -0,0 +1,15 @@ + +BadTelescope4.hs:9:1: error: + • These kind and type variables: (a :: k1) + (c :: Proxy b) + (d :: Proxy a) + (x :: SameKind b d) + are out of dependency order. Perhaps try this ordering: + k1 + (a :: k1) + (b :: Proxy a) + (c :: Proxy b) + (d :: Proxy a) + (x :: SameKind b d) + NB: Implicitly declared kind variables are put first. + • In the data type declaration for ‘Bad’ diff --git a/testsuite/tests/dependent/should_fail/DepFail1.hs b/testsuite/tests/dependent/should_fail/DepFail1.hs new file mode 100644 index 0000000000..425a8159c4 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/DepFail1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType #-} + +module DepFail1 where + +data Proxy k (a :: k) = P + +z :: Proxy Bool +z = P + +a :: Proxy Int Bool +a = P diff --git a/testsuite/tests/dependent/should_fail/DepFail1.stderr b/testsuite/tests/dependent/should_fail/DepFail1.stderr new file mode 100644 index 0000000000..630f010fa3 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/DepFail1.stderr @@ -0,0 +1,12 @@ + +DepFail1.hs:7:6: error: + • Expecting one more argument to ‘Proxy Bool’ + Expected a type, but ‘Proxy Bool’ has kind ‘Bool -> *’ + • In the type signature: + z :: Proxy Bool + +DepFail1.hs:10:16: error: + • Expected kind ‘Int’, but ‘Bool’ has kind ‘*’ + • In the second argument of ‘Proxy’, namely ‘Bool’ + In the type signature: + a :: Proxy Int Bool diff --git a/testsuite/tests/dependent/should_fail/Makefile b/testsuite/tests/dependent/should_fail/Makefile new file mode 100644 index 0000000000..13938e423d --- /dev/null +++ b/testsuite/tests/dependent/should_fail/Makefile @@ -0,0 +1,5 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + + diff --git a/testsuite/tests/dependent/should_fail/PromotedClass.hs b/testsuite/tests/dependent/should_fail/PromotedClass.hs new file mode 100644 index 0000000000..6c3f415e5d --- /dev/null +++ b/testsuite/tests/dependent/should_fail/PromotedClass.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType, GADTs #-} + +module PromotedClass where + +import Data.Proxy + +data X a where + MkX :: Show a => a -> X a + +foo :: Proxy ('MkX 'True) +foo = Proxy diff --git a/testsuite/tests/dependent/should_fail/PromotedClass.stderr b/testsuite/tests/dependent/should_fail/PromotedClass.stderr new file mode 100644 index 0000000000..544124ed07 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/PromotedClass.stderr @@ -0,0 +1,6 @@ + +PromotedClass.hs:10:15: error: + • Illegal constraint in a type: Show a0 + • In the first argument of ‘Proxy’, namely ‘MkX True’ + In the type signature: + foo :: Proxy (MkX True) diff --git a/testsuite/tests/dependent/should_fail/RAE_T32a.hs b/testsuite/tests/dependent/should_fail/RAE_T32a.hs new file mode 100644 index 0000000000..08a4ad78a8 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/RAE_T32a.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, + PolyKinds, TypeFamilies, GADTs, TypeInType #-} + +module RAE_T32a where + +import Data.Kind + +data family Sing (k :: *) :: k -> * + +data TyArr' (a :: *) (b :: *) :: * +type TyArr (a :: *) (b :: *) = TyArr' a b -> * +type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: *) (b :: TyArr a *) :: * +type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> * +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data MkStar (p :: *) (x :: TyArr' p *) +type instance MkStar p @@ x = * +$(return []) + +data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where + Sigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). + Sing * p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r +$(return []) + +data instance Sing Sigma (Sigma p r) x where + SSigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) + (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). + Sing (Sing (r @@@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) + +-- I (RAE) believe this last definition is ill-typed. diff --git a/testsuite/tests/dependent/should_fail/RAE_T32a.stderr b/testsuite/tests/dependent/should_fail/RAE_T32a.stderr new file mode 100644 index 0000000000..1a54c7d53b --- /dev/null +++ b/testsuite/tests/dependent/should_fail/RAE_T32a.stderr @@ -0,0 +1,19 @@ + +RAE_T32a.hs:28:1: error: + Too many parameters to Sing: + x is unexpected; + expected only two parameters + In the data instance declaration for ‘Sing’ + +RAE_T32a.hs:28:20: error: + Expecting two more arguments to ‘Sigma’ + Expected a type, but + ‘Sigma’ has kind + ‘forall p -> TyPi p (MkStar p) -> *’ + In the first argument of ‘Sing’, namely ‘Sigma’ + In the data instance declaration for ‘Sing’ + +RAE_T32a.hs:28:27: error: + Expected kind ‘Sigma’, but ‘Sigma p r’ has kind ‘*’ + In the second argument of ‘Sing’, namely ‘Sigma p r’ + In the data instance declaration for ‘Sing’ diff --git a/testsuite/tests/dependent/should_fail/SelfDep.hs b/testsuite/tests/dependent/should_fail/SelfDep.hs new file mode 100644 index 0000000000..f54b92752b --- /dev/null +++ b/testsuite/tests/dependent/should_fail/SelfDep.hs @@ -0,0 +1,3 @@ +module SelfDep where + +data T :: T -> * diff --git a/testsuite/tests/dependent/should_fail/SelfDep.stderr b/testsuite/tests/dependent/should_fail/SelfDep.stderr new file mode 100644 index 0000000000..f4014f7277 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/SelfDep.stderr @@ -0,0 +1,5 @@ + +SelfDep.hs:3:11: error: + Type constructor ‘T’ cannot be used here + (it is defined and used in the same recursive group) + In the kind ‘T -> *’ diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs b/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs new file mode 100644 index 0000000000..09845ed87e --- /dev/null +++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes, PolyKinds, TypeInType #-} + +module TypeSkolEscape where + +import GHC.Types +import GHC.Exts + +type Bad = forall (v :: Levity) (a :: TYPE v). a diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr new file mode 100644 index 0000000000..1574c017ce --- /dev/null +++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr @@ -0,0 +1,7 @@ + +TypeSkolEscape.hs:8:1: error: + Quantified type's kind mentions quantified type variable + (skolem escape) + type: forall (v1 :: Levity) (a1 :: TYPE v1). a1 + of kind: TYPE v + In the type synonym declaration for ‘Bad’ diff --git a/testsuite/tests/dependent/should_fail/all.T b/testsuite/tests/dependent/should_fail/all.T new file mode 100644 index 0000000000..8d4b288e96 --- /dev/null +++ b/testsuite/tests/dependent/should_fail/all.T @@ -0,0 +1,9 @@ +test('DepFail1', normal, compile_fail, ['']) +test('RAE_T32a', normal, compile_fail, ['']) +test('TypeSkolEscape', normal, compile_fail, ['']) +test('BadTelescope', normal, compile_fail, ['']) +test('BadTelescope2', normal, compile_fail, ['']) +test('BadTelescope3', normal, compile_fail, ['']) +test('PromotedClass', normal, compile_fail, ['']) +test('SelfDep', normal, compile_fail, ['']) +test('BadTelescope4', normal, compile_fail, ['']) diff --git a/testsuite/tests/deriving/should_fail/T10524.hs b/testsuite/tests/deriving/should_compile/T10524.hs index 43d93bf862..cb5a8e370f 100644 --- a/testsuite/tests/deriving/should_fail/T10524.hs +++ b/testsuite/tests/deriving/should_compile/T10524.hs @@ -6,3 +6,4 @@ import Data.Data newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) +-- WrappedFunctor :: forall k. (k -> *) -> k -> * diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index f2fb80be02..36d49f5078 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -56,6 +56,7 @@ test('T4896', normal, compile, ['']) test('T7947', extra_clean(['T7947a.o', 'T7947a.hi', 'T7947b.o', 'T7947b.hi']), multimod_compile, ['T7947', '-v0']) test('T10561', normal, compile_fail, ['']) test('T10487', extra_clean(['T10487_M.o', 'T10487_M.hi']), multimod_compile, ['T10487', '-v0']) +test('T10524', normal, compile, ['']) test('T11148', normal, run_command, ['$MAKE -s --no-print-directory T11148']) test('T9968', normal, compile, ['']) diff --git a/testsuite/tests/deriving/should_fail/T1496.stderr b/testsuite/tests/deriving/should_fail/T1496.stderr index c9f3869846..c560f5fe0f 100644 --- a/testsuite/tests/deriving/should_fail/T1496.stderr +++ b/testsuite/tests/deriving/should_fail/T1496.stderr @@ -1,9 +1,9 @@ -T1496.hs:10:32: +T1496.hs:10:32: error: Couldn't match representation of type ‘c Int’ with that of ‘c Moo’ - arising from the coercion of the method ‘isInt’ - from type ‘forall (c :: * -> *). c Int -> c Int’ - to type ‘forall (c :: * -> *). c Int -> c Moo’ + arising from the coercion of the method ‘isInt’ + from type ‘forall (c :: * -> *). c Int -> c Int’ + to type ‘forall (c :: * -> *). c Int -> c Moo’ NB: We cannot know what roles the parameters to ‘c’ have; we must assume that the role is nominal When deriving the instance for (IsInt Moo) diff --git a/testsuite/tests/deriving/should_fail/T7959.stderr b/testsuite/tests/deriving/should_fail/T7959.stderr index 5ca93a7fe3..4756f793c8 100644 --- a/testsuite/tests/deriving/should_fail/T7959.stderr +++ b/testsuite/tests/deriving/should_fail/T7959.stderr @@ -1,8 +1,8 @@ -T7959.hs:5:1: - Cannot derive instances for nullary classes - In the stand-alone deriving instance for ‘A’ +T7959.hs:5:1: error: + • Cannot derive instances for nullary classes + • In the stand-alone deriving instance for ‘A’ -T7959.hs:6:17: - Expected kind ‘k0 -> Constraint’, but ‘A’ has kind ‘Constraint’ - In the data declaration for ‘B’ +T7959.hs:6:17: error: + • Expected kind ‘k0 -> Constraint’, but ‘A’ has kind ‘Constraint’ + • In the data declaration for ‘B’ diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T index 400b748435..e0c6e62bff 100644 --- a/testsuite/tests/deriving/should_fail/all.T +++ b/testsuite/tests/deriving/should_fail/all.T @@ -57,6 +57,5 @@ test('T9600-1', normal, compile_fail, ['']) test('T9687', normal, compile_fail, ['']) test('T8984', normal, compile_fail, ['']) -test('T10524', normal, compile_fail, ['']) test('T9968a', normal, compile_fail, ['']) diff --git a/testsuite/tests/deriving/should_fail/drvfail005.stderr b/testsuite/tests/deriving/should_fail/drvfail005.stderr index 1546a37d07..552b3b0291 100644 --- a/testsuite/tests/deriving/should_fail/drvfail005.stderr +++ b/testsuite/tests/deriving/should_fail/drvfail005.stderr @@ -1,5 +1,6 @@ -drvfail005.hs:4:13: - Expected kind ‘k0 -> Constraint’, - but ‘Show a’ has kind ‘Constraint’ - In the data declaration for ‘Test’ +drvfail005.hs:4:13: error: + • Expecting one fewer argument to ‘Show a’ + Expected kind ‘k0 -> Constraint’, + but ‘Show a’ has kind ‘Constraint’ + • In the data declaration for ‘Test’ diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index f58d4c4b8a..1b4f8e65ae 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -35,7 +35,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRuleTransitional", "OverloadedLabels", "TemplateHaskellQuotes", - "MonadFailDesugaring"] + "MonadFailDesugaring", + "TypeInType"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", diff --git a/testsuite/tests/driver/werror.stderr b/testsuite/tests/driver/werror.stderr index 20770fa8bc..ce6dba6347 100644 --- a/testsuite/tests/driver/werror.stderr +++ b/testsuite/tests/driver/werror.stderr @@ -16,7 +16,7 @@ werror.hs:10:1: Warning: Defined but not used: ‘f’ werror.hs:10:1: Warning: Top-level binding with no type signature: - f :: forall t t1. [t] -> [t1] + f :: forall r r1. [r] -> [r1] werror.hs:10:1: Warning: Pattern match(es) are redundant diff --git a/testsuite/tests/gadt/T3163.stderr b/testsuite/tests/gadt/T3163.stderr index 095378b540..c6b6a976da 100644 --- a/testsuite/tests/gadt/T3163.stderr +++ b/testsuite/tests/gadt/T3163.stderr @@ -1,5 +1,5 @@ -
-T3163.hs:8:5: error:
- Illegal polymorphic or qualified type: forall s. s
- In the definition of data constructor ‘Unreached’
- In the data type declaration for ‘Taker’
+ +T3163.hs:8:5: error: + Illegal polymorphic or qualified type: forall s1. s1 + In the definition of data constructor ‘Unreached’ + In the data type declaration for ‘Taker’ diff --git a/testsuite/tests/gadt/gadt-escape1.stderr b/testsuite/tests/gadt/gadt-escape1.stderr index 39d736adb8..829dfa0e2b 100644 --- a/testsuite/tests/gadt/gadt-escape1.stderr +++ b/testsuite/tests/gadt/gadt-escape1.stderr @@ -1,17 +1,17 @@ -gadt-escape1.hs:19:58: - Couldn't match type ‘t’ with ‘ExpGADT Int’ - ‘t’ is untouchable - inside the constraints: t1 ~ Int - bound by a pattern with constructor: ExpInt :: Int -> ExpGADT Int, - in a case alternative - at gadt-escape1.hs:19:43-50 - ‘t’ is a rigid type variable bound by - the inferred type of weird1 :: t at gadt-escape1.hs:19:1 - Possible fix: add a type signature for ‘weird1’ - Expected type: t - Actual type: ExpGADT t1 - In the expression: a - In a case alternative: Hidden (ExpInt _) a -> a - Relevant bindings include - weird1 :: t (bound at gadt-escape1.hs:19:1) +gadt-escape1.hs:19:58: error: + • Couldn't match type ‘r’ with ‘ExpGADT Int’ + ‘r’ is untouchable + inside the constraints: t ~ Int + bound by a pattern with constructor: ExpInt :: Int -> ExpGADT Int, + in a case alternative + at gadt-escape1.hs:19:43-50 + ‘r’ is a rigid type variable bound by + the inferred type of weird1 :: r at gadt-escape1.hs:19:1 + Possible fix: add a type signature for ‘weird1’ + Expected type: r + Actual type: ExpGADT t + • In the expression: a + In a case alternative: Hidden (ExpInt _) a -> a + • Relevant bindings include + weird1 :: r (bound at gadt-escape1.hs:19:1) diff --git a/testsuite/tests/gadt/gadt10.stderr b/testsuite/tests/gadt/gadt10.stderr index cc5230e2f2..97bd197a2a 100644 --- a/testsuite/tests/gadt/gadt10.stderr +++ b/testsuite/tests/gadt/gadt10.stderr @@ -1,7 +1,7 @@ -gadt10.hs:6:24: +gadt10.hs:6:24: error: Expecting one more argument to ‘RInt’ - Expected kind ‘*’, but ‘RInt’ has kind ‘k0 -> *’ + Expected a type, but ‘RInt’ has kind ‘k0 -> *’ In the type ‘RInt’ In the definition of data constructor ‘R’ In the data declaration for ‘RInt’ diff --git a/testsuite/tests/gadt/gadt13.stderr b/testsuite/tests/gadt/gadt13.stderr index ce56fe838e..44b100b059 100644 --- a/testsuite/tests/gadt/gadt13.stderr +++ b/testsuite/tests/gadt/gadt13.stderr @@ -1,16 +1,16 @@ -gadt13.hs:15:13: - Couldn't match expected type ‘t’ - with actual type ‘String -> [Char]’ - ‘t’ is untouchable - inside the constraints: t1 ~ Int - bound by a pattern with constructor: I :: Int -> Term Int, - in an equation for ‘shw’ - at gadt13.hs:15:6-8 - ‘t’ is a rigid type variable bound by - the inferred type of shw :: Term t1 -> t at gadt13.hs:15:1 - Possible fix: add a type signature for ‘shw’ - In the expression: ("I " ++) . shows t - In an equation for ‘shw’: shw (I t) = ("I " ++) . shows t - Relevant bindings include - shw :: Term t1 -> t (bound at gadt13.hs:15:1) +gadt13.hs:15:13: error: + • Couldn't match expected type ‘r’ + with actual type ‘String -> [Char]’ + ‘r’ is untouchable + inside the constraints: r1 ~ Int + bound by a pattern with constructor: I :: Int -> Term Int, + in an equation for ‘shw’ + at gadt13.hs:15:6-8 + ‘r’ is a rigid type variable bound by + the inferred type of shw :: Term r1 -> r at gadt13.hs:15:1 + Possible fix: add a type signature for ‘shw’ + • In the expression: ("I " ++) . shows t + In an equation for ‘shw’: shw (I t) = ("I " ++) . shows t + • Relevant bindings include + shw :: Term r1 -> r (bound at gadt13.hs:15:1) diff --git a/testsuite/tests/gadt/gadt7.stderr b/testsuite/tests/gadt/gadt7.stderr index e49cac1577..8720d7fe10 100644 --- a/testsuite/tests/gadt/gadt7.stderr +++ b/testsuite/tests/gadt/gadt7.stderr @@ -1,19 +1,19 @@ -gadt7.hs:16:38: - Couldn't match expected type ‘t’ with actual type ‘r’ - ‘r’ is untouchable - inside the constraints: t1 ~ Int - bound by a pattern with constructor: K :: T Int, - in a case alternative - at gadt7.hs:16:33 +gadt7.hs:16:38: error: + • Couldn't match expected type ‘r’ with actual type ‘r1’ + ‘r’ is untouchable + inside the constraints: t ~ Int + bound by a pattern with constructor: K :: T Int, + in a case alternative + at gadt7.hs:16:33 ‘r’ is a rigid type variable bound by - the inferred type of i1b :: T t1 -> r -> t at gadt7.hs:16:1 - ‘t’ is a rigid type variable bound by - the inferred type of i1b :: T t1 -> r -> t at gadt7.hs:16:1 - Possible fix: add a type signature for ‘i1b’ - In the expression: y1 - In a case alternative: K -> y1 - Relevant bindings include - y1 :: r (bound at gadt7.hs:16:16) - y :: r (bound at gadt7.hs:16:7) - i1b :: T t1 -> r -> t (bound at gadt7.hs:16:1) + the inferred type of i1b :: T t -> r1 -> r at gadt7.hs:16:1 + ‘r1’ is a rigid type variable bound by + the inferred type of i1b :: T t -> r1 -> r at gadt7.hs:16:1 + Possible fix: add a type signature for ‘i1b’ + • In the expression: y1 + In a case alternative: K -> y1 + • Relevant bindings include + y1 :: r1 (bound at gadt7.hs:16:16) + y :: r1 (bound at gadt7.hs:16:7) + i1b :: T t -> r1 -> r (bound at gadt7.hs:16:1) diff --git a/testsuite/tests/ghc-api/annotations/T10307.stdout b/testsuite/tests/ghc-api/annotations/T10307.stdout index 26a255dca9..48cbca6cd0 100644 --- a/testsuite/tests/ghc-api/annotations/T10307.stdout +++ b/testsuite/tests/ghc-api/annotations/T10307.stdout @@ -12,7 +12,6 @@ ((Test10307.hs:5:3-34,AnnDcolon), [Test10307.hs:5:31-32]), ((Test10307.hs:5:3-34,AnnSemi), [Test10307.hs:6:3]), ((Test10307.hs:5:3-34,AnnType), [Test10307.hs:5:3-6]), -((Test10307.hs:5:34,AnnStar), [Test10307.hs:5:34]), ((Test10307.hs:6:3-34,AnnEqual), [Test10307.hs:6:31]), ((Test10307.hs:6:3-34,AnnType), [Test10307.hs:6:3-6]), ((Test10307.hs:6:8-34,AnnEqual), [Test10307.hs:6:31]), diff --git a/testsuite/tests/ghc-api/annotations/T10312.stderr b/testsuite/tests/ghc-api/annotations/T10312.stderr index 8fc7a0c0bf..e5c16948f2 100644 --- a/testsuite/tests/ghc-api/annotations/T10312.stderr +++ b/testsuite/tests/ghc-api/annotations/T10312.stderr @@ -1,2 +1,2 @@ -
-Test10312.hs:77:38: error: Not in scope: data constructor ‘Fixity’
+ +Test10312.hs:77:38: error: Not in scope: data constructor ‘Fixity’ diff --git a/testsuite/tests/ghc-api/annotations/T10312.stdout b/testsuite/tests/ghc-api/annotations/T10312.stdout index 61fea45a33..00f25444cc 100644 --- a/testsuite/tests/ghc-api/annotations/T10312.stdout +++ b/testsuite/tests/ghc-api/annotations/T10312.stdout @@ -33,7 +33,6 @@ ((Test10312.hs:(16,19)-(20,19),AnnVbar), [Test10312.hs:17:19]), ((Test10312.hs:16:21-25,AnnVal), [Test10312.hs:16:23]), ((Test10312.hs:16:21-29,AnnVal), [Test10312.hs:16:27]), -((Test10312.hs:16:27,AnnStar), [Test10312.hs:16:27]), ((Test10312.hs:17:21-32,AnnComma), [Test10312.hs:18:19]), ((Test10312.hs:17:21-32,AnnLarrow), [Test10312.hs:17:23-24]), ((Test10312.hs:17:26-32,AnnCloseS), [Test10312.hs:17:32]), @@ -60,7 +59,6 @@ ((Test10312.hs:(23,20)-(27,20),AnnVbar), [Test10312.hs:24:20]), ((Test10312.hs:23:22-26,AnnVal), [Test10312.hs:23:24]), ((Test10312.hs:23:22-30,AnnVal), [Test10312.hs:23:28]), -((Test10312.hs:23:28,AnnStar), [Test10312.hs:23:28]), ((Test10312.hs:24:22-33,AnnLarrow), [Test10312.hs:24:24-25]), ((Test10312.hs:24:22-33,AnnVbar), [Test10312.hs:25:20]), ((Test10312.hs:24:27-33,AnnCloseS), [Test10312.hs:24:33]), diff --git a/testsuite/tests/ghc-api/annotations/T10357.stderr b/testsuite/tests/ghc-api/annotations/T10357.stderr index b394ffa49b..09f29ddfb8 100644 --- a/testsuite/tests/ghc-api/annotations/T10357.stderr +++ b/testsuite/tests/ghc-api/annotations/T10357.stderr @@ -1,37 +1,37 @@ -
-Test10357.hs:4:13: error: Variable not in scope: one
-
-Test10357.hs:4:19: error: Variable not in scope: x
-
-Test10357.hs:5:7: error:
- Variable not in scope: multPoly :: t3 -> t4 -> t
-
-Test10357.hs:6:10: error:
- Variable not in scope: poly :: t0 -> [Double] -> t3
-
-Test10357.hs:6:15: error:
- Data constructor not in scope: LE
- Perhaps you meant ‘LT’ (imported from Prelude)
-
-Test10357.hs:7:10: error:
- Variable not in scope: addPoly :: t5 -> t6 -> t4
-
-Test10357.hs:7:19: error:
- Variable not in scope: poly :: t1 -> [Double] -> t7
-
-Test10357.hs:7:24: error:
- Data constructor not in scope: LE
- Perhaps you meant ‘LT’ (imported from Prelude)
-
-Test10357.hs:7:43: error:
- Variable not in scope: multPoly :: t7 -> t -> t5
-
-Test10357.hs:8:19: error:
- Variable not in scope: poly :: t2 -> [Double] -> t8
-
-Test10357.hs:8:24: error:
- Data constructor not in scope: LE
- Perhaps you meant ‘LT’ (imported from Prelude)
-
-Test10357.hs:8:43: error:
- Variable not in scope: multPoly :: t8 -> t -> t6
+ +Test10357.hs:4:13: error: Variable not in scope: one + +Test10357.hs:4:19: error: Variable not in scope: x + +Test10357.hs:5:7: error: + Variable not in scope: multPoly :: t0 -> t1 -> t + +Test10357.hs:6:10: error: + Variable not in scope: poly :: t2 -> [Double] -> t0 + +Test10357.hs:6:15: error: + Data constructor not in scope: LE + Perhaps you meant ‘LT’ (imported from Prelude) + +Test10357.hs:7:10: error: + Variable not in scope: addPoly :: t3 -> t4 -> t1 + +Test10357.hs:7:19: error: + Variable not in scope: poly :: t6 -> [Double] -> t5 + +Test10357.hs:7:24: error: + Data constructor not in scope: LE + Perhaps you meant ‘LT’ (imported from Prelude) + +Test10357.hs:7:43: error: + Variable not in scope: multPoly :: t5 -> t -> t3 + +Test10357.hs:8:19: error: + Variable not in scope: poly :: t8 -> [Double] -> t7 + +Test10357.hs:8:24: error: + Data constructor not in scope: LE + Perhaps you meant ‘LT’ (imported from Prelude) + +Test10357.hs:8:43: error: + Variable not in scope: multPoly :: t7 -> t -> t4 diff --git a/testsuite/tests/ghc-api/annotations/T10357.stdout b/testsuite/tests/ghc-api/annotations/T10357.stdout index cbbb84e2ee..15d5139be5 100644 --- a/testsuite/tests/ghc-api/annotations/T10357.stdout +++ b/testsuite/tests/ghc-api/annotations/T10357.stdout @@ -31,7 +31,6 @@ ((Test10357.hs:7:28,AnnComma), [Test10357.hs:7:29]), ((Test10357.hs:7:31-36,AnnVal), [Test10357.hs:7:33]), ((Test10357.hs:7:31-40,AnnVal), [Test10357.hs:7:38]), -((Test10357.hs:7:33,AnnStar), [Test10357.hs:7:33]), ((Test10357.hs:7:43-52,AnnBackquote), [Test10357.hs:7:43, Test10357.hs:7:52]), ((Test10357.hs:7:43-52,AnnVal), [Test10357.hs:7:44-51]), ((Test10357.hs:8:18-59,AnnCloseP), [Test10357.hs:8:59]), diff --git a/testsuite/tests/ghc-api/annotations/T10358.stdout b/testsuite/tests/ghc-api/annotations/T10358.stdout index 2bcbf68c09..ae1ec8587f 100644 --- a/testsuite/tests/ghc-api/annotations/T10358.stdout +++ b/testsuite/tests/ghc-api/annotations/T10358.stdout @@ -15,23 +15,18 @@ ((Test10358.hs:5:7-16,AnnEqual), [Test10358.hs:5:12]), ((Test10358.hs:5:7-16,AnnSemi), [Test10358.hs:5:17]), ((Test10358.hs:5:14-16,AnnVal), [Test10358.hs:5:15]), -((Test10358.hs:5:15,AnnStar), [Test10358.hs:5:15]), ((Test10358.hs:5:19-22,AnnBang), [Test10358.hs:5:19]), ((Test10358.hs:5:19-32,AnnEqual), [Test10358.hs:5:24]), ((Test10358.hs:5:19-32,AnnSemi), [Test10358.hs:6:7]), ((Test10358.hs:5:26-32,AnnVal), [Test10358.hs:5:29]), -((Test10358.hs:5:29,AnnStar), [Test10358.hs:5:29]), ((Test10358.hs:6:7-16,AnnEqual), [Test10358.hs:6:10]), ((Test10358.hs:6:7-16,AnnFunId), [Test10358.hs:6:7-8]), ((Test10358.hs:6:7-16,AnnSemi), [Test10358.hs:7:7]), ((Test10358.hs:6:12-14,AnnVal), [Test10358.hs:6:13]), ((Test10358.hs:6:12-16,AnnVal), [Test10358.hs:6:15]), -((Test10358.hs:6:13,AnnStar), [Test10358.hs:6:13]), -((Test10358.hs:6:15,AnnStar), [Test10358.hs:6:15]), ((Test10358.hs:7:7-17,AnnEqual), [Test10358.hs:7:10]), ((Test10358.hs:7:7-17,AnnFunId), [Test10358.hs:7:7-8]), ((Test10358.hs:7:12-17,AnnVal), [Test10358.hs:7:14]), -((Test10358.hs:7:14,AnnStar), [Test10358.hs:7:14]), ((<no location info>,AnnEofPos), [Test10358.hs:9:1]) ] diff --git a/testsuite/tests/ghc-api/annotations/T11018.stderr b/testsuite/tests/ghc-api/annotations/T11018.stderr index c58942f4c7..86d30ec5ed 100644 --- a/testsuite/tests/ghc-api/annotations/T11018.stderr +++ b/testsuite/tests/ghc-api/annotations/T11018.stderr @@ -20,7 +20,7 @@ Test11018.hs:26:7: error: Not in scope: type constructor or class ‘ArrowApply’ Test11018.hs:37:27: error: - Illegal kind signature: ‘* -> *’ + Illegal kind signature: ‘★ -> ★’ Perhaps you intended to use KindSignatures In the data type declaration for ‘RecorderU’ diff --git a/testsuite/tests/ghc-api/annotations/T11018.stdout b/testsuite/tests/ghc-api/annotations/T11018.stdout index d05c13f213..ac32549858 100644 --- a/testsuite/tests/ghc-api/annotations/T11018.stdout +++ b/testsuite/tests/ghc-api/annotations/T11018.stdout @@ -23,9 +23,8 @@ ((Test11018.hs:12:21-32,AnnCloseP), [Test11018.hs:12:32]), ((Test11018.hs:12:21-32,AnnDcolonU), [Test11018.hs:12:24]), ((Test11018.hs:12:21-32,AnnOpenP), [Test11018.hs:12:21]), -((Test11018.hs:12:26,AnnStar), [Test11018.hs:12:26]), +((Test11018.hs:12:26,AnnRarrow), [Test11018.hs:12:28-29]), ((Test11018.hs:12:26-31,AnnRarrow), [Test11018.hs:12:28-29]), -((Test11018.hs:12:31,AnnStar), [Test11018.hs:12:31]), ((Test11018.hs:(13,16)-(15,7),AnnCloseC), [Test11018.hs:15:7]), ((Test11018.hs:(13,16)-(15,7),AnnOpenC), [Test11018.hs:13:16]), ((Test11018.hs:14:9-40,AnnDcolon), [Test11018.hs:14:18-19]), @@ -119,9 +118,8 @@ ((Test11018.hs:37:22-32,AnnCloseP), [Test11018.hs:37:32]), ((Test11018.hs:37:22-32,AnnDcolonU), [Test11018.hs:37:25]), ((Test11018.hs:37:22-32,AnnOpenP), [Test11018.hs:37:22]), -((Test11018.hs:37:27,AnnStarU), [Test11018.hs:37:27]), +((Test11018.hs:37:27,AnnRarrowU), [Test11018.hs:37:29]), ((Test11018.hs:37:27-31,AnnRarrowU), [Test11018.hs:37:29]), -((Test11018.hs:37:31,AnnStarU), [Test11018.hs:37:31]), ((Test11018.hs:(38,17)-(40,7),AnnCloseC), [Test11018.hs:40:7]), ((Test11018.hs:(38,17)-(40,7),AnnOpenC), [Test11018.hs:38:17]), ((Test11018.hs:39:9-40,AnnDcolonU), [Test11018.hs:39:19]), diff --git a/testsuite/tests/ghc-api/annotations/exampleTest.stdout b/testsuite/tests/ghc-api/annotations/exampleTest.stdout index 9ae9f2300a..a884f56a32 100644 --- a/testsuite/tests/ghc-api/annotations/exampleTest.stdout +++ b/testsuite/tests/ghc-api/annotations/exampleTest.stdout @@ -65,9 +65,8 @@ ((AnnotationTuple.hs:18:1-28,AnnDcolon), [AnnotationTuple.hs:18:20-21]), ((AnnotationTuple.hs:18:1-28,AnnFamily), [AnnotationTuple.hs:18:6-11]), ((AnnotationTuple.hs:18:1-28,AnnSemi), [AnnotationTuple.hs:19:1]), -((AnnotationTuple.hs:18:23,AnnStar), [AnnotationTuple.hs:18:23]), +((AnnotationTuple.hs:18:23,AnnRarrow), [AnnotationTuple.hs:18:25-26]), ((AnnotationTuple.hs:18:23-28,AnnRarrow), [AnnotationTuple.hs:18:25-26]), -((AnnotationTuple.hs:18:28,AnnStar), [AnnotationTuple.hs:18:28]), ((AnnotationTuple.hs:(20,1)-(24,14),AnnFunId), [AnnotationTuple.hs:20:1-5]), ((AnnotationTuple.hs:(20,1)-(24,14),AnnSemi), [AnnotationTuple.hs:25:1]), ((AnnotationTuple.hs:(21,7)-(24,14),AnnEqual), [AnnotationTuple.hs:24:7]), diff --git a/testsuite/tests/ghc-api/annotations/listcomps.stdout b/testsuite/tests/ghc-api/annotations/listcomps.stdout index 754c170f39..1c0b8e5ce4 100644 --- a/testsuite/tests/ghc-api/annotations/listcomps.stdout +++ b/testsuite/tests/ghc-api/annotations/listcomps.stdout @@ -97,8 +97,6 @@ (AK ListComprehensions.hs:18:22-30 AnnVal = [ListComprehensions.hs:18:28]) -(AK ListComprehensions.hs:18:28 AnnStar = [ListComprehensions.hs:18:28]) - (AK ListComprehensions.hs:19:22-33 AnnLarrow = [ListComprehensions.hs:19:24-25]) (AK ListComprehensions.hs:19:22-33 AnnVbar = [ListComprehensions.hs:20:20]) diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout index d3e1a5a7dd..46b1c4fbb4 100644 --- a/testsuite/tests/ghc-api/annotations/parseTree.stdout +++ b/testsuite/tests/ghc-api/annotations/parseTree.stdout @@ -132,12 +132,10 @@ (AK AnnotationTuple.hs:18:1-28 AnnSemi = [AnnotationTuple.hs:19:1]) -(AK AnnotationTuple.hs:18:23 AnnStar = [AnnotationTuple.hs:18:23]) +(AK AnnotationTuple.hs:18:23 AnnRarrow = [AnnotationTuple.hs:18:25-26]) (AK AnnotationTuple.hs:18:23-28 AnnRarrow = [AnnotationTuple.hs:18:25-26]) -(AK AnnotationTuple.hs:18:28 AnnStar = [AnnotationTuple.hs:18:28]) - (AK AnnotationTuple.hs:(20,1)-(24,14) AnnFunId = [AnnotationTuple.hs:20:1-5]) (AK AnnotationTuple.hs:(20,1)-(24,14) AnnSemi = [AnnotationTuple.hs:25:1]) diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index 551b2cf8d7..ccb6b3107e 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ (12,12,7) -(63,63,0) -(13,13,7) +(70,63,0) +(14,13,7) (10,10,7) diff --git a/testsuite/tests/ghci.debugger/scripts/break001.stdout b/testsuite/tests/ghci.debugger/scripts/break001.stdout index c3146e2351..02ba1bbe93 100644 --- a/testsuite/tests/ghci.debugger/scripts/break001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break001.stdout @@ -1,12 +1,12 @@ Breakpoint 0 activated at ../Test2.hs:3:1-9 Breakpoint 1 activated at ../Test2.hs:5:1-7 Stopped at ../Test2.hs:3:1-9 -_result :: t = _ +_result :: r = _ Stopped at ../Test2.hs:3:7-9 _result :: Integer = _ x :: Integer = 1 Stopped at ../Test2.hs:5:1-7 -_result :: t = _ +_result :: r = _ Stopped at ../Test2.hs:5:7 _result :: Integer = _ y :: Integer = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stderr b/testsuite/tests/ghci.debugger/scripts/break003.stderr index bf3d2ef5a4..c19e8b45ce 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break003.stderr @@ -1,5 +1,5 @@ <interactive>:4:1: error: - No instance for (Show (t -> t1)) arising from a use of ‘print’ + No instance for (Show (t1 -> t)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stdout b/testsuite/tests/ghci.debugger/scripts/break003.stdout index a48f74c4c3..b1aa8ba2d2 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break003.stdout @@ -1,6 +1,6 @@ Breakpoint 0 activated at ../Test3.hs:2:18-31 Stopped at ../Test3.hs:2:18-31 -_result :: [t1] = _ -f :: t -> t1 = _ -x :: t = _ -xs :: [t] = [_] +_result :: [t] = _ +f :: t1 -> t = _ +x :: t1 = _ +xs :: [t1] = [_] diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index 56f40f2b21..f1567ed7ff 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -1,14 +1,14 @@ <interactive>:5:1: error: - No instance for (Show t1) arising from a use of ‘print’ - Cannot resolve unknown runtime type ‘t1’ + No instance for (Show t) arising from a use of ‘print’ + Cannot resolve unknown runtime type ‘t’ Use :print or :force to determine these types - Relevant bindings include it :: t1 (bound at <interactive>:5:1) + Relevant bindings include it :: t (bound at <interactive>:5:1) These potential instances exist: instance (Show a, Show b) => Show (Either a b) -- Defined in ‘Data.Either’ instance Show All -- Defined in ‘Data.Monoid’ - instance forall (k :: BOX) (f :: k -> *) (a :: k). + instance forall k (f :: k -> *) (a :: k). Show (f a) => Show (Alt f a) -- Defined in ‘Data.Monoid’ @@ -17,15 +17,15 @@ In a stmt of an interactive GHCi command: print it <interactive>:7:1: error: - No instance for (Show t1) arising from a use of ‘print’ - Cannot resolve unknown runtime type ‘t1’ + No instance for (Show t) arising from a use of ‘print’ + Cannot resolve unknown runtime type ‘t’ Use :print or :force to determine these types - Relevant bindings include it :: t1 (bound at <interactive>:7:1) + Relevant bindings include it :: t (bound at <interactive>:7:1) These potential instances exist: instance (Show a, Show b) => Show (Either a b) -- Defined in ‘Data.Either’ instance Show All -- Defined in ‘Data.Monoid’ - instance forall (k :: BOX) (f :: k -> *) (a :: k). + instance forall k (f :: k -> *) (a :: k). Show (f a) => Show (Alt f a) -- Defined in ‘Data.Monoid’ diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stdout b/testsuite/tests/ghci.debugger/scripts/break006.stdout index 7e5edbf9d2..374fffd29a 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break006.stdout @@ -1,15 +1,15 @@ Stopped at ../Test3.hs:(1,1)-(2,31) -_result :: [t1] = _ +_result :: [t] = _ Stopped at ../Test3.hs:2:18-31 -_result :: [t1] = _ -f :: Integer -> t1 = _ +_result :: [t] = _ +f :: Integer -> t = _ x :: Integer = 1 xs :: [Integer] = [2,3] xs :: [Integer] = [2,3] x :: Integer = 1 -f :: Integer -> t1 = _ -_result :: [t1] = _ -y = (_t1::t1) +f :: Integer -> t = _ +_result :: [t] = _ +y = (_t1::t) y = 2 xs :: [Integer] = [2,3] x :: Integer = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/break012.stdout b/testsuite/tests/ghci.debugger/scripts/break012.stdout index 88e8b3ee71..6b023718dc 100644 --- a/testsuite/tests/ghci.debugger/scripts/break012.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break012.stdout @@ -1,16 +1,16 @@ Stopped at break012.hs:(1,1)-(5,18) -_result :: (t, a3 -> a3, (), a2 -> a2 -> a2) = _ +_result :: (r, a3 -> a3, (), a2 -> a2 -> a2) = _ Stopped at break012.hs:5:10-18 -_result :: (t, a3 -> a3, (), a2 -> a2 -> a2) = _ -a :: t = _ +_result :: (r, a3 -> a3, (), a2 -> a2 -> a2) = _ +a :: r = _ b :: a4 -> a4 = _ c :: () = _ d :: a2 -> a2 -> a2 = _ -a :: t +a :: r b :: a4 -> a4 c :: () d :: a2 -> a2 -> a2 -a = (_t1::t) +a = (_t1::r) b = (_t2::a4 -> a4) c = (_t3::()) d = (_t4::a2 -> a2 -> a2) diff --git a/testsuite/tests/ghci.debugger/scripts/break018.stdout b/testsuite/tests/ghci.debugger/scripts/break018.stdout index 11ef5476b5..d9c6b6e06a 100644 --- a/testsuite/tests/ghci.debugger/scripts/break018.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break018.stdout @@ -1,5 +1,5 @@ Stopped at ../mdo.hs:(30,1)-(32,27) -_result :: IO (N a6) = _ +_result :: IO (N a7) = _ Stopped at ../mdo.hs:(30,16)-(32,27) _result :: IO (N Char) = _ x :: Char = 'h' @@ -10,4 +10,4 @@ f :: N Char = _ l :: N Char = _ x :: Char = 'h' Stopped at ../mdo.hs:(8,1)-(9,42) -_result :: IO (N a6) = _ +_result :: IO (N a7) = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout index a87ffce942..f4b804296f 100644 --- a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout @@ -5,4 +5,4 @@ Stopped at A.hs:4:7-9 _result :: () = _ x :: () = () Stopped at B.hs:5:1-7 -_result :: t = _ +_result :: r = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break026.stdout b/testsuite/tests/ghci.debugger/scripts/break026.stdout index 8d81867044..9afc3f470e 100644 --- a/testsuite/tests/ghci.debugger/scripts/break026.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break026.stdout @@ -1,58 +1,58 @@ -Stopped at break026.hs:(5,1)-(7,35)
-_result :: t1 = _
-Stopped at break026.hs:5:16-22
-_result :: Integer = _
-c :: Integer = 0
-go :: Integer -> [t] -> Integer = _
-xs :: [t] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t1 = _
-f :: t1 -> t -> t1 = _
-Stopped at break026.hs:7:23-35
-_result :: Integer = _
-c :: Integer = 0
-f :: Integer -> Integer -> Integer = _
-x :: Integer = 1
-xs :: [Integer] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t1 = _
-f :: t1 -> t -> t1 = _
-Stopped at break026.hs:7:23-35
-_result :: t1 = _
-c :: t1 = _
-f :: t1 -> Integer -> t1 = _
-x :: Integer = 2
-xs :: [Integer] = _
-c = 1
-Stopped at break026.hs:(5,1)-(7,35)
-_result :: t1 = _
-Stopped at break026.hs:5:16-22
-_result :: Integer = _
-c :: Integer = 0
-go :: Integer -> [t] -> Integer = _
-xs :: [t] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t1 = _
-f :: t1 -> t -> t1 = _
-Stopped at break026.hs:7:23-35
-_result :: Integer = _
-c :: Integer = 0
-f :: Integer -> Integer -> Integer = _
-x :: Integer = 1
-xs :: [Integer] = _
-Stopped at break026.hs:(6,9)-(7,35)
-_result :: t1 = _
-f :: t1 -> t -> t1 = _
-Stopped at break026.hs:7:23-35
-_result :: t1 = _
-c :: t1 = _
-f :: t1 -> Integer -> t1 = _
-x :: Integer = 2
-xs :: [Integer] = _
-Stopped at break026.hs:7:27-31
-_result :: Integer = _
-c :: Integer = 0
-f :: Integer -> Integer -> Integer = _
-x :: Integer = 1
-()
-1
+Stopped at break026.hs:(5,1)-(7,35) +_result :: t = _ +Stopped at break026.hs:5:16-22 +_result :: Integer = _ +c :: Integer = 0 +go :: Integer -> [t1] -> Integer = _ +xs :: [t1] = _ +Stopped at break026.hs:(6,9)-(7,35) +_result :: t = _ +f :: t -> t1 -> t = _ +Stopped at break026.hs:7:23-35 +_result :: Integer = _ +c :: Integer = 0 +f :: Integer -> Integer -> Integer = _ +x :: Integer = 1 +xs :: [Integer] = _ +Stopped at break026.hs:(6,9)-(7,35) +_result :: t = _ +f :: t -> t1 -> t = _ +Stopped at break026.hs:7:23-35 +_result :: t = _ +c :: t = _ +f :: t -> Integer -> t = _ +x :: Integer = 2 +xs :: [Integer] = _ +c = 1 +Stopped at break026.hs:(5,1)-(7,35) +_result :: t = _ +Stopped at break026.hs:5:16-22 +_result :: Integer = _ +c :: Integer = 0 +go :: Integer -> [t1] -> Integer = _ +xs :: [t1] = _ +Stopped at break026.hs:(6,9)-(7,35) +_result :: t = _ +f :: t -> t1 -> t = _ +Stopped at break026.hs:7:23-35 +_result :: Integer = _ +c :: Integer = 0 +f :: Integer -> Integer -> Integer = _ +x :: Integer = 1 +xs :: [Integer] = _ +Stopped at break026.hs:(6,9)-(7,35) +_result :: t = _ +f :: t -> t1 -> t = _ +Stopped at break026.hs:7:23-35 +_result :: t = _ +c :: t = _ +f :: t -> Integer -> t = _ +x :: Integer = 2 +xs :: [Integer] = _ +Stopped at break026.hs:7:27-31 +_result :: Integer = _ +c :: Integer = 0 +f :: Integer -> Integer -> Integer = _ +x :: Integer = 1 +() +1 diff --git a/testsuite/tests/ghci.debugger/scripts/break028.stdout b/testsuite/tests/ghci.debugger/scripts/break028.stdout index 896a2416ef..bbe47267b0 100644 --- a/testsuite/tests/ghci.debugger/scripts/break028.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break028.stdout @@ -1,5 +1,5 @@ Stopped at break028.hs:15:1-24 -_result :: Id a3 = _ +_result :: Id a4 = _ Stopped at break028.hs:15:23-24 -_result :: Id a3 = _ -x' :: Id a3 = _ +_result :: Id a4 = _ +x' :: Id a4 = _ diff --git a/testsuite/tests/ghci.debugger/scripts/hist001.stdout b/testsuite/tests/ghci.debugger/scripts/hist001.stdout index 0b58b8fcb7..3a70f6aa1e 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist001.stdout @@ -12,20 +12,20 @@ _result :: [a] = _ -9 : mymap (../Test3.hs:(1,1)-(2,31)) <end of history> Logged breakpoint at ../Test3.hs:(1,1)-(2,31) -_result :: [t1] -_result :: [t1] = _ +_result :: [t] +_result :: [t] = _ Logged breakpoint at ../Test3.hs:2:22-31 -_result :: [t1] -f :: t -> t1 -xs :: [t] -xs :: [t] = [] -f :: t -> t1 = _ -_result :: [t1] = _ +_result :: [t] +f :: t1 -> t +xs :: [t1] +xs :: [t1] = [] +f :: t1 -> t = _ +_result :: [t] = _ *** Ignoring breakpoint _result = [] Logged breakpoint at ../Test3.hs:2:18-20 -_result :: t1 -f :: Integer -> t1 +_result :: t +f :: Integer -> t x :: Integer Logged breakpoint at ../Test3.hs:2:22-31 -_result :: [t1] +_result :: [t] diff --git a/testsuite/tests/ghci.debugger/scripts/print018.stdout b/testsuite/tests/ghci.debugger/scripts/print018.stdout index a00d5374dd..614b7d3657 100644 --- a/testsuite/tests/ghci.debugger/scripts/print018.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print018.stdout @@ -3,9 +3,9 @@ Stopped at ../Test.hs:40:1-17 _result :: () = _ Stopped at ../Test.hs:40:10-17 _result :: () = _ -x :: a36 = _ -x = (_t1::a36) -x :: a36 +x :: a41 = _ +x = (_t1::a41) +x :: a41 () x = Unary x :: Unary diff --git a/testsuite/tests/ghci.debugger/scripts/print022.stdout b/testsuite/tests/ghci.debugger/scripts/print022.stdout index 8aa539418a..85111a2c7e 100644 --- a/testsuite/tests/ghci.debugger/scripts/print022.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print022.stdout @@ -2,9 +2,9 @@ test = C 1 32 1.2 1.23 'x' 1 1.2 1.23 Breakpoint 0 activated at print022.hs:11:1-7 Stopped at print022.hs:11:1-7 -_result :: t = _ +_result :: r = _ Stopped at print022.hs:11:7 -_result :: t = _ -x :: t = _ +_result :: r = _ +x :: r = _ x = C2 1 (W# 32) (TwoFields 'a' 3) x :: T2 diff --git a/testsuite/tests/ghci.debugger/scripts/print025.stdout b/testsuite/tests/ghci.debugger/scripts/print025.stdout index b2fcf65b1b..3936640210 100644 --- a/testsuite/tests/ghci.debugger/scripts/print025.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print025.stdout @@ -1,7 +1,7 @@ T 1 Breakpoint 0 activated at print025.hs:2:1-7 Stopped at print025.hs:2:1-7 -_result :: t = _ +_result :: r = _ Stopped at print025.hs:2:7 _result :: T Int s = _ x :: T Int s = T 1 diff --git a/testsuite/tests/ghci.debugger/scripts/print031.stdout b/testsuite/tests/ghci.debugger/scripts/print031.stdout index da3e14238d..81a2518a31 100644 --- a/testsuite/tests/ghci.debugger/scripts/print031.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print031.stdout @@ -4,5 +4,5 @@ Stopped at print031.hs:7:1-19 _result :: Bool = _ Stopped at print031.hs:7:7-19 _result :: Bool = _ -x :: t (Phantom a5) = [Just (Phantom 1)] +x :: t (Phantom a6) = [Just (Phantom 1)] x = [Just (Phantom 1)] diff --git a/testsuite/tests/ghci.debugger/scripts/print036.stdout b/testsuite/tests/ghci.debugger/scripts/print036.stdout index d932b467a5..b9862354ab 100644 --- a/testsuite/tests/ghci.debugger/scripts/print036.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print036.stdout @@ -1,2 +1 @@ read = (_t1::Read a => String -> a) -_t1 :: Read a => String -> a diff --git a/testsuite/tests/ghci/prog009/ghci.prog009.stdout b/testsuite/tests/ghci/prog009/ghci.prog009.stdout index 74d4c49e88..20c759782f 100644 --- a/testsuite/tests/ghci/prog009/ghci.prog009.stdout +++ b/testsuite/tests/ghci/prog009/ghci.prog009.stdout @@ -1,8 +1,8 @@ -nub :: Eq a => [a] -> [a]
-"tan"
-nub :: Eq a => [a] -> [a]
-"tan"
-nub :: Eq a => [a] -> [a]
-A ( A.hs, interpreted )
-nub :: Eq a => [a] -> [a]
-"tan"
+nub :: Eq a => [a] -> [a] +"tan" +nub :: Eq a => [a] -> [a] +"tan" +nub :: Eq a => [a] -> [a] +A ( A.hs, interpreted ) +nub :: Eq a => [a] -> [a] +"tan" diff --git a/testsuite/tests/ghci/scripts/Defer02.stderr b/testsuite/tests/ghci/scripts/Defer02.stderr index 8b63df689a..ad39191d08 100644 --- a/testsuite/tests/ghci/scripts/Defer02.stderr +++ b/testsuite/tests/ghci/scripts/Defer02.stderr @@ -12,6 +12,11 @@ • In the expression: 'p' In an equation for ‘a’: a = 'p' +../../typecheck/should_run/Defer01.hs:18:9: warning: + • No instance for (Eq B) arising from a use of ‘==’ + • In the expression: x == x + In an equation for ‘b’: b x = x == x + ../../typecheck/should_run/Defer01.hs:25:1: warning: Pattern match(es) have inaccessible right hand side In an equation for ‘c’: c (C2 x) = ... @@ -173,7 +178,7 @@ (deferred type error) <interactive>:13:8: error: - • Couldn't match expected type ‘Bool’ with actual type ‘Int’ + • Couldn't match type ‘Int’ with ‘Bool’ arising from a use of ‘k’ • In the first argument of ‘print’, namely ‘(k 2)’ In the expression: print (k 2) In an equation for ‘it’: it = print (k 2) diff --git a/testsuite/tests/ghci/scripts/Defer02.stdout b/testsuite/tests/ghci/scripts/Defer02.stdout index 4fd8c5d880..9d68933c44 100644 --- a/testsuite/tests/ghci/scripts/Defer02.stdout +++ b/testsuite/tests/ghci/scripts/Defer02.stdout @@ -1 +1 @@ -Hello World("
\ No newline at end of file +"
\ No newline at end of file diff --git a/testsuite/tests/ghci/scripts/T10122.stdout b/testsuite/tests/ghci/scripts/T10122.stdout index c79a8711f3..84d8856c1b 100644 --- a/testsuite/tests/ghci/scripts/T10122.stdout +++ b/testsuite/tests/ghci/scripts/T10122.stdout @@ -1,2 +1,2 @@ T :: (k -> *) -> k -> * -T :: forall (k :: BOX). (k -> *) -> k -> * +T :: forall k. (k -> *) -> k -> * diff --git a/testsuite/tests/ghci/scripts/T10508.stderr b/testsuite/tests/ghci/scripts/T10508.stderr index c5aff2361c..86ee279393 100644 --- a/testsuite/tests/ghci/scripts/T10508.stderr +++ b/testsuite/tests/ghci/scripts/T10508.stderr @@ -1,8 +1,8 @@ -<interactive>:1:15: +<interactive>:1:15: error: Couldn't match type ‘a0 -> a0’ with ‘[Char]’ - Expected type: Prelude.String - Actual type: a0 -> a0 + Expected type: Prelude.String + Actual type: a0 -> a0 Probable cause: ‘id’ is applied to too few arguments In the first argument of ‘return’, namely ‘id’ - In the expression: return id
\ No newline at end of file + In the expression: return id diff --git a/testsuite/tests/ghci/scripts/T2182ghci.stderr b/testsuite/tests/ghci/scripts/T2182ghci.stderr index f5eafdfc88..dd65a7fc1f 100644 --- a/testsuite/tests/ghci/scripts/T2182ghci.stderr +++ b/testsuite/tests/ghci/scripts/T2182ghci.stderr @@ -1,25 +1,25 @@ <interactive>:2:1: error: - No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + No instance for (Show (r0 -> r0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it <interactive>:10:1: error: - No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + No instance for (Show (r0 -> r0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it <interactive>:19:1: error: - No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + No instance for (Show (r0 -> r0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it <interactive>:28:1: error: - No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + No instance for (Show (r0 -> r0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it <interactive>:49:1: error: - No instance for (Show (t0 -> t0)) arising from a use of ‘print’ + No instance for (Show (r0 -> r0)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/T4087.stdout b/testsuite/tests/ghci/scripts/T4087.stdout index 2ca08aa449..3f600bd78d 100644 --- a/testsuite/tests/ghci/scripts/T4087.stdout +++ b/testsuite/tests/ghci/scripts/T4087.stdout @@ -1,4 +1,4 @@ -type role Equal nominal nominal
-data Equal a b where
- Equal :: Equal b b
- -- Defined at T4087.hs:5:1
+type role Equal nominal nominal +data Equal a b where + Equal :: Equal a a + -- Defined at T4087.hs:5:1 diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index cea9a01264..dbf2f371dd 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -1,4 +1,6 @@ -type family A a b :: * -- Defined at T4175.hs:7:1 +type family A a b + Kind: * -> * -> * + -- Defined at T4175.hs:7:1 type instance A (B a) b = () -- Defined at T4175.hs:10:1 type instance A (Maybe a) a = a -- Defined at T4175.hs:9:1 type instance A Int Int = () -- Defined at T4175.hs:8:1 @@ -7,13 +9,16 @@ instance G B -- Defined at T4175.hs:34:10 data instance B () = MkB -- Defined at T4175.hs:13:15 type instance A (B a) b = () -- Defined at T4175.hs:10:1 class C a where - type family D a b :: * + type family D a b + Kind: * -> * -> * -- Defined at T4175.hs:16:5 type instance D () () = Bool -- Defined at T4175.hs:22:5 type instance D Int () = String -- Defined at T4175.hs:19:5 -type family E a :: * where - E () = Bool - E Int = String +type family E a + Kind: * -> * + where + E () = Bool + E Int = String -- Defined at T4175.hs:24:1 data () = () -- Defined in ‘GHC.Tuple’ instance C () -- Defined at T4175.hs:21:10 diff --git a/testsuite/tests/ghci/scripts/T6018ghcifail.stderr b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr index ff97c50957..110092d514 100644 --- a/testsuite/tests/ghci/scripts/T6018ghcifail.stderr +++ b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr @@ -46,7 +46,7 @@ <interactive>:60:15: error: Type family equation violates injectivity annotation. - Kind variable ‘k1’ cannot be inferred from the right-hand side. + Kind variable ‘k’ cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: PolyKindVars '[] = '[] -- Defined at <interactive>:60:15 @@ -56,7 +56,7 @@ Kind variable ‘k’ cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: - forall (k :: BOX) (a :: k) (b :: k). + forall k (a :: k) (b :: k). Fc a b = Int -- Defined at <interactive>:64:15 <interactive>:68:15: error: @@ -65,7 +65,7 @@ cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: - forall (k :: BOX) (a :: k) (b :: k). + forall k (a :: k) (b :: k). Gc a b = Int -- Defined at <interactive>:68:15 <interactive>:81:15: error: diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index 158672cc2a..81a360facb 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -25,9 +25,9 @@ instance Foldable ((,) a) -- Defined in ‘Data.Foldable’ instance Traversable ((,) a) -- Defined in ‘Data.Traversable’ instance (Monoid a, Monoid b) => Monoid (a, b) -- Defined in ‘GHC.Base’ -data (#,#) (a :: OpenKind) (b :: OpenKind) = (#,#) a b +data (#,#) (c :: TYPE a) (d :: TYPE b) = (#,#) c d -- Defined in ‘GHC.Prim’ (,) :: a -> b -> (a, b) -(#,#) :: a -> b -> (# a, b #) +(#,#) :: c -> d -> (# c, d #) ( , ) :: a -> b -> (a, b) -(# , #) :: a -> b -> (# a, b #) +(# , #) :: c -> d -> (# c, d #) diff --git a/testsuite/tests/ghci/scripts/T7730.stdout b/testsuite/tests/ghci/scripts/T7730.stdout index d91d058e53..fcf9e4c1d2 100644 --- a/testsuite/tests/ghci/scripts/T7730.stdout +++ b/testsuite/tests/ghci/scripts/T7730.stdout @@ -4,5 +4,5 @@ data A (x :: k) (y :: k1) A :: k -> k1 -> * type role T phantom data T (a :: k) where - MkT :: forall (k :: BOX) (a :: k) a1. a1 -> T a + MkT :: forall k (a :: k) a1. a1 -> T a -- Defined at <interactive>:6:1 diff --git a/testsuite/tests/ghci/scripts/T7873.script b/testsuite/tests/ghci/scripts/T7873.script index 590332665a..404c1f5bda 100644 --- a/testsuite/tests/ghci/scripts/T7873.script +++ b/testsuite/tests/ghci/scripts/T7873.script @@ -1,5 +1,6 @@ -:set -XPolyKinds -XRankNTypes -XGADTs +:set -XPolyKinds -XRankNTypes -XGADTs -XTypeInType data D1 = MkD1 (forall p (a :: k). p a -> Int) data D2 = MkD2 (forall p a. p a -> Int) -:i D1 +data D3 = MkD3 (forall k p (a :: k). p a -> Int) :i D2 +:i D3 diff --git a/testsuite/tests/ghci/scripts/T7873.stderr b/testsuite/tests/ghci/scripts/T7873.stderr new file mode 100644 index 0000000000..3b6f4f64c1 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T7873.stderr @@ -0,0 +1,7 @@ + +<interactive>:2:1: error: + • Kind variable ‘k’ is implicitly bound in datatype + ‘D1’, but does not appear as the kind of any + of its type variables. Perhaps you meant + to bind it (with TypeInType) explicitly somewhere? + • In the data declaration for ‘D1’ diff --git a/testsuite/tests/ghci/scripts/T7873.stdout b/testsuite/tests/ghci/scripts/T7873.stdout index 84f3117958..b7415d6222 100644 --- a/testsuite/tests/ghci/scripts/T7873.stdout +++ b/testsuite/tests/ghci/scripts/T7873.stdout @@ -1,6 +1,4 @@ -data D1 where
- MkD1 :: (forall (p :: k -> *) (a :: k). p a -> Int) -> D1
- -- Defined at <interactive>:2:1
-data D2 where
- MkD2 :: (forall (p :: k -> *) (a :: k). p a -> Int) -> D2
- -- Defined at <interactive>:3:1
+data D2 = MkD2 (forall (p :: Any -> *) (a :: Any). p a -> Int) + -- Defined at <interactive>:3:1 +data D3 = MkD3 (forall k (p :: k -> *) (a :: k). p a -> Int) + -- Defined at <interactive>:4:1 diff --git a/testsuite/tests/ghci/scripts/T7939.stdout b/testsuite/tests/ghci/scripts/T7939.stdout index feb890c578..ec6c75cca2 100644 --- a/testsuite/tests/ghci/scripts/T7939.stdout +++ b/testsuite/tests/ghci/scripts/T7939.stdout @@ -1,25 +1,34 @@ class Foo (a :: k) where - type family Bar (a :: k) b :: * + type family Bar (a :: k) b + Kind: forall k1. k1 -> * -> * -- Defined at T7939.hs:6:4 Bar :: k -> * -> * -type family F a :: * -- Defined at T7939.hs:8:1 +type family F a + Kind: * -> * + -- Defined at T7939.hs:8:1 type instance F Int = Bool -- Defined at T7939.hs:9:1 F :: * -> * -type family G a :: * where - G Int = Bool +type family G a + Kind: * -> * + where G Int = Bool -- Defined at T7939.hs:11:1 G :: * -> * -type family H (a :: Bool) :: Bool where - H 'False = 'True +type family H (a :: Bool) + Kind: Bool -> Bool + where H 'False = 'True -- Defined at T7939.hs:14:1 H :: Bool -> Bool -type family J (a :: [k]) :: Bool where - J k '[] = 'False - forall (k :: BOX) (h :: k) (t :: [k]). J k (h : t) = 'True +type family J (a :: [k]) + Kind: forall k1. [k1] -> Bool + where + [k] J k '[] = 'False + [k, (h :: k), (t :: [k])] J k (h : t) = 'True -- Defined at T7939.hs:17:1 J :: [k] -> Bool -type family K (a :: [k]) :: Maybe k where - K k '[] = 'Nothing - forall (k :: BOX) (h :: k) (t :: [k]). K k (h : t) = 'Just h +type family K (a1 :: [a]) + Kind: forall a2. [a2] -> Maybe a2 + where + [a] K a '[] = 'Nothing + [a, (h :: a), (t :: [a])] K a (h : t) = 'Just h -- Defined at T7939.hs:21:1 -K :: [k] -> Maybe k +K :: [a] -> Maybe a diff --git a/testsuite/tests/ghci/scripts/T9181.stdout b/testsuite/tests/ghci/scripts/T9181.stdout index 15504ec324..0e9913966f 100644 --- a/testsuite/tests/ghci/scripts/T9181.stdout +++ b/testsuite/tests/ghci/scripts/T9181.stdout @@ -1,10 +1,16 @@ -type family (*) (a :: Nat) (b :: Nat) :: Nat -type family (+) (a :: Nat) (b :: Nat) :: Nat -type family (-) (a :: Nat) (b :: Nat) :: Nat +type family (*) (a :: Nat) (b :: Nat) + Kind: Nat -> Nat -> Nat +type family (+) (a :: Nat) (b :: Nat) + Kind: Nat -> Nat -> Nat +type family (-) (a :: Nat) (b :: Nat) + Kind: Nat -> Nat -> Nat type (<=) (x :: Nat) (y :: Nat) = (x <=? y) ~ 'True -type family (<=?) (a :: Nat) (b :: Nat) :: Bool -type family CmpNat (a :: Nat) (b :: Nat) :: Ordering -type family CmpSymbol (a :: Symbol) (b :: Symbol) :: Ordering +type family (<=?) (a :: Nat) (b :: Nat) + Kind: Nat -> Nat -> Bool +type family CmpNat (a :: Nat) (b :: Nat) + Kind: Nat -> Nat -> Ordering +type family CmpSymbol (a :: Symbol) (b :: Symbol) + Kind: Symbol -> Symbol -> Ordering data ErrorMessage where Text :: Symbol -> ErrorMessage ShowType :: t -> ErrorMessage @@ -20,8 +26,10 @@ data SomeNat where SomeNat :: KnownNat n => (Proxy n) -> SomeNat data SomeSymbol where SomeSymbol :: KnownSymbol n => (Proxy n) -> SomeSymbol -type family TypeError (a :: ErrorMessage) :: b where -type family (^) (a :: Nat) (b :: Nat) :: Nat +type family TypeError (a :: ErrorMessage) + Kind: forall b1. ErrorMessage -> b1 +type family (^) (a :: Nat) (b :: Nat) + Kind: Nat -> Nat -> Nat natVal :: KnownNat n => proxy n -> Integer natVal' :: KnownNat n => Proxy# n -> Integer sameNat :: diff --git a/testsuite/tests/ghci/scripts/ghci001.stdout b/testsuite/tests/ghci/scripts/ghci001.stdout index b0a2458b59..a1ff2665f5 100644 --- a/testsuite/tests/ghci/scripts/ghci001.stdout +++ b/testsuite/tests/ghci/scripts/ghci001.stdout @@ -1,2 +1,2 @@ -(+) :: Num a => a -> a -> a
-enumFromTo :: Enum a => a -> a -> [a]
+(+) :: Num a => a -> a -> a +enumFromTo :: Enum a => a -> a -> [a] diff --git a/testsuite/tests/ghci/scripts/ghci013.stdout b/testsuite/tests/ghci/scripts/ghci013.stdout index 5daf16ee23..6d99b877ba 100644 --- a/testsuite/tests/ghci/scripts/ghci013.stdout +++ b/testsuite/tests/ghci/scripts/ghci013.stdout @@ -1 +1 @@ -f :: Monad m => (m a, t) -> m b
+f :: Monad m => (m a, r) -> m b diff --git a/testsuite/tests/ghci/scripts/ghci047.stderr b/testsuite/tests/ghci/scripts/ghci047.stderr index dc8dfc9ecb..7e696c02c4 100644 --- a/testsuite/tests/ghci/scripts/ghci047.stderr +++ b/testsuite/tests/ghci/scripts/ghci047.stderr @@ -1,16 +1,14 @@ -<interactive>:38:1: - Couldn't match type ‘HFalse’ with ‘HTrue’ - Expected type: HTrue - Actual type: Or HFalse HFalse - In the expression: f - In the expression: f $ Baz 'a' - In an equation for ‘it’: it = f $ Baz 'a' +<interactive>:38:1: error: + • Couldn't match type ‘HFalse’ with ‘HTrue’ + arising from a use of ‘f’ + • In the expression: f + In the expression: f $ Baz 'a' + In an equation for ‘it’: it = f $ Baz 'a' -<interactive>:39:1: - Couldn't match type ‘HFalse’ with ‘HTrue’ - Expected type: HTrue - Actual type: Or HFalse HFalse - In the expression: f - In the expression: f $ Quz - In an equation for ‘it’: it = f $ Quz +<interactive>:39:1: error: + • Couldn't match type ‘HFalse’ with ‘HTrue’ + arising from a use of ‘f’ + • In the expression: f + In the expression: f $ Quz + In an equation for ‘it’: it = f $ Quz diff --git a/testsuite/tests/ghci/scripts/ghci051.stderr b/testsuite/tests/ghci/scripts/ghci051.stderr index 7a33dd57b6..6d28081344 100644 --- a/testsuite/tests/ghci/scripts/ghci051.stderr +++ b/testsuite/tests/ghci/scripts/ghci051.stderr @@ -4,7 +4,7 @@ with ‘Ghci1.T’ NB: ‘Ghci1.T’ is defined at <interactive>:2:1-14 ‘T’ is defined at <interactive>:5:1-16 - Expected type: T' - Actual type: T + Expected type: T' + Actual type: T In the expression: C :: T' In an equation for ‘c’: c = C :: T' diff --git a/testsuite/tests/ghci/scripts/ghci055.stdout b/testsuite/tests/ghci/scripts/ghci055.stdout index d57430bb8c..578740d6de 100644 --- a/testsuite/tests/ghci/scripts/ghci055.stdout +++ b/testsuite/tests/ghci/scripts/ghci055.stdout @@ -1,6 +1,6 @@ *** Exception: Prelude.undefined CallStack (from ImplicitParams): - error, called at libraries/base/GHC/Err.hs:42:14 in base:GHC.Err + error, called at libraries/base/GHC/Err.hs:43:14 in base:GHC.Err undefined, called at <interactive>:1:7 in interactive:Ghci1 -x :: t = _ +x :: r = _ y :: Integer = 3 diff --git a/testsuite/tests/ghci/scripts/ghci059.script b/testsuite/tests/ghci/scripts/ghci059.script index 936277e336..1d344d7833 100644 --- a/testsuite/tests/ghci/scripts/ghci059.script +++ b/testsuite/tests/ghci/scripts/ghci059.script @@ -1,5 +1,5 @@ -- At one point, :info Coercible would not report it as a constraint, but as a --- data type. So this test case ensures that this is broken later. +-- data type. So this test case ensures that this is not broken later. :m + Data.Coerce :info Coercible diff --git a/testsuite/tests/ghci/scripts/ghci059.stdout b/testsuite/tests/ghci/scripts/ghci059.stdout index 6b2c8f886e..fac61163f4 100644 --- a/testsuite/tests/ghci/scripts/ghci059.stdout +++ b/testsuite/tests/ghci/scripts/ghci059.stdout @@ -1,4 +1,4 @@ type role Coercible representational representational -class Coercible (a :: k) (b :: k) +class a ~R# b => Coercible (a :: k) (b :: k) -- Defined in ‘GHC.Types’ coerce :: Coercible a b => a -> b -- Defined in ‘GHC.Prim’ diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr index 2bb1a178e0..63c2b2f74b 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -test :: (Eq a) => [a] doc1 -> [a] doc2 -> [a] doc3 +test :: (Eq a) => [a] doc1 -> [a] doc2 -> [a] doc3 test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr index 4a57879c5c..769da3f0d3 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -test :: (Eq a) => [a] doc1 -> forall b. [b] doc2 -> [a] doc3 +test :: (Eq a) => [a] doc1 -> forall b. [b] doc2 -> [a] doc3 test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr index d1cb709c55..e7707c5ec0 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr @@ -2,9 +2,9 @@ ==================== Parser ==================== module ShouldCompile where test :: - [a] doc1 - -> forall b. (Ord b) => - [b] doc2 -> forall c. (Num c) => [c] doc3 -> [a] + [a] doc1 + -> forall b. + (Ord b) => [b] doc2 -> forall c. (Num c) => [c] doc3 -> [a] test xs ys zs = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr index fa0d7019c0..bd9ec257e7 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr @@ -2,7 +2,7 @@ ==================== Parser ==================== module ShouldCompile where data (<-->) a b = Mk a b -test :: [a] doc1 -> (a <--> (b -> [a])) blabla +test :: [a] doc1 -> a <--> b -> [a] blabla test xs ys = xs diff --git a/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr b/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr index 68412759e7..ce3f4f9048 100644 --- a/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr +++ b/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr @@ -15,7 +15,8 @@ PushedInAsGivens.hs:10:31: error: bar :: a -> (a, Int) (bound at PushedInAsGivens.hs:9:1) PushedInAsGivens.hs:11:15: error: - • Couldn't match expected type ‘[a]’ with actual type ‘F Int’ + • Couldn't match type ‘F Int’ with ‘[a]’ + arising from a use of ‘foo’ • In the expression: foo y In the expression: (y, foo y) In the expression: diff --git a/testsuite/tests/indexed-types/should_compile/Simple12.hs b/testsuite/tests/indexed-types/should_compile/Simple12.hs index c425d78db5..5a74776c27 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple12.hs +++ b/testsuite/tests/indexed-types/should_compile/Simple12.hs @@ -14,4 +14,3 @@ mkf p = undefined -- foo :: a ~ F a => a -> a -- foo :: a ~ F a => a -> F a foo p = same p (mkf p) - diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index d47accbe20..53d7942958 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -4,12 +4,13 @@ TYPE SIGNATURES forall c t t1. (Num t, Num t1, Coll c, Elem c ~ (t, t1)) => c -> c TYPE CONSTRUCTORS class Coll c where - type family Elem c :: * open + type family Elem c open + Kind: * -> * empty :: c insert :: Elem c -> c -> c {-# MINIMAL empty, insert #-} data ListColl a = L [a] - Promotable + Kind: * -> * COERCION AXIOMS axiom Foo.TFCo:R:ElemListColl :: Elem (ListColl a) = a -- Defined at T3017.hs:13:9 diff --git a/testsuite/tests/indexed-types/should_compile/T3208b.stderr b/testsuite/tests/indexed-types/should_compile/T3208b.stderr index b40942a5a9..0a0a491f17 100644 --- a/testsuite/tests/indexed-types/should_compile/T3208b.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3208b.stderr @@ -1,6 +1,6 @@ T3208b.hs:15:10: error: - • Could not deduce: OTerm o0 ~ STerm o0 + • Could not deduce: OTerm o0 ~ STerm o0 arising from a use of ‘fce’ from the context: (OTerm a ~ STerm a, OBJECT a, SUBST a) bound by the type signature for: fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c @@ -11,6 +11,7 @@ T3208b.hs:15:10: error: T3208b.hs:15:15: error: • Could not deduce: OTerm o0 ~ STerm a + arising from a use of ‘apply’ from the context: (OTerm a ~ STerm a, OBJECT a, SUBST a) bound by the type signature for: fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c diff --git a/testsuite/tests/indexed-types/should_compile/T9316.hs b/testsuite/tests/indexed-types/should_compile/T9316.hs index ca7680c063..31da8f4791 100644 --- a/testsuite/tests/indexed-types/should_compile/T9316.hs +++ b/testsuite/tests/indexed-types/should_compile/T9316.hs @@ -85,4 +85,3 @@ forAllSubscriptionChannels f = withSomeSing BookingsChannel $ \(sChannel) -> case witnessC sChannel of Dict -> f sChannel - diff --git a/testsuite/tests/indexed-types/should_compile/T9747.hs b/testsuite/tests/indexed-types/should_compile/T9747.hs index 0466cbae67..3b1c47703e 100644 --- a/testsuite/tests/indexed-types/should_compile/T9747.hs +++ b/testsuite/tests/indexed-types/should_compile/T9747.hs @@ -4,7 +4,7 @@ module T9747 where import Data.List (intercalate) import Data.Proxy -import GHC.Prim (Constraint) +import GHC.Exts (Constraint) data HList :: [*] -> * where Nil :: HList '[] diff --git a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr index 3b9539e19e..04eedb1eaf 100644 --- a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr +++ b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr @@ -2,27 +2,39 @@ ClosedFam3.hs-boot:5:1: Type constructor ‘Foo’ has conflicting definitions in the module and its hs-boot file - Main module: type family Foo a :: * where + Main module: type family Foo a + Kind: * -> * + where Foo Int = Bool Foo Double = Char - Boot file: type family Foo a :: * where + Boot file: type family Foo a + Kind: * -> * + where Foo Int = Bool ClosedFam3.hs-boot:8:1: Type constructor ‘Bar’ has conflicting definitions in the module and its hs-boot file - Main module: type family Bar a :: * where + Main module: type family Bar a + Kind: * -> * + where Bar Int = Bool Bar Double = Double - Boot file: type family Bar a :: * where + Boot file: type family Bar a + Kind: * -> * + where Bar Int = Bool Bar Double = Char ClosedFam3.hs-boot:12:1: Type constructor ‘Baz’ has conflicting definitions in the module and its hs-boot file - Main module: type family Baz a :: * where + Main module: type family Baz a + Kind: * -> * + where Baz Int = Bool - Boot file: type family Baz (a :: k) :: * where + Boot file: type family Baz (a :: k) + Kind: forall k1. k1 -> * + where Baz * Int = Bool The types have different kinds diff --git a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr index d1622335d8..d64036c4bc 100644 --- a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr +++ b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr @@ -1,4 +1,5 @@ Overlap4.hs:7:3: Number of parameters must match family declaration; expected 2 + In the equations for closed type family ‘F’ In the type family declaration for ‘F’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail12.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail12.stderr index 11664e67bd..a402623bae 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail12.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail12.stderr @@ -1,4 +1,4 @@ SimpleFail12.hs:8:15: - Illegal polymorphic or qualified type: forall a. [a] + Illegal polymorphic or qualified type: forall a1. [a1] In the type instance declaration for ‘C’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr index 59b5c138ad..7079d8cc84 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr @@ -1,6 +1,6 @@ SimpleFail14.hs:5:15: error: - Constraint ‘a ~ a’ used as a type - In the type ‘a ~ a’ - In the definition of data constructor ‘T’ - In the data declaration for ‘T’ + • Expected a type, but ‘a ~ a’ has kind ‘Constraint’ + • In the type ‘a ~ a’ + In the definition of data constructor ‘T’ + In the data declaration for ‘T’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr index f57af3908b..8637eaa892 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr @@ -1,4 +1,5 @@ -SimpleFail1a.hs:4:1: - Number of parameters must match family declaration; expected 2 - In the data instance declaration for ‘T1’ +SimpleFail1a.hs:4:1: error: + • Expecting one more argument to ‘T1 Int’ + Expected a type, but ‘T1 Int’ has kind ‘* -> *’ + • In the data instance declaration for ‘T1’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr index 3ecd31a003..e872f115a2 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr @@ -1,4 +1,6 @@ SimpleFail1b.hs:4:1: - Number of parameters must match family declaration; expected 2 + Too many parameters to T1: + Char is unexpected; + expected only two parameters In the data instance declaration for ‘T1’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail6.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail6.stderr index 6b12656863..6c04646b81 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail6.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail6.stderr @@ -1,5 +1,5 @@ -SimpleFail6.hs:7:11: +SimpleFail6.hs:6:10: error: Conflicting definitions for ‘a’ - Bound at: SimpleFail6.hs:7:11 + Bound at: SimpleFail6.hs:6:10 SimpleFail6.hs:7:13 diff --git a/testsuite/tests/indexed-types/should_fail/T10141.stderr b/testsuite/tests/indexed-types/should_fail/T10141.stderr index 2cb2652388..79c964c71d 100644 --- a/testsuite/tests/indexed-types/should_fail/T10141.stderr +++ b/testsuite/tests/indexed-types/should_fail/T10141.stderr @@ -1,6 +1,5 @@ T10141.hs:6:6: error: - The first argument of ‘G’ should have kind ‘k’, - but ‘Int’ has kind ‘*’ - In the type ‘Int’ + Expected kind ‘k’, but ‘Int’ has kind ‘*’ + In the first argument of ‘G’, namely ‘Int’ In the type family declaration for ‘G’ diff --git a/testsuite/tests/indexed-types/should_fail/T10899.stderr b/testsuite/tests/indexed-types/should_fail/T10899.stderr index e48274c466..ed21c65b11 100644 --- a/testsuite/tests/indexed-types/should_fail/T10899.stderr +++ b/testsuite/tests/indexed-types/should_fail/T10899.stderr @@ -1,4 +1,4 @@ T10899.hs:7:3: error: - Illegal polymorphic or qualified type: forall (m :: * -> *). m a + Illegal polymorphic or qualified type: forall (m1 :: * -> *). m1 a In the class declaration for ‘C’ diff --git a/testsuite/tests/indexed-types/should_fail/T2627b.stderr b/testsuite/tests/indexed-types/should_fail/T2627b.stderr index 0b18041825..11e1b8e8fd 100644 --- a/testsuite/tests/indexed-types/should_fail/T2627b.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2627b.stderr @@ -1,8 +1,9 @@ T2627b.hs:20:24: error: - Occurs check: cannot construct the infinite type: - t0 ~ Dual (Dual t0) - The type variable ‘t0’ is ambiguous - In the expression: conn undefined undefined - In an equation for ‘conn’: - conn (Rd k) (Wr a r) = conn undefined undefined + • Occurs check: cannot construct the infinite type: + t0 ~ Dual (Dual t0) + arising from a use of ‘conn’ + The type variable ‘t0’ is ambiguous + • In the expression: conn undefined undefined + In an equation for ‘conn’: + conn (Rd k) (Wr a r) = conn undefined undefined diff --git a/testsuite/tests/indexed-types/should_fail/T2664.stderr b/testsuite/tests/indexed-types/should_fail/T2664.stderr index d2dd0dff60..3a84f18272 100644 --- a/testsuite/tests/indexed-types/should_fail/T2664.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2664.stderr @@ -1,21 +1,19 @@ -T2664.hs:31:52: - Could not deduce: b ~ a - from the context: ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) - bound by the type signature for: - newPChan :: ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) => - IO (PChan (a :*: b), PChan c) - at T2664.hs:23:5-12 +T2664.hs:31:52: error: + • Could not deduce: b ~ a arising from a use of ‘newPChan’ + from the context: ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) + bound by the type signature for: + newPChan :: ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) => + IO (PChan (a :*: b), PChan c) + at T2664.hs:23:5-12 ‘b’ is a rigid type variable bound by - the instance declaration at T2664.hs:22:10 + the instance declaration at T2664.hs:22:10 ‘a’ is a rigid type variable bound by - the instance declaration at T2664.hs:22:10 - Expected type: Dual (Dual a) - Actual type: b - In the third argument of ‘pchoose’, namely ‘newPChan’ - In the first argument of ‘E’, namely ‘(pchoose Right v newPChan)’ - In the expression: - E (pchoose Right v newPChan) (pchoose Left v newPChan) - Relevant bindings include - v :: MVar (Either (PChan a) (PChan b)) (bound at T2664.hs:24:9) - newPChan :: IO (PChan (a :*: b), PChan c) (bound at T2664.hs:23:5) + the instance declaration at T2664.hs:22:10 + • In the third argument of ‘pchoose’, namely ‘newPChan’ + In the first argument of ‘E’, namely ‘(pchoose Right v newPChan)’ + In the expression: + E (pchoose Right v newPChan) (pchoose Left v newPChan) + • Relevant bindings include + v :: MVar (Either (PChan a) (PChan b)) (bound at T2664.hs:24:9) + newPChan :: IO (PChan (a :*: b), PChan c) (bound at T2664.hs:23:5) diff --git a/testsuite/tests/indexed-types/should_fail/T3330a.stderr b/testsuite/tests/indexed-types/should_fail/T3330a.stderr index acefda7253..ea3b1d4001 100644 --- a/testsuite/tests/indexed-types/should_fail/T3330a.stderr +++ b/testsuite/tests/indexed-types/should_fail/T3330a.stderr @@ -1,14 +1,15 @@ T3330a.hs:19:34: error: - • Couldn't match type ‘s’ with ‘(->) (s0 ix0 -> ix1)’ - ‘s’ is a rigid type variable bound by + • Couldn't match type ‘ix’ + with ‘r ix1 -> Writer [AnyF s] (r'0 ix1)’ + ‘ix’ is a rigid type variable bound by the type signature for: children :: forall (s :: * -> *) ix (r :: * -> *). s ix -> PF s r ix -> [AnyF s] at T3330a.hs:18:13 Expected type: (s0 ix0 -> ix1) -> r ix1 -> Writer [AnyF s] (r'0 ix1) - Actual type: s ix + Actual type: s ix • In the first argument of ‘hmapM’, namely ‘p’ In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ • Relevant bindings include @@ -17,16 +18,15 @@ T3330a.hs:19:34: error: children :: s ix -> PF s r ix -> [AnyF s] (bound at T3330a.hs:19:1) T3330a.hs:19:34: error: - • Couldn't match type ‘ix’ - with ‘r ix1 -> Writer [AnyF s] (r'0 ix1)’ - ‘ix’ is a rigid type variable bound by + • Couldn't match type ‘s’ with ‘(->) (s0 ix0 -> ix1)’ + ‘s’ is a rigid type variable bound by the type signature for: children :: forall (s :: * -> *) ix (r :: * -> *). s ix -> PF s r ix -> [AnyF s] at T3330a.hs:18:13 Expected type: (s0 ix0 -> ix1) -> r ix1 -> Writer [AnyF s] (r'0 ix1) - Actual type: s ix + Actual type: s ix • In the first argument of ‘hmapM’, namely ‘p’ In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ • Relevant bindings include @@ -43,7 +43,7 @@ T3330a.hs:19:44: error: s ix -> PF s r ix -> [AnyF s] at T3330a.hs:18:13 Expected type: PF s r (r0 ix0 -> Writer [AnyF s0] (r0 ix0)) - Actual type: PF s r ix + Actual type: PF s r ix • In the third argument of ‘hmapM’, namely ‘x’ In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ • Relevant bindings include diff --git a/testsuite/tests/indexed-types/should_fail/T3330c.stderr b/testsuite/tests/indexed-types/should_fail/T3330c.stderr index d0a8320384..4d9e6d5be6 100644 --- a/testsuite/tests/indexed-types/should_fail/T3330c.stderr +++ b/testsuite/tests/indexed-types/should_fail/T3330c.stderr @@ -1,14 +1,15 @@ T3330c.hs:23:43: error: - Couldn't match kind ‘*’ with ‘* -> *’ - When matching types - Der ((->) x) :: * -> * - R :: (* -> *) -> * - Expected type: Der ((->) x) (Der f1 x) + • Couldn't match kind ‘* -> *’ with ‘*’ + When matching types + f1 :: * -> * + Der f1 x :: * + Expected type: Der ((->) x) (Der f1 x) Actual type: R f1 - In the first argument of ‘plug’, namely ‘rf’ - In the first argument of ‘Inl’, namely ‘(plug rf df x)’ - Relevant bindings include - x :: x (bound at T3330c.hs:23:29) - df :: Der f1 x (bound at T3330c.hs:23:25) - plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:23:1) + • In the first argument of ‘plug’, namely ‘rf’ + In the first argument of ‘Inl’, namely ‘(plug rf df x)’ + • Relevant bindings include + x :: x (bound at T3330c.hs:23:29) + df :: Der f1 x (bound at T3330c.hs:23:25) + rf :: R f1 (bound at T3330c.hs:23:13) + plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:23:1) diff --git a/testsuite/tests/indexed-types/should_fail/T4179.stderr b/testsuite/tests/indexed-types/should_fail/T4179.stderr index f7f142a4bd..4173eff8da 100644 --- a/testsuite/tests/indexed-types/should_fail/T4179.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4179.stderr @@ -1,15 +1,15 @@ -T4179.hs:26:16: - Couldn't match type ‘A2 (x (A2 (FCon x) -> A3 (FCon x)))’ - with ‘A2 (FCon x)’ - NB: ‘A2’ is a type function, and may not be injective - Expected type: x (A2 (FCon x) -> A3 (FCon x)) - -> A2 (FCon x) -> A3 (FCon x) +T4179.hs:26:16: error: + • Couldn't match type ‘A3 (x (A2 (FCon x) -> A3 (FCon x)))’ + with ‘A3 (FCon x)’ + NB: ‘A3’ is a type function, and may not be injective + Expected type: x (A2 (FCon x) -> A3 (FCon x)) + -> A2 (FCon x) -> A3 (FCon x) Actual type: x (A2 (FCon x) -> A3 (FCon x)) -> A2 (x (A2 (FCon x) -> A3 (FCon x))) -> A3 (x (A2 (FCon x) -> A3 (FCon x))) - In the first argument of ‘foldDoC’, namely ‘op’ - In the expression: foldDoC op - Relevant bindings include - fCon :: Con x -> A2 (FCon x) -> A3 (FCon x) - (bound at T4179.hs:26:1) + • In the first argument of ‘foldDoC’, namely ‘op’ + In the expression: foldDoC op + • Relevant bindings include + fCon :: Con x -> A2 (FCon x) -> A3 (FCon x) + (bound at T4179.hs:26:1) diff --git a/testsuite/tests/indexed-types/should_fail/T5439.stderr b/testsuite/tests/indexed-types/should_fail/T5439.stderr index c5b9c9cfc9..193b1536ec 100644 --- a/testsuite/tests/indexed-types/should_fail/T5439.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5439.stderr @@ -1,25 +1,25 @@ -T5439.hs:82:28: - Couldn't match type ‘Attempt (HElemOf rs)’ - with ‘Attempt (HHead (HDrop n0 l0)) -> Attempt (HElemOf l0)’ - Expected type: f (Attempt (HNth n0 l0) -> Attempt (HElemOf l0)) - Actual type: f (Attempt (WaitOpResult (WaitOps rs))) - In the first argument of ‘complete’, namely ‘ev’ - In the expression: complete ev - Relevant bindings include - register :: Bool -> Peano n -> WaitOps (HDrop n rs) -> IO Bool - (bound at T5439.hs:64:9) - ev :: f (Attempt (WaitOpResult (WaitOps rs))) - (bound at T5439.hs:61:22) - ops :: WaitOps rs (bound at T5439.hs:61:18) - registerWaitOp :: WaitOps rs - -> f (Attempt (WaitOpResult (WaitOps rs))) -> IO Bool - (bound at T5439.hs:61:3) +T5439.hs:82:28: error: + • Couldn't match type ‘Attempt (WaitOpResult (WaitOps rs))’ + with ‘Attempt (HNth n0 l0) -> Attempt (HElemOf l0)’ + Expected type: f (Attempt (HNth n0 l0) -> Attempt (HElemOf l0)) + Actual type: f (Attempt (WaitOpResult (WaitOps rs))) + • In the first argument of ‘complete’, namely ‘ev’ + In the expression: complete ev + • Relevant bindings include + register :: Bool -> Peano n -> WaitOps (HDrop n rs) -> IO Bool + (bound at T5439.hs:64:9) + ev :: f (Attempt (WaitOpResult (WaitOps rs))) + (bound at T5439.hs:61:22) + ops :: WaitOps rs (bound at T5439.hs:61:18) + registerWaitOp :: WaitOps rs + -> f (Attempt (WaitOpResult (WaitOps rs))) -> IO Bool + (bound at T5439.hs:61:3) -T5439.hs:82:39: - Couldn't match expected type ‘Peano n0’ - with actual type ‘Attempt α0’ - In the second argument of ‘($)’, namely - ‘Failure (e :: SomeException)’ - In the second argument of ‘($)’, namely - ‘inj $ Failure (e :: SomeException)’ +T5439.hs:82:39: error: + • Couldn't match expected type ‘Peano n0’ + with actual type ‘Attempt α0’ + • In the second argument of ‘($)’, namely + ‘Failure (e :: SomeException)’ + In the second argument of ‘($)’, namely + ‘inj $ Failure (e :: SomeException)’ diff --git a/testsuite/tests/indexed-types/should_fail/T6123.stderr b/testsuite/tests/indexed-types/should_fail/T6123.stderr index d97968b3aa..3c77040f95 100644 --- a/testsuite/tests/indexed-types/should_fail/T6123.stderr +++ b/testsuite/tests/indexed-types/should_fail/T6123.stderr @@ -1,7 +1,9 @@ T6123.hs:10:14: error: - Occurs check: cannot construct the infinite type: t0 ~ Id t0 - The type variable ‘t0’ is ambiguous - In the expression: cid undefined - In an equation for ‘cundefined’: cundefined = cid undefined - Relevant bindings include cundefined :: t0 (bound at T6123.hs:10:1) + • Occurs check: cannot construct the infinite type: t0 ~ Id t0 + arising from a use of ‘cid’ + The type variable ‘t0’ is ambiguous + • In the expression: cid undefined + In an equation for ‘cundefined’: cundefined = cid undefined + • Relevant bindings include + cundefined :: t0 (bound at T6123.hs:10:1) diff --git a/testsuite/tests/indexed-types/should_fail/T7786.stderr b/testsuite/tests/indexed-types/should_fail/T7786.stderr index 62627d6377..a58b69e7e7 100644 --- a/testsuite/tests/indexed-types/should_fail/T7786.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7786.stderr @@ -1,36 +1,36 @@ -
-T7786.hs:86:22: error:
- Couldn't match type ‘xxx’ with ‘'Empty’
- Inaccessible code in
- a pattern with constructor: Nil :: forall (k :: BOX). Sing 'Empty,
- in a pattern binding in
- 'do' block
- In the pattern: Nil
- In the pattern: Nil :: Sing xxx
- In a stmt of a 'do' block:
- Nil :: Sing xxx <- return
- (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)
-
-T7786.hs:86:49: error:
- Couldn't match type ‘xxx’
- with ‘Intersect (BuriedUnder sub k 'Empty) inv’
- Expected type: Sing xxx
- Actual type: Sing (Intersect (BuriedUnder sub k 'Empty) inv)
- In the first argument of ‘return’, namely
- ‘(buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)’
- In a stmt of a 'do' block:
- Nil :: Sing xxx <- return
- (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)
- In the expression:
- do { Nil :: Sing xxx <- return
- (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db);
- return $ Sub db k sub }
- Relevant bindings include
- sub :: Database sub (bound at T7786.hs:86:13)
- k :: Sing k (bound at T7786.hs:86:11)
- db :: Database inv (bound at T7786.hs:86:8)
- addSub :: Database inv
- -> Sing k
- -> Database sub
- -> Maybe (Database (BuriedUnder sub k inv))
- (bound at T7786.hs:86:1)
+ +T7786.hs:86:22: error: + • Couldn't match type ‘xxx’ with ‘'Empty’ + Inaccessible code in + a pattern with constructor: Nil :: forall a. Sing 'Empty, + in a pattern binding in + 'do' block + • In the pattern: Nil + In the pattern: Nil :: Sing xxx + In a stmt of a 'do' block: + Nil :: Sing xxx <- return + (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db) + +T7786.hs:86:49: error: + • Couldn't match type ‘xxx’ + with ‘Intersect (BuriedUnder sub k 'Empty) inv’ + Expected type: Sing xxx + Actual type: Sing (Intersect (BuriedUnder sub k 'Empty) inv) + • In the first argument of ‘return’, namely + ‘(buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)’ + In a stmt of a 'do' block: + Nil :: Sing xxx <- return + (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db) + In the expression: + do { Nil :: Sing xxx <- return + (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db); + return $ Sub db k sub } + • Relevant bindings include + sub :: Database sub (bound at T7786.hs:86:13) + k :: Sing k (bound at T7786.hs:86:11) + db :: Database inv (bound at T7786.hs:86:8) + addSub :: Database inv + -> Sing k + -> Database sub + -> Maybe (Database (BuriedUnder sub k inv)) + (bound at T7786.hs:86:1) diff --git a/testsuite/tests/indexed-types/should_fail/T7788.stderr b/testsuite/tests/indexed-types/should_fail/T7788.stderr index 31e23cd3fd..757c05089e 100644 --- a/testsuite/tests/indexed-types/should_fail/T7788.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7788.stderr @@ -1,10 +1,10 @@ -T7788.hs:9:7: +T7788.hs:19:20: error: Reduction stack overflow; size = 201 When simplifying the following type: F (Id (Fix Id)) Use -freduction-depth=0 to disable this check (any upper bound you could choose might fail unpredictably with minor updates to GHC, so disabling the check is recommended if you're sure that type checking should terminate) - In the expression: undefined - In an equation for ‘foo’: foo = undefined + In the first argument of ‘foo’, namely ‘Proxy’ + In the second argument of ‘($)’, namely ‘foo Proxy’ diff --git a/testsuite/tests/indexed-types/should_fail/T9160.stderr b/testsuite/tests/indexed-types/should_fail/T9160.stderr index 5850257ec4..a5c2f79257 100644 --- a/testsuite/tests/indexed-types/should_fail/T9160.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9160.stderr @@ -1,7 +1,7 @@ T9160.hs:18:12: error: Expecting one more argument to ‘Maybe’ - Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ In the type ‘Maybe’ In the type instance declaration for ‘F’ In the instance declaration for ‘C (a :: *)’ diff --git a/testsuite/tests/indexed-types/should_fail/T9171.stderr b/testsuite/tests/indexed-types/should_fail/T9171.stderr index 9a618c50bf..5ffb87b0ea 100644 --- a/testsuite/tests/indexed-types/should_fail/T9171.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9171.stderr @@ -1,11 +1,10 @@ -
-T9171.hs:10:20: error:
- Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
- with actual type ‘GetParam Base (GetParam Base Int)’
- NB: ‘GetParam’ is a type function, and may not be injective
- The kind variable ‘k0’ is ambiguous
- Use -fprint-explicit-kinds to see the kind arguments
- In the ambiguity check for an expression type signature
- To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
- In an expression type signature: GetParam Base (GetParam Base Int)
- In the expression: undefined :: GetParam Base (GetParam Base Int)
+ +T9171.hs:10:20: error: + • Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ + NB: ‘GetParam’ is a type function, and may not be injective + The type variable ‘k20’ is ambiguous + • In the ambiguity check for an expression type signature + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In an expression type signature: GetParam Base (GetParam Base Int) + In the expression: undefined :: GetParam Base (GetParam Base Int) diff --git a/testsuite/tests/indexed-types/should_fail/T9357.stderr b/testsuite/tests/indexed-types/should_fail/T9357.stderr index 4d97c31fd6..cc483c54db 100644 --- a/testsuite/tests/indexed-types/should_fail/T9357.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9357.stderr @@ -4,5 +4,5 @@ T9357.hs:7:15: In the type instance declaration for ‘F’ T9357.hs:8:15: - Illegal polymorphic or qualified type: forall a. a -> a + Illegal polymorphic or qualified type: forall a1. a1 -> a1 In the type instance declaration for ‘F’ diff --git a/testsuite/tests/indexed-types/should_run/T5719.hs b/testsuite/tests/indexed-types/should_run/T5719.hs index 91ec01afbf..c4243f7918 100644 --- a/testsuite/tests/indexed-types/should_run/T5719.hs +++ b/testsuite/tests/indexed-types/should_run/T5719.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleInstances #-} module Main where -import GHC.Prim (Constraint) +import GHC.Exts (Constraint) import Prelude hiding (Functor, fmap) diff --git a/testsuite/tests/mdo/should_compile/mdo006.hs b/testsuite/tests/mdo/should_compile/mdo006.hs index 6ccfb94041..3d4a4dd09b 100644 --- a/testsuite/tests/mdo/should_compile/mdo006.hs +++ b/testsuite/tests/mdo/should_compile/mdo006.hs @@ -1,6 +1,6 @@ {-# OPTIONS -XRecursiveDo #-} --- This test, from Iavor Diatchki, made GHC 6.2 loop (testLoop) +-- This test, from Iavor Diatchki, made GHC 6.2 loop (testLoop) -- or panic (testPanic); there was a Lint error. -- The reason was a missing bindInstsOfLocalFuns in tcStmtAndThen diff --git a/testsuite/tests/module/mod71.stderr b/testsuite/tests/module/mod71.stderr index a85f7cf182..9c72697300 100644 --- a/testsuite/tests/module/mod71.stderr +++ b/testsuite/tests/module/mod71.stderr @@ -1,12 +1,12 @@ -
-mod71.hs:4:9: error:
- Found hole: _ :: t1
- Where: ‘t1’ is a rigid type variable bound by
- the inferred type of f :: Num a => (t1 -> a -> t) -> t
- at mod71.hs:4:1
- In the first argument of ‘x’, namely ‘_’
- In the expression: x _ 1
- In an equation for ‘f’: f x = x _ 1
- Relevant bindings include
- x :: t1 -> a -> t (bound at mod71.hs:4:3)
- f :: (t1 -> a -> t) -> t (bound at mod71.hs:4:1)
+ +mod71.hs:4:9: error: + • Found hole: _ :: t + Where: ‘t’ is a rigid type variable bound by + the inferred type of f :: Num a => (t -> a -> r) -> r + at mod71.hs:4:1 + • In the first argument of ‘x’, namely ‘_’ + In the expression: x _ 1 + In an equation for ‘f’: f x = x _ 1 + • Relevant bindings include + x :: t -> a -> r (bound at mod71.hs:4:3) + f :: (t -> a -> r) -> r (bound at mod71.hs:4:1) diff --git a/testsuite/tests/module/mod72.stderr b/testsuite/tests/module/mod72.stderr index 8af25f6012..69246edb76 100644 --- a/testsuite/tests/module/mod72.stderr +++ b/testsuite/tests/module/mod72.stderr @@ -1,2 +1,2 @@ -
-mod72.hs:3:7: error: Variable not in scope: g :: t1 -> t
+ +mod72.hs:3:7: error: Variable not in scope: g :: t -> t1 diff --git a/testsuite/tests/parser/should_compile/read014.stderr b/testsuite/tests/parser/should_compile/read014.stderr index f3d8d604fb..5302b3476e 100644 --- a/testsuite/tests/parser/should_compile/read014.stderr +++ b/testsuite/tests/parser/should_compile/read014.stderr @@ -1,7 +1,7 @@ read014.hs:4:1: Warning: Top-level binding with no type signature: - ng1 :: forall t a. Num a => t -> a -> a + ng1 :: forall r a. Num a => r -> a -> a read014.hs:4:5: Warning: Defined but not used: ‘x’ diff --git a/testsuite/tests/parser/should_fail/T3811d.stderr b/testsuite/tests/parser/should_fail/T3811d.stderr index fb23eceb2c..4ba2d16e01 100644 --- a/testsuite/tests/parser/should_fail/T3811d.stderr +++ b/testsuite/tests/parser/should_fail/T3811d.stderr @@ -1,5 +1,5 @@ -T3811d.hs:6:11: +T3811d.hs:6:12: error: Unexpected type ‘D Char’ In the class declaration for ‘C’ A class declaration should have form diff --git a/testsuite/tests/parser/should_fail/T7848.stderr b/testsuite/tests/parser/should_fail/T7848.stderr index 402dc642b0..b957433e9b 100644 --- a/testsuite/tests/parser/should_fail/T7848.stderr +++ b/testsuite/tests/parser/should_fail/T7848.stderr @@ -1,7 +1,7 @@ T7848.hs:6:57: error: • Occurs check: cannot construct the infinite type: - t2 ~ t0 -> t -> t1 -> A -> A -> A -> A -> t2 + t2 ~ r0 -> t -> t1 -> A -> A -> A -> A -> t2 • In the expression: y In an equation for ‘x’: x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) @@ -13,7 +13,7 @@ T7848.hs:6:57: error: {-# SPECIALIZE (&) :: a #-} (&) = x • Relevant bindings include - y :: forall t4. t4 -> t -> t1 -> A -> A -> A -> A -> t2 + y :: forall r. r -> t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:8:9) (&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9) z :: t1 (bound at T7848.hs:6:12) diff --git a/testsuite/tests/parser/should_fail/readFail003.stderr b/testsuite/tests/parser/should_fail/readFail003.stderr index acb265b9b4..8b9b4d0295 100644 --- a/testsuite/tests/parser/should_fail/readFail003.stderr +++ b/testsuite/tests/parser/should_fail/readFail003.stderr @@ -1,16 +1,16 @@ -readFail003.hs:4:27: - Occurs check: cannot construct the infinite type: - t ~ (t, [a], [a1]) - In the expression: a - In a pattern binding: - ~(a, b, c) - | nullity b = a - | nullity c = a - | otherwise = a - where - nullity = null - Relevant bindings include - a :: t (bound at readFail003.hs:4:3) - b :: [a] (bound at readFail003.hs:4:5) - c :: [a1] (bound at readFail003.hs:4:7) +readFail003.hs:4:27: error: + • Occurs check: cannot construct the infinite type: + r ~ (r, [a], [a1]) + • In the expression: a + In a pattern binding: + ~(a, b, c) + | nullity b = a + | nullity c = a + | otherwise = a + where + nullity = null + • Relevant bindings include + a :: r (bound at readFail003.hs:4:3) + b :: [a] (bound at readFail003.hs:4:5) + c :: [a1] (bound at readFail003.hs:4:7) diff --git a/testsuite/tests/partial-sigs/should_compile/ADT.stderr b/testsuite/tests/partial-sigs/should_compile/ADT.stderr index 2a9de4b2cc..0fe16d1ed5 100644 --- a/testsuite/tests/partial-sigs/should_compile/ADT.stderr +++ b/testsuite/tests/partial-sigs/should_compile/ADT.stderr @@ -2,7 +2,7 @@ TYPE SIGNATURES bar :: Int -> Foo Bool () Int TYPE CONSTRUCTORS data Foo x y z = Foo x y z - Promotable + Kind: * -> * -> * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr index ec41b123f1..9698ab2c10 100644 --- a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr @@ -2,7 +2,7 @@ TYPE SIGNATURES foo :: Sing 'A TYPE CONSTRUCTORS data MyKind = A | B - Promotable + Kind: * data family Sing (a :: k) COERCION AXIOMS axiom DataFamilyInstanceLHS.TFCo:R:SingMyKind_ :: diff --git a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr index ef1b755341..cf6a223c45 100644 --- a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr @@ -6,7 +6,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role NukeMonad phantom phantom phantom data NukeMonad a b c - Promotable + Kind: * -> * -> * -> * COERCION AXIOMS INSTANCES instance Functor (NukeMonad a b) -- Defined at Meltdown.hs:8:10 diff --git a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr index 25fa959707..e67eeb095e 100644 --- a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr @@ -5,7 +5,7 @@ TYPE SIGNATURES forall tok st a. GenParser tok st a -> GenParser tok st () TYPE CONSTRUCTORS data GenParser tok st a = GenParser tok st a - Promotable + Kind: * -> * -> * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr index 1a71a3c803..5337cc3d12 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr @@ -6,13 +6,13 @@ T10403.hs:15:7: warning: T10403.hs:15:12: warning: • Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’ - Where: ‘b’ is a rigid type variable bound by + Where: ‘f’ is a rigid type variable bound by the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1 - ‘a’ is a rigid type variable bound by + ‘b’ is a rigid type variable bound by the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1 - ‘f’ is a rigid type variable bound by + ‘a’ is a rigid type variable bound by the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1 • In the type signature: @@ -22,13 +22,13 @@ T10403.hs:15:12: warning: T10403.hs:19:7: warning: • Found type wildcard ‘_’ standing for ‘(a -> b) -> f0 a -> H f0’ - Where: ‘b’ is a rigid type variable bound by + Where: ‘f0’ is an ambiguous type variable + ‘b’ is a rigid type variable bound by the inferred type of h2 :: (a -> b) -> f0 a -> H f0 at T10403.hs:22:1 ‘a’ is a rigid type variable bound by the inferred type of h2 :: (a -> b) -> f0 a -> H f0 at T10403.hs:22:1 - ‘f0’ is an ambiguous type variable • In the type signature: h2 :: _ • Relevant bindings include @@ -59,7 +59,7 @@ T10403.hs:28:8: warning: app2 :: H (B t) at T10403.hs:27:1-15 Expected type: H (B t) - Actual type: H f0 + Actual type: H f0 • In the expression: h2 (H . I) (B ()) In an equation for ‘app2’: app2 = h2 (H . I) (B ()) • Relevant bindings include @@ -73,7 +73,7 @@ T10403.hs:28:20: warning: app2 :: H (B t) at T10403.hs:27:1-15 Expected type: f0 () - Actual type: B t () + Actual type: B t () • In the second argument of ‘h2’, namely ‘(B ())’ In the expression: h2 (H . I) (B ()) • Relevant bindings include diff --git a/testsuite/tests/partial-sigs/should_compile/T10438.stderr b/testsuite/tests/partial-sigs/should_compile/T10438.stderr index f070b3b8a0..5624d8dc9e 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10438.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10438.stderr @@ -1,8 +1,8 @@ T10438.hs:7:22: warning: - • Found type wildcard ‘_’ standing for ‘t2’ - Where: ‘t2’ is a rigid type variable bound by - the inferred type of g :: t2 -> t2 at T10438.hs:6:9 + • Found type wildcard ‘_’ standing for ‘r2’ + Where: ‘r2’ is a rigid type variable bound by + the inferred type of g :: r2 -> r2 at T10438.hs:6:9 • In the type signature: x :: _ In an equation for ‘g’: @@ -21,8 +21,8 @@ T10438.hs:7:22: warning: x :: _ x = r • Relevant bindings include - x :: t2 (bound at T10438.hs:8:17) - r :: t2 (bound at T10438.hs:6:11) - g :: t2 -> t2 (bound at T10438.hs:6:9) - f :: t (bound at T10438.hs:5:5) - foo :: t -> t1 -> t1 (bound at T10438.hs:5:1) + x :: r2 (bound at T10438.hs:8:17) + r :: r2 (bound at T10438.hs:6:11) + g :: r2 -> r2 (bound at T10438.hs:6:9) + f :: r (bound at T10438.hs:5:5) + foo :: r -> r1 -> r1 (bound at T10438.hs:5:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T11192.stderr b/testsuite/tests/partial-sigs/should_compile/T11192.stderr index 2fac5eb8b6..77b70e3fe2 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11192.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11192.stderr @@ -22,9 +22,9 @@ T11192.hs:7:14: warning: T11192.hs:13:14: warning: • Found type wildcard ‘_’ standing for ‘t -> t1 -> t1’ - Where: ‘t’ is a rigid type variable bound by + Where: ‘t1’ is a rigid type variable bound by the inferred type of go :: t -> t1 -> t1 at T11192.hs:14:8 - ‘t1’ is a rigid type variable bound by + ‘t’ is a rigid type variable bound by the inferred type of go :: t -> t1 -> t1 at T11192.hs:14:8 • In the type signature: go :: _ diff --git a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr index ebd327c98f..2d5f52e357 100644 --- a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr @@ -1,7 +1,8 @@ TYPE SIGNATURES foo :: F Int Char -> Int TYPE CONSTRUCTORS - type family F a b :: * open + type family F a b open + Kind: * -> * -> * COERCION AXIOMS axiom TypeFamilyInstanceLHS.TFCo:R:FBool_ :: F Bool _ = Bool -- Defined at TypeFamilyInstanceLHS.hs:6:15 diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr index def47612d3..8b9eb466ad 100644 --- a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - bar :: forall t t1. t -> (t -> t1) -> t1 + bar :: forall t t1. t1 -> (t1 -> t) -> t foo :: forall a. (Show a, Enum a) => a -> String TYPE CONSTRUCTORS COERCION AXIOMS @@ -30,37 +30,37 @@ WarningWildcardInstantiations.hs:5:30: warning: foo :: a -> String (bound at WarningWildcardInstantiations.hs:6:1) WarningWildcardInstantiations.hs:8:8: warning: - • Found type wildcard ‘_’ standing for ‘t’ - Where: ‘t’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + • Found type wildcard ‘_’ standing for ‘t1’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of bar :: t1 -> (t1 -> t) -> t at WarningWildcardInstantiations.hs:9:1 • In the type signature: bar :: _ -> _ -> _ • Relevant bindings include - bar :: t -> (t -> t1) -> t1 + bar :: t1 -> (t1 -> t) -> t (bound at WarningWildcardInstantiations.hs:9:1) WarningWildcardInstantiations.hs:8:13: warning: - • Found type wildcard ‘_’ standing for ‘t -> t1’ + • Found type wildcard ‘_’ standing for ‘t1 -> t’ Where: ‘t’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + the inferred type of bar :: t1 -> (t1 -> t) -> t at WarningWildcardInstantiations.hs:9:1 ‘t1’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + the inferred type of bar :: t1 -> (t1 -> t) -> t at WarningWildcardInstantiations.hs:9:1 • In the type signature: bar :: _ -> _ -> _ • Relevant bindings include - bar :: t -> (t -> t1) -> t1 + bar :: t1 -> (t1 -> t) -> t (bound at WarningWildcardInstantiations.hs:9:1) WarningWildcardInstantiations.hs:8:18: warning: - • Found type wildcard ‘_’ standing for ‘t1’ - Where: ‘t1’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + • Found type wildcard ‘_’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t1 -> (t1 -> t) -> t at WarningWildcardInstantiations.hs:9:1 • In the type signature: bar :: _ -> _ -> _ • Relevant bindings include - bar :: t -> (t -> t1) -> t1 + bar :: t1 -> (t1 -> t) -> t (bound at WarningWildcardInstantiations.hs:9:1) diff --git a/testsuite/tests/partial-sigs/should_fail/T10045.stderr b/testsuite/tests/partial-sigs/should_fail/T10045.stderr index 556201cc04..42218b5fe9 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10045.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10045.stderr @@ -1,9 +1,9 @@ T10045.hs:6:18: error: • Found type wildcard ‘_’ standing for ‘t1 -> Bool -> t2’ - Where: ‘t1’ is a rigid type variable bound by + Where: ‘t2’ is a rigid type variable bound by the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 - ‘t2’ is a rigid type variable bound by + ‘t1’ is a rigid type variable bound by the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 To use the inferred type, enable PartialTypeSignatures • In the type signature: diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr index ac44a19e4b..ddbb9e2b6c 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr @@ -25,40 +25,40 @@ WildcardInstantiations.hs:5:30: error: foo :: a -> String (bound at WildcardInstantiations.hs:6:1) WildcardInstantiations.hs:8:8: error: - • Found type wildcard ‘_’ standing for ‘t’ - Where: ‘t’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + • Found type wildcard ‘_’ standing for ‘t1’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of bar :: t1 -> (t1 -> t) -> t at WildcardInstantiations.hs:9:1 To use the inferred type, enable PartialTypeSignatures • In the type signature: bar :: _ -> _ -> _ • Relevant bindings include - bar :: t -> (t -> t1) -> t1 + bar :: t1 -> (t1 -> t) -> t (bound at WildcardInstantiations.hs:9:1) WildcardInstantiations.hs:8:13: error: - • Found type wildcard ‘_’ standing for ‘t -> t1’ + • Found type wildcard ‘_’ standing for ‘t1 -> t’ Where: ‘t’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + the inferred type of bar :: t1 -> (t1 -> t) -> t at WildcardInstantiations.hs:9:1 ‘t1’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + the inferred type of bar :: t1 -> (t1 -> t) -> t at WildcardInstantiations.hs:9:1 To use the inferred type, enable PartialTypeSignatures • In the type signature: bar :: _ -> _ -> _ • Relevant bindings include - bar :: t -> (t -> t1) -> t1 + bar :: t1 -> (t1 -> t) -> t (bound at WildcardInstantiations.hs:9:1) WildcardInstantiations.hs:8:18: error: - • Found type wildcard ‘_’ standing for ‘t1’ - Where: ‘t1’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> t1) -> t1 + • Found type wildcard ‘_’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t1 -> (t1 -> t) -> t at WildcardInstantiations.hs:9:1 To use the inferred type, enable PartialTypeSignatures • In the type signature: bar :: _ -> _ -> _ • Relevant bindings include - bar :: t -> (t -> t1) -> t1 + bar :: t1 -> (t1 -> t) -> t (bound at WildcardInstantiations.hs:9:1) diff --git a/testsuite/tests/patsyn/should_fail/T9161-2.stderr b/testsuite/tests/patsyn/should_fail/T9161-2.stderr index ebaea2d455..b7a1f360d7 100644 --- a/testsuite/tests/patsyn/should_fail/T9161-2.stderr +++ b/testsuite/tests/patsyn/should_fail/T9161-2.stderr @@ -1,5 +1,6 @@ -
-T9161-2.hs:8:20: error:
- Pattern synonym ‘PATTERN’ used as a type
- In the type signature:
- wrongLift :: Proxy PATTERN ()
+ +T9161-2.hs:8:20: error: + • Pattern synonym ‘PATTERN’ used as a type + • In the first argument of ‘Proxy’, namely ‘PATTERN’ + In the type signature: + wrongLift :: Proxy PATTERN () diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 620a62ceee..ae093be893 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -294,7 +294,7 @@ test('T3064', # 2014-12-01: 162457940 (Windows) # 2014-12-22: 122836340 (Windows) Death to silent superclasses - (wordsize(64), 264952256, 5)]), + (wordsize(64), 304344936, 5)]), # (amd64/Linux) (28/06/2011): 73259544 # (amd64/Linux) (07/02/2013): 224798696 # (amd64/Linux) (02/08/2013): 236404384, increase from roles @@ -313,6 +313,8 @@ test('T3064', # much less code for Monad instances # (amd64/Linux) (01/12/2015): 264952256, Regression due to Simon's wildcard refactor # Tracked as #11151. + # (amd64/Linux) (11/12/2015): 304344936, Regression due to TypeInType + # Tracked as #11196 ################################### # deactivated for now, as this metric became too volatile recently @@ -362,7 +364,7 @@ test('T5030', # of family-applications leads to less sharing, I think # 2015-07-11: 201882912 reason unknown - (wordsize(64), 403932600, 10)]), + (wordsize(64), 653710960, 10)]), # Previously 530000000 (+/- 10%) # 17/1/13: 602993184 (x86_64/Linux) # (new demand analyser) @@ -379,6 +381,7 @@ test('T5030', # 2014-12-10 449042120 constraint solver got worse again; more aggressive solving # of family-applications leads to less sharing, I think # 2015-03-17 403932600 tweak to solver algorithm + # 2015-12-11 653710960 TypeInType (see #11196) only_ways(['normal']) ], @@ -391,13 +394,14 @@ test('T5631', # expected value: 392904228 (x86/Linux) # 2014-04-04: 346389856 (x86 Windows, 64 bit machine) # 2014-12-01: 390199244 (Windows laptop) - (wordsize(64), 812288344, 5)]), + (wordsize(64), 1128828928, 5)]), # expected value: 774595008 (amd64/Linux): # expected value: 735486328 (amd64/Linux) 2012/12/12: # expected value: 690742040 (amd64/Linux) Call Arity improvements # 2014-09-09: 739704712 (amd64/Linux) AMP changes # 2014-11-04: 776121120 (amd64/Linux) new-flatten-skolems # 2015-06-01: 812288344 (amd64/Linux) unknown cause + # 2015-12-11: 1128828928 (amd64/Linux) TypeInType (see #11196) only_ways(['normal']) ], compile, @@ -465,7 +469,7 @@ test('T5321Fun', # (increase due to new codegen) # 2014-09-03: 299656164 (specialisation and inlining) # 10/12/2014: 206406188 # Improvements in constraint solver - (wordsize(64), 509921312, 10)]) + (wordsize(64), 565883176, 10)]) # prev: 585521080 # 29/08/2012: 713385808 # (increase due to new codegen) # 15/05/2013: 628341952 # (reason for decrease unknown) @@ -478,6 +482,7 @@ test('T5321Fun', # 10/08/2015: 509921312 # (undefined now takes an implicit parameter and GHC -O0 does # not recognize that the application is bottom) + # 11/12/2015: 565883176 # TypeInType (see #11196) ], compile,['']) @@ -548,7 +553,7 @@ test('T5837', # 2014-12-01: 135914136 (Windows laptop, regression see below) # 2014-12-08 115905208 Constraint solver perf improvements (esp kick-out) - (wordsize(64), 38834096, 10)]) + (wordsize(64), 43877520, 10)]) # sample: 3926235424 (amd64/Linux, 15/2/2012) # 2012-10-02 81879216 # 2012-09-20 87254264 amd64/Linux @@ -564,6 +569,7 @@ test('T5837', # some optimization # 2015-03-17 53424304 Mac Better depth checking; fails earlier # 2015-06-09 38834096 Better "improvement"; I'm not sure whey it improves things + # 2015-12-11 43877520 amd64/Linux, TypeInType (see #11196) ], compile_fail,['-freduction-depth=50']) @@ -608,18 +614,19 @@ test('T9020', test('T9675', [ only_ways(['optasm']), compiler_stats_num_field('max_bytes_used', # Note [residency] - [(wordsize(64), 23776640, 15), + [(wordsize(64), 30837312, 15), # 2014-10-13 29596552 # 2014-10-13 26570896 seq the DmdEnv in seqDmdType as well # 2014-10-13 18582472 different machines giving different results.. # 2014-10-13 22220552 use the mean # 2015-06-21 28056344 switch to `+RTS -G1`, tighten bound to 15% # 2015-10-28 23776640 emit Typeable at definition site + # 2015-12-11 30837312 TypeInType (see #11196) (wordsize(32), 15341228, 15) # 2015-07-11 15341228 (x86/Linux, 64-bit machine) use +RTS -G1 ]), compiler_stats_num_field('peak_megabytes_allocated', # Note [residency] - [(wordsize(64), 88, 15), + [(wordsize(64), 113, 15), # 2014-10-13 66 # 2014-10-13 58 seq the DmdEnv in seqDmdType as well # 2014-10-13 49 different machines giving different results... @@ -627,6 +634,7 @@ test('T9675', # 2015-06-15 44 reduced for some reason # 2015-06-21 105 switch to `+RTS -G1` # 2015-12-04 88 new pattern checker (D1535) + # 2015-12-11 113 TypeInType (see #11196) (wordsize(32), 56, 15) # 2015-07-11 56 (x86/Linux, 64-bit machine) use +RTS -G1 ]), @@ -647,10 +655,11 @@ test('T9675', test('T9872a', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 2680733672, 5), + [(wordsize(64), 3581500440, 5), # 2014-12-10 5521332656 Initally created # 2014-12-16 5848657456 Flattener parameterized over roles # 2014-12-18 2680733672 Reduce type families even more eagerly + # 2015-12-11 3581500440 TypeInType (see #11196) (wordsize(32), 1325592896, 5) ]), ], @@ -660,10 +669,11 @@ test('T9872a', test('T9872b', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 3480212048, 5), + [(wordsize(64), 5199926080, 5), # 2014-12-10 6483306280 Initally created # 2014-12-16 6892251912 Flattener parameterized over roles # 2014-12-18 3480212048 Reduce type families even more eagerly + # 2015-12-11 5199926080 TypeInType (see #11196) (wordsize(32), 1700000000, 5) ]), ], @@ -672,10 +682,11 @@ test('T9872b', test('T9872c', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 2963554096, 5), + [(wordsize(64), 4723613784, 5), # 2014-12-10 5495850096 Initally created # 2014-12-16 5842024784 Flattener parameterized over roles # 2014-12-18 2963554096 Reduce type families even more eagerly + # 2015-12-11 4723613784 TypeInType (see #11196) (wordsize(32), 1500000000, 5) ]), ], @@ -683,16 +694,19 @@ test('T9872c', ['']) test('T9872d', [ only_ways(['normal']), - compiler_stats_num_field('bytes allocated', - [(wordsize(64), 726679784, 5), + expect_broken(11203), + # compiler_stats_num_field('bytes allocated', + # [(wordsize(64), 59651432, 5), # 2014-12-18 796071864 Initally created # 2014-12-18 739189056 Reduce type families even more eagerly # 2015-01-07 687562440 TrieMap leaf compression # 2015-03-17 726679784 tweak to solver; probably flattens more - (wordsize(32), 350369584, 5) + # (wordsize(32), 59651432, 5) # some date 328810212 # 2015-07-11 350369584 - ]), + # 2015-12-11 59651432 Massive improvement from TypeInType + # but see also #11196 + # ]), ], compile, ['']) diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 22107a9185..9b8785f9c8 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -5,7 +5,7 @@ test('haddock.base', [unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 9894189856, 5) + [(wordsize(64), 11119767632, 5) # 2012-08-14: 5920822352 (amd64/Linux) # 2012-09-20: 5829972376 (amd64/Linux) # 2012-10-08: 5902601224 (amd64/Linux) @@ -25,6 +25,7 @@ test('haddock.base', # 2014-01-08: 9014511528 (x86_64/Linux) - Eliminate so-called "silent superclass parameters" (and others) # 2015-07-22: 9418857192 (x86_64/Linux) - Just slowly creeping up. # 2015-10-03: 9894189856 (x86_64/Linux) - Still creeping + # 2015-12-11: 11119767632 (amd64/Linux) TypeInType (see #11196) ,(platform('i386-unknown-mingw32'), 4434804940, 5) # 2013-02-10: 3358693084 (x86/Windows) @@ -47,7 +48,7 @@ test('haddock.base', test('haddock.Cabal', [unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 7413958344, 5) + [(wordsize(64), 8114833312, 5) # 2012-08-14: 3255435248 (amd64/Linux) # 2012-08-29: 3324606664 (amd64/Linux, new codegen) # 2012-10-08: 3373401360 (amd64/Linux) @@ -68,6 +69,7 @@ test('haddock.Cabal', # 2014-12-14: 6387320816 (x86_64/Linux) - Update to Haddock 2.16 # 2015-01-22: 6710234312 (x86_64/Linux) - Cabal updated # 2015-06-29: 7413958344 (x86_64/Linux) due to #10482, not yet investigated + # 2015-12-11: 8114833312 (amd64/Linux) TypeInType (See #11196) ,(platform('i386-unknown-mingw32'), 3293415576, 5) # 2012-10-30: 1733638168 (x86/Windows) diff --git a/testsuite/tests/polykinds/PolyInstances.hs b/testsuite/tests/polykinds/PolyInstances.hs new file mode 100644 index 0000000000..cc15126142 --- /dev/null +++ b/testsuite/tests/polykinds/PolyInstances.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables, + UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module PolyInstances where + +import GHC.Exts +import Data.Proxy + +class C (a :: k) + +instance (C a, C b) => C (a b) + +data Dict :: Constraint -> * + +instance C Dict + +foo :: C p => proxy p -> () +foo = undefined + +bar :: forall (p :: Constraint) proxy. C p => proxy p -> () +bar _ = foo (Proxy :: Proxy (Dict p)) diff --git a/testsuite/tests/polykinds/PolyKinds02.stderr b/testsuite/tests/polykinds/PolyKinds02.stderr index 7c5716a65e..b95cd4f207 100644 --- a/testsuite/tests/polykinds/PolyKinds02.stderr +++ b/testsuite/tests/polykinds/PolyKinds02.stderr @@ -1,5 +1,6 @@ -
-PolyKinds02.hs:13:16: error:
- The second argument of ‘Vec’ should have kind ‘Nat’,
- but ‘Nat’ has kind ‘*’
- In the type signature: vec :: Vec Nat Nat
+ +PolyKinds02.hs:13:16: error: + • Expected kind ‘Nat’, but ‘Nat’ has kind ‘*’ + • In the second argument of ‘Vec’, namely ‘Nat’ + In the type signature: + vec :: Vec Nat Nat diff --git a/testsuite/tests/polykinds/PolyKinds04.stderr b/testsuite/tests/polykinds/PolyKinds04.stderr index eaa4c07909..8162dd247b 100644 --- a/testsuite/tests/polykinds/PolyKinds04.stderr +++ b/testsuite/tests/polykinds/PolyKinds04.stderr @@ -1,8 +1,7 @@ PolyKinds04.hs:5:16: Expecting one more argument to ‘Maybe’ - The first argument of ‘A’ should have kind ‘*’, - but ‘Maybe’ has kind ‘* -> *’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + In the first argument of ‘A’, namely ‘Maybe’ In the type ‘A Maybe’ In the definition of data constructor ‘B1’ - In the data declaration for ‘B’ diff --git a/testsuite/tests/polykinds/PolyKinds07.stderr b/testsuite/tests/polykinds/PolyKinds07.stderr index 6b1d6c137d..3a38a6777f 100644 --- a/testsuite/tests/polykinds/PolyKinds07.stderr +++ b/testsuite/tests/polykinds/PolyKinds07.stderr @@ -2,6 +2,6 @@ PolyKinds07.hs:10:11: Data constructor ‘A1’ cannot be used here (it is defined and used in the same recursive group) + In the first argument of ‘B’, namely ‘A1’ In the type ‘B A1’ In the definition of data constructor ‘B1’ - In the data declaration for ‘B’ diff --git a/testsuite/tests/polykinds/SigTvKinds.hs b/testsuite/tests/polykinds/SigTvKinds.hs new file mode 100644 index 0000000000..782a7b3f8b --- /dev/null +++ b/testsuite/tests/polykinds/SigTvKinds.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds #-} + +module SigTvKinds where + +data T (a :: k1) x = MkT (S a ()) +data S (b :: k2) y = MkS (T b ()) + -- tests TcTyClsDecls.no_sig_tv diff --git a/testsuite/tests/polykinds/SigTvKinds2.hs b/testsuite/tests/polykinds/SigTvKinds2.hs new file mode 100644 index 0000000000..1ec1ebb0f6 --- /dev/null +++ b/testsuite/tests/polykinds/SigTvKinds2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds #-} + +module SigTvKinds2 where + +data SameKind :: k -> k -> * + +data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) diff --git a/testsuite/tests/polykinds/SigTvKinds2.stderr b/testsuite/tests/polykinds/SigTvKinds2.stderr new file mode 100644 index 0000000000..9f523705a6 --- /dev/null +++ b/testsuite/tests/polykinds/SigTvKinds2.stderr @@ -0,0 +1,6 @@ + +SigTvKinds2.hs:7:48: error: + • Expected kind ‘k1’, but ‘b’ has kind ‘k2’ + • In the second argument of ‘SameKind’, namely ‘b’ + In the type ‘SameKind a b’ + In the definition of data constructor ‘MkQ’ diff --git a/testsuite/tests/polykinds/T10503.stderr b/testsuite/tests/polykinds/T10503.stderr index 071ab5e88e..7c39c41738 100644 --- a/testsuite/tests/polykinds/T10503.stderr +++ b/testsuite/tests/polykinds/T10503.stderr @@ -1,15 +1,18 @@ -
-T10503.hs:8:6: error:
- Couldn't match kind ‘k’ with ‘*’
- ‘k’ is a rigid type variable bound by
- the type signature for:
- h :: forall (k :: BOX) r.
- ((Proxy 'KProxy ~ Proxy 'KProxy) => r) -> r
- at T10503.hs:8:6
- Expected type: Proxy 'KProxy
- Actual type: Proxy 'KProxy
- In the ambiguity check for ‘h’
- To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
- In the type signature:
- h :: forall r.
- (Proxy (KProxy :: KProxy k) ~ Proxy (KProxy :: KProxy *) => r) -> r
+ +T10503.hs:8:6: error: + • Could not deduce: k ~ * + from the context: Proxy 'KProxy ~ Proxy 'KProxy + bound by the type signature for: + h :: (Proxy 'KProxy ~ Proxy 'KProxy) => r + at T10503.hs:8:6-85 + ‘k’ is a rigid type variable bound by + the type signature for: + h :: forall k r. ((Proxy 'KProxy ~ Proxy 'KProxy) => r) -> r + at T10503.hs:8:6 + Expected type: ((Proxy 'KProxy ~ Proxy 'KProxy) => r) -> r + Actual type: ((Proxy 'KProxy ~ Proxy 'KProxy) => r) -> r + • In the ambiguity check for ‘h’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the type signature: + h :: forall r. + (Proxy (KProxy :: KProxy k) ~ Proxy (KProxy :: KProxy *) => r) -> r diff --git a/testsuite/tests/polykinds/T11142.hs b/testsuite/tests/polykinds/T11142.hs new file mode 100644 index 0000000000..58eb3b6c94 --- /dev/null +++ b/testsuite/tests/polykinds/T11142.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeInType, RankNTypes #-} + +module T11142 where + +import Data.Kind + +data SameKind :: k -> k -> * + +foo :: forall b. (forall k (a :: k). SameKind a b) -> () +foo = undefined diff --git a/testsuite/tests/polykinds/T11142.stderr b/testsuite/tests/polykinds/T11142.stderr new file mode 100644 index 0000000000..2cb4e61f19 --- /dev/null +++ b/testsuite/tests/polykinds/T11142.stderr @@ -0,0 +1,7 @@ + +T11142.hs:9:8: error: + • The kind of variable ‘b’, namely ‘k’, + depends on variable ‘k’ from an inner scope + Perhaps bind ‘b’ sometime after binding ‘k’ + • In the type signature: + foo :: forall b. (forall k (a :: k). SameKind a b) -> () diff --git a/testsuite/tests/polykinds/T5716.hs b/testsuite/tests/polykinds/T5716.hs index 572de5e4e8..1b705a36b1 100644 --- a/testsuite/tests/polykinds/T5716.hs +++ b/testsuite/tests/polykinds/T5716.hs @@ -5,7 +5,7 @@ module T5716 where -data family DF a +data family DF a data instance DF Int = DFInt data U = U1 (DF Int) diff --git a/testsuite/tests/polykinds/T5716.stderr b/testsuite/tests/polykinds/T5716.stderr index 227a6b88c6..8bc8883daf 100644 --- a/testsuite/tests/polykinds/T5716.stderr +++ b/testsuite/tests/polykinds/T5716.stderr @@ -1,4 +1,7 @@ -T5716.hs:13:11: - ‘U’ of kind ‘*’ is not promotable - In the kind ‘U -> *’ +T5716.hs:13:33: error: + Data constructor ‘U1’ cannot be used here + (Perhaps you intended to use TypeInType) + In the first argument of ‘I’, namely ‘U1 DFInt’ + In the type ‘I (U1 DFInt)’ + In the definition of data constructor ‘I1’ diff --git a/testsuite/tests/polykinds/T6021.hs b/testsuite/tests/polykinds/T6021.hs index 0a89bf9570..77915a266e 100644 --- a/testsuite/tests/polykinds/T6021.hs +++ b/testsuite/tests/polykinds/T6021.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, PolyKinds, MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures, PolyKinds, MultiParamTypeClasses, FlexibleInstances #-} module T6021 where class Panic a b diff --git a/testsuite/tests/polykinds/T6021.stderr b/testsuite/tests/polykinds/T6021.stderr index 0b7ce77439..d747043d27 100644 --- a/testsuite/tests/polykinds/T6021.stderr +++ b/testsuite/tests/polykinds/T6021.stderr @@ -1,5 +1,4 @@ -
-T6021.hs:5:22: error:
- Type variable ‘b’ used as a kind
- In the kind ‘b’
- In the instance declaration for ‘Panic (a :: b) b’
+ +T6021.hs:5:22: error: + Variable ‘b’ used as both a kind and a type + Did you intend to use TypeInType? diff --git a/testsuite/tests/polykinds/T6039.stderr b/testsuite/tests/polykinds/T6039.stderr deleted file mode 100644 index def904ea33..0000000000 --- a/testsuite/tests/polykinds/T6039.stderr +++ /dev/null @@ -1,4 +0,0 @@ - -T6039.hs:5:14: - Kind variable ‘j’ cannot appear in a function position - In the kind ‘j k’ diff --git a/testsuite/tests/polykinds/T6129.stderr b/testsuite/tests/polykinds/T6129.stderr index 36b749680b..451d851c5d 100644 --- a/testsuite/tests/polykinds/T6129.stderr +++ b/testsuite/tests/polykinds/T6129.stderr @@ -2,6 +2,6 @@ T6129.hs:12:11: Data constructor ‘DInt’ cannot be used here (it comes from a data family instance) + In the first argument of ‘X’, namely ‘DInt’ In the type ‘X DInt’ In the definition of data constructor ‘X1’ - In the data declaration for ‘X’ diff --git a/testsuite/tests/polykinds/T7224.stderr b/testsuite/tests/polykinds/T7224.stderr index b957a1ba65..daab1c40a9 100644 --- a/testsuite/tests/polykinds/T7224.stderr +++ b/testsuite/tests/polykinds/T7224.stderr @@ -1,6 +1,7 @@ -
-T7224.hs:6:19: error:
- Kind variable ‘i’ used as a type
- In the type signature:
- ret' :: a -> m i i a
- In the class declaration for ‘PMonad'’
+ +T7224.hs:6:19: error: + • Expected kind ‘i’, but ‘i’ has kind ‘*’ + • In the first argument of ‘m’, namely ‘i’ + In the type signature: + ret' :: a -> m i i a + In the class declaration for ‘PMonad'’ diff --git a/testsuite/tests/polykinds/T7230.stderr b/testsuite/tests/polykinds/T7230.stderr index 92938bedb1..36e333c5ec 100644 --- a/testsuite/tests/polykinds/T7230.stderr +++ b/testsuite/tests/polykinds/T7230.stderr @@ -8,18 +8,18 @@ T7230.hs:48:32: error: at T7230.hs:47:1-68 or from: xs ~ (x : xs1) bound by a pattern with constructor: - SCons :: forall (k :: BOX) (x :: k) (xs :: [k]). + SCons :: forall a (x :: a) (xs :: [a]). Sing x -> Sing xs -> Sing (x : xs), in an equation for ‘crash’ at T7230.hs:48:8-27 or from: xs1 ~ (x1 : xs2) bound by a pattern with constructor: - SCons :: forall (k :: BOX) (x :: k) (xs :: [k]). + SCons :: forall a (x :: a) (xs :: [a]). Sing x -> Sing xs -> Sing (x : xs), in an equation for ‘crash’ at T7230.hs:48:17-26 Expected type: SBool (Increasing xs) - Actual type: SBool (x :<<= x1) + Actual type: SBool (x :<<= x1) • In the expression: x %:<<= y In an equation for ‘crash’: crash (SCons x (SCons y xs)) = x %:<<= y diff --git a/testsuite/tests/polykinds/T7278.hs b/testsuite/tests/polykinds/T7278.hs index d43e60c7a7..af4800507e 100644 --- a/testsuite/tests/polykinds/T7278.hs +++ b/testsuite/tests/polykinds/T7278.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TypeFamilies, PolyKinds, MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies, PolyKinds, MultiParamTypeClasses, FlexibleContexts, + AllowAmbiguousTypes #-} module T7278 where type family TF (t :: k) :: * -> * -> * diff --git a/testsuite/tests/polykinds/T7278.stderr b/testsuite/tests/polykinds/T7278.stderr index f8b2cfface..676be2cb0f 100644 --- a/testsuite/tests/polykinds/T7278.stderr +++ b/testsuite/tests/polykinds/T7278.stderr @@ -1,5 +1,6 @@ -
-T7278.hs:8:43: error:
- ‘t’ is applied to too many type arguments
- In the type signature:
- f :: (C (t :: k) (TF t)) => TF t p1 p0 -> t p1 p0
+ +T7278.hs:9:43: error: + • Expecting two fewer arguments to ‘t’ + Expected kind ‘* -> * -> *’, but ‘t’ has kind ‘k’ + • In the type signature: + f :: (C (t :: k) (TF t)) => TF t p1 p0 -> t p1 p0 diff --git a/testsuite/tests/polykinds/T7328.hs b/testsuite/tests/polykinds/T7328.hs index 3e51875508..f51efb7943 100644 --- a/testsuite/tests/polykinds/T7328.hs +++ b/testsuite/tests/polykinds/T7328.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PolyKinds, GADTs #-} +{-# LANGUAGE PolyKinds, GADTs, AllowAmbiguousTypes #-} module T7328 where diff --git a/testsuite/tests/polykinds/T7328.stderr b/testsuite/tests/polykinds/T7328.stderr index 9e7cbab03a..31b425f644 100644 --- a/testsuite/tests/polykinds/T7328.stderr +++ b/testsuite/tests/polykinds/T7328.stderr @@ -1,8 +1,7 @@ -
-T7328.hs:8:34: error:
- Kind occurs check
- The first argument of ‘Foo’ should have kind ‘k0’,
- but ‘f’ has kind ‘k1 -> k0’
- In the type signature:
- foo :: a ~ f i => Proxy (Foo f)
- In the class declaration for ‘Foo’
+ +T7328.hs:8:34: error: + • Occurs check: cannot construct the infinite kind: k10 ~ k0 -> k10 + • In the first argument of ‘Foo’, namely ‘f’ + In the first argument of ‘Proxy’, namely ‘Foo f’ + In the type signature: + foo :: a ~ f i => Proxy (Foo f) diff --git a/testsuite/tests/polykinds/T7341.hs b/testsuite/tests/polykinds/T7341.hs index 1c91847dfc..79d056532a 100644 --- a/testsuite/tests/polykinds/T7341.hs +++ b/testsuite/tests/polykinds/T7341.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, TypeFamilies, PolyKinds #-} +{-# LANGUAGE KindSignatures, TypeFamilies, PolyKinds, FlexibleInstances #-} module T7341 where diff --git a/testsuite/tests/polykinds/T7341.stderr b/testsuite/tests/polykinds/T7341.stderr index c5dd260660..925c68e52d 100644 --- a/testsuite/tests/polykinds/T7341.stderr +++ b/testsuite/tests/polykinds/T7341.stderr @@ -1,6 +1,6 @@ T7341.hs:11:12: Expecting one more argument to ‘[]’ - The first argument of ‘C’ should have kind ‘*’, - but ‘[]’ has kind ‘* -> *’ + Expected a type, but ‘[]’ has kind ‘* -> *’ + In the first argument of ‘C’, namely ‘[]’ In the instance declaration for ‘C []’ diff --git a/testsuite/tests/polykinds/T7404.stderr b/testsuite/tests/polykinds/T7404.stderr index d9d4288c56..a8b953e5df 100644 --- a/testsuite/tests/polykinds/T7404.stderr +++ b/testsuite/tests/polykinds/T7404.stderr @@ -1,4 +1,5 @@ -T7404.hs:4:1: - Kind variable also used as type variable: ‘x’ - In the declaration for type family ‘Foo’ +T7404.hs:4:32: error: + Type variable ‘x’ used in a kind. + Did you mean to use TypeInType? + the declaration for type family ‘Foo’ diff --git a/testsuite/tests/polykinds/T7438.stderr b/testsuite/tests/polykinds/T7438.stderr index ca09383a2d..539d15d406 100644 --- a/testsuite/tests/polykinds/T7438.stderr +++ b/testsuite/tests/polykinds/T7438.stderr @@ -1,20 +1,19 @@ T7438.hs:6:14: error: - Couldn't match expected type ‘t1’ with actual type ‘t’ - ‘t’ is untouchable - inside the constraints: t2 ~ t3 - bound by a pattern with constructor: - Nil :: forall (k :: BOX) (b :: k). Thrist b b, - in an equation for ‘go’ - at T7438.hs:6:4-6 - ‘t’ is a rigid type variable bound by - the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1 - ‘t1’ is a rigid type variable bound by - the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1 - Possible fix: add a type signature for ‘go’ - In the expression: acc - In an equation for ‘go’: go Nil acc = acc - Relevant bindings include - acc :: t (bound at T7438.hs:6:8) - go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1) - + • Couldn't match expected type ‘r1’ with actual type ‘r’ + ‘r1’ is untouchable + inside the constraints: r3 ~ r2 + bound by a pattern with constructor: + Nil :: forall k (a :: k). Thrist a a, + in an equation for ‘go’ + at T7438.hs:6:4-6 + ‘r1’ is a rigid type variable bound by + the inferred type of go :: Thrist r2 r3 -> r -> r1 at T7438.hs:6:1 + ‘r’ is a rigid type variable bound by + the inferred type of go :: Thrist r2 r3 -> r -> r1 at T7438.hs:6:1 + Possible fix: add a type signature for ‘go’ + • In the expression: acc + In an equation for ‘go’: go Nil acc = acc + • Relevant bindings include + acc :: r (bound at T7438.hs:6:8) + go :: Thrist r2 r3 -> r -> r1 (bound at T7438.hs:6:1) diff --git a/testsuite/tests/polykinds/T7481.stderr b/testsuite/tests/polykinds/T7481.stderr deleted file mode 100644 index cca905d5e5..0000000000 --- a/testsuite/tests/polykinds/T7481.stderr +++ /dev/null @@ -1,4 +0,0 @@ - -T7481.hs:12:13: - ‘D’ of kind ‘* -> *’ is not promotable - In the kind ‘D * -> *’ diff --git a/testsuite/tests/polykinds/T7524.stderr b/testsuite/tests/polykinds/T7524.stderr index 83b355e312..2340ce1aa6 100644 --- a/testsuite/tests/polykinds/T7524.stderr +++ b/testsuite/tests/polykinds/T7524.stderr @@ -1,6 +1,6 @@ -
-T7524.hs:5:15:
- Conflicting family instance declarations:
- forall (k :: BOX) (a :: k). F a a = Int -- Defined at T7524.hs:5:15
- forall (k :: BOX) (k1 :: BOX) (a :: k) (b :: k1).
- F a b = Bool -- Defined at T7524.hs:6:15
+ +T7524.hs:5:15: error: + Conflicting family instance declarations: + forall k2 (a :: k2). F a a = Int -- Defined at T7524.hs:5:15 + forall k2 k1 (a :: k1) (b :: k2). + F a b = Bool -- Defined at T7524.hs:6:15 diff --git a/testsuite/tests/polykinds/T7594.hs b/testsuite/tests/polykinds/T7594.hs index 2cbd3db88d..18da70342c 100644 --- a/testsuite/tests/polykinds/T7594.hs +++ b/testsuite/tests/polykinds/T7594.hs @@ -8,7 +8,7 @@ {-# LANGUAGE Rank2Types #-} module T7594 where -import GHC.Prim (Constraint) +import GHC.Exts (Constraint) class (c1 t, c2 t) => (:&:) (c1 :: * -> Constraint) (c2 :: * -> Constraint) (t :: *) instance (c1 t, c2 t) => (:&:) c1 c2 t @@ -33,5 +33,3 @@ q2 = error "urk" bar2 = app print q2 -- This one fail, because the given constraint is -- (c :&: Real) a, which might have equality superclasses - - diff --git a/testsuite/tests/polykinds/T7805.stderr b/testsuite/tests/polykinds/T7805.stderr index bdf0f21b14..33b9d4df6b 100644 --- a/testsuite/tests/polykinds/T7805.stderr +++ b/testsuite/tests/polykinds/T7805.stderr @@ -1,4 +1,6 @@ -T7805.hs:6:21: - ‘HigherRank’ of kind ‘*’ is not promotable - In the kind ‘HigherRank’ +T7805.hs:7:21: error: + Expected kind ‘forall a. a -> a’, but ‘x’ has kind ‘k0’ + In the first argument of ‘HR’, namely ‘x’ + In the first argument of ‘F’, namely ‘HR x’ + In the type instance declaration for ‘F’ diff --git a/testsuite/tests/polykinds/T7939a.stderr b/testsuite/tests/polykinds/T7939a.stderr index 22388ddca0..4b24b3dc72 100644 --- a/testsuite/tests/polykinds/T7939a.stderr +++ b/testsuite/tests/polykinds/T7939a.stderr @@ -1,7 +1,6 @@ T7939a.hs:7:5: Expecting one more argument to ‘Maybe’ - The first argument of ‘F’ should have kind ‘*’, - but ‘Maybe’ has kind ‘* -> *’ - In the type ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + In the first argument of ‘F’, namely ‘Maybe’ In the type family declaration for ‘F’ diff --git a/testsuite/tests/polykinds/T8566.stderr b/testsuite/tests/polykinds/T8566.stderr index 168e890404..1e7818c5ef 100644 --- a/testsuite/tests/polykinds/T8566.stderr +++ b/testsuite/tests/polykinds/T8566.stderr @@ -1,19 +1,18 @@ -
-T8566.hs:32:9:
- Could not deduce (C ('AA (t (I a ps)) as) ps fs0)
- arising from a use of ‘c’
- from the context: C ('AA (t (I a ps)) as) ps fs
- bound by the instance declaration at T8566.hs:30:10-67
- or from: 'AA t (a : as) ~ 'AA t1 as1
- bound by a pattern with constructor:
- A :: forall (r :: [*]) (k :: BOX) (t :: k) (as :: [U *]).
- I ('AA t as) r,
- in an equation for ‘c’
- at T8566.hs:32:5
- The type variable ‘fs0’ is ambiguous
- Relevant bindings include
- c :: I ('AA t (a : as)) ps -> I ('AA t (a : as)) ps
- (bound at T8566.hs:32:3)
- In the expression: c undefined
- In an equation for ‘c’: c A = c undefined
- In the instance declaration for ‘C ('AA t (a : as)) ps fs’
+ +T8566.hs:32:9: error: + • Could not deduce (C ('AA (t (I a ps)) as) ps fs0) + arising from a use of ‘c’ + from the context: C ('AA (t (I a ps)) as) ps fs + bound by the instance declaration at T8566.hs:30:10-67 + or from: 'AA t (a : as) ~ 'AA t1 as1 + bound by a pattern with constructor: + A :: forall (r :: [*]) v (t :: v) (as :: [U *]). I ('AA t as) r, + in an equation for ‘c’ + at T8566.hs:32:5 + The type variable ‘fs0’ is ambiguous + Relevant bindings include + c :: I ('AA t (a : as)) ps -> I ('AA t (a : as)) ps + (bound at T8566.hs:32:3) + • In the expression: c undefined + In an equation for ‘c’: c A = c undefined + In the instance declaration for ‘C ('AA t (a : as)) ps fs’ diff --git a/testsuite/tests/polykinds/T8616.stderr b/testsuite/tests/polykinds/T8616.stderr index 5c8449826d..00c9c6328e 100644 --- a/testsuite/tests/polykinds/T8616.stderr +++ b/testsuite/tests/polykinds/T8616.stderr @@ -1,7 +1,9 @@ -T8616.hs:8:29: - Expected a type, but ‘Any’ has kind ‘k’ - In an expression type signature: (Any :: k) - In the expression: undefined :: (Any :: k) - In an equation for ‘withSomeSing’: - withSomeSing = undefined :: (Any :: k) +T8616.hs:8:29: error: + • Expected a type, but ‘Any’ has kind ‘k’ + • In an expression type signature: (Any :: k) + In the expression: undefined :: (Any :: k) + In an equation for ‘withSomeSing’: + withSomeSing = undefined :: (Any :: k) + • Relevant bindings include + withSomeSing :: Proxy kproxy (bound at T8616.hs:8:1) diff --git a/testsuite/tests/polykinds/T9200b.stderr b/testsuite/tests/polykinds/T9200b.stderr index 5e8c730878..22f9df73f1 100644 --- a/testsuite/tests/polykinds/T9200b.stderr +++ b/testsuite/tests/polykinds/T9200b.stderr @@ -1,6 +1,5 @@ -T9200b.hs:8:5: - The first argument of ‘F’ should have kind ‘k’, - but ‘True’ has kind ‘Bool’ - In the type ‘True’ +T9200b.hs:8:5: error: + Expected kind ‘k’, but ‘'True’ has kind ‘Bool’ + In the first argument of ‘F’, namely ‘True’ In the type family declaration for ‘F’ diff --git a/testsuite/tests/polykinds/T9222.stderr b/testsuite/tests/polykinds/T9222.stderr index 6a45c4a7fb..69e850caf8 100644 --- a/testsuite/tests/polykinds/T9222.stderr +++ b/testsuite/tests/polykinds/T9222.stderr @@ -1,19 +1,19 @@ T9222.hs:13:3: error: - Couldn't match type ‘b0’ with ‘b’ - ‘b0’ is untouchable - inside the constraints: a ~ '(b0, c0) - bound by the type of the constructor ‘Want’: - (a ~ '(b0, c0)) => Proxy b0 + • Couldn't match type ‘b0’ with ‘b’ + ‘b0’ is untouchable + inside the constraints: a ~ '(b0, c0) + bound by the type of the constructor ‘Want’: + (a ~ '(b0, c0)) => Proxy b0 + at T9222.hs:13:3 + ‘b’ is a rigid type variable bound by + the type of the constructor ‘Want’: + forall i j (a :: (i, j)) (b :: i) (c :: j). + ((a ~ '(b, c)) => Proxy b) -> Want a at T9222.hs:13:3 - ‘b’ is a rigid type variable bound by - the type of the constructor ‘Want’: - forall (k :: BOX) (k1 :: BOX) (a :: (,) k k1) (b :: k) (c :: k1). - ((a ~ '(b, c)) => Proxy b) -> Want a - at T9222.hs:13:3 - Expected type: '(b, c) - Actual type: a - In the ambiguity check for ‘Want’ - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the definition of data constructor ‘Want’ - In the data type declaration for ‘Want’ + Expected type: Proxy b0 + Actual type: Proxy b + • In the ambiguity check for ‘Want’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the definition of data constructor ‘Want’ + In the data type declaration for ‘Want’ diff --git a/testsuite/tests/polykinds/T9569.hs b/testsuite/tests/polykinds/T9569.hs index 0e1fdd596a..1b8bb68c75 100644 --- a/testsuite/tests/polykinds/T9569.hs +++ b/testsuite/tests/polykinds/T9569.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes, ConstraintKinds, KindSignatures, DataKinds, TypeFamilies #-} module T9569 where -import GHC.Prim +import GHC.Exts data Proxy (c :: Constraint) @@ -23,4 +23,4 @@ instance (Deferrable c1, Deferrable c2) => Deferrable (c1,c2) where [W] Proxy (c1,c2) -> ((c1,c2) => a) -> a ~ Proxy (c1x,c2x) -> ((c1x,c2x) => ax) -> ax [w] Deferrable c1x [w] Deferrable c2x --}
\ No newline at end of file +-} diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T index b1e0793a4e..a93ad8bc41 100644 --- a/testsuite/tests/polykinds/all.T +++ b/testsuite/tests/polykinds/all.T @@ -37,7 +37,7 @@ test('T6035', normal, compile, ['']) test('T6036', normal, compile, ['']) test('T6025', normal, run_command, ['$MAKE -s --no-print-directory T6025']) test('T6002', normal, compile, ['']) -test('T6039', normal, compile_fail, ['']) +test('T6039', normal, compile, ['']) test('T6021', normal, compile_fail, ['']) test('T6020a', normal, compile, ['']) test('T6044', normal, compile, ['']) @@ -94,8 +94,8 @@ test('T8449', normal, run_command, ['$MAKE -s --no-print-directory T8449']) test('T8534', normal, compile, ['']) test('T8566', normal, compile_fail,['']) test('T8616', normal, compile_fail,['']) -test('T8566a', expect_broken(8566), compile,['']) -test('T7481', normal, compile_fail,['']) +test('T8566a', normal, compile,['']) +test('T7481', normal, compile,['']) test('T8705', normal, compile, ['']) test('T8985', normal, compile, ['']) test('T9106', normal, compile_fail, ['']) @@ -112,6 +112,7 @@ test('T9838', normal, multimod_compile, ['T9838.hs','-v0']) test('T9574', normal, compile_fail, ['']) test('T9833', normal, compile, ['']) test('T7908', normal, compile, ['']) +test('PolyInstances', normal, compile, ['']) test('T10041', normal, compile, ['']) test('T10451', normal, compile_fail, ['']) test('T10516', normal, compile_fail, ['']) @@ -122,3 +123,6 @@ test('T10670a', normal, compile, ['']) test('T10134', normal, multimod_compile, ['T10134.hs','-v0']) test('T10742', normal, compile, ['']) test('T10934', normal, compile, ['']) +test('T11142', normal, compile_fail, ['']) +test('SigTvKinds', expect_broken(11203), compile, ['']) +test('SigTvKinds2', expect_broken(11203), compile_fail, ['']) diff --git a/testsuite/tests/rename/should_fail/T2993.stderr b/testsuite/tests/rename/should_fail/T2993.stderr index 44582b33dc..257e9d434b 100644 --- a/testsuite/tests/rename/should_fail/T2993.stderr +++ b/testsuite/tests/rename/should_fail/T2993.stderr @@ -1,4 +1,4 @@ -
-T2993.hs:7:13: error:
- Variable not in scope: (<**>) :: t1 -> (a -> a) -> t
- Perhaps you meant ‘<*>’ (imported from Prelude)
+ +T2993.hs:7:13: error: + Variable not in scope: (<**>) :: t -> (a -> a) -> t1 + Perhaps you meant ‘<*>’ (imported from Prelude) diff --git a/testsuite/tests/rename/should_fail/rnfail026.stderr b/testsuite/tests/rename/should_fail/rnfail026.stderr index f220f81812..bc717ec163 100644 --- a/testsuite/tests/rename/should_fail/rnfail026.stderr +++ b/testsuite/tests/rename/should_fail/rnfail026.stderr @@ -1,9 +1,14 @@ -
-rnfail026.hs:16:27: error:
- The first argument of ‘Monad’ should have kind ‘* -> *’,
- but ‘Eq a => Set a’ has kind ‘*’
- In the instance declaration for ‘Monad (forall a. Eq a => Set a)’
-
-rnfail026.hs:19:10: error:
- Illegal polymorphic or qualified type: forall a. [a]
- In the instance declaration for ‘Eq (forall a. [a])’
+ +rnfail026.hs:16:10: error: + • Illegal polymorphic or qualified type: forall a1. Eq a1 => Set a1 + • In the instance declaration for ‘Monad (forall a. Eq a => Set a)’ + +rnfail026.hs:16:27: error: + • Expected kind ‘* -> *’, but ‘Set a’ has kind ‘*’ + • In the first argument of ‘Monad’, namely + ‘forall a. Eq a => Set a’ + In the instance declaration for ‘Monad (forall a. Eq a => Set a)’ + +rnfail026.hs:19:10: error: + • Illegal polymorphic or qualified type: forall a1. [a1] + • In the instance declaration for ‘Eq (forall a. [a])’ diff --git a/testsuite/tests/rename/should_fail/rnfail055.stderr b/testsuite/tests/rename/should_fail/rnfail055.stderr index d87054e926..e7e6a3a817 100644 --- a/testsuite/tests/rename/should_fail/rnfail055.stderr +++ b/testsuite/tests/rename/should_fail/rnfail055.stderr @@ -73,7 +73,8 @@ RnFail055.hs-boot:25:1: error: Main module: type role T7 phantom data T7 a where T7 :: a1 -> T7 a - Boot file: data T7 a = T7 a + Boot file: data T7 a where + T7 :: a -> T7 a The roles do not match. Roles on abstract types default to ‘representational’ in boot files. The constructors do not match: The types for ‘T7’ differ diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr index 839d04d692..1759bab776 100644 --- a/testsuite/tests/roles/should_compile/Roles1.stderr +++ b/testsuite/tests/roles/should_compile/Roles1.stderr @@ -2,84 +2,42 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role T1 nominal data T1 a = K1 a - Promotable + Kind: * -> * data T2 a = K2 a - Promotable + Kind: * -> * type role T3 phantom data T3 (a :: k) = K3 + Kind: forall k1. k1 -> * type role T4 nominal nominal data T4 (a :: * -> *) b = K4 (a b) + Kind: (* -> *) -> * -> * data T5 a = K5 a - Promotable + Kind: * -> * type role T6 phantom data T6 (a :: k) = K6 + Kind: forall k1. k1 -> * type role T7 phantom representational data T7 (a :: k) b = K7 b + Kind: forall k1. k1 -> * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== -Roles1.$tcT7 - = TyCon - 12795488517584970699## - 6852268802866176810## - Roles1.$trModule - (TrNameS "T7"#) -Roles1.$tcT6 - = TyCon - 1052116432298682626## - 4782516991847719023## - Roles1.$trModule - (TrNameS "T6"#) -Roles1.$tcT5 - = TyCon - 10855726709479635304## - 5574528370049939204## - Roles1.$trModule - (TrNameS "T5"#) -Roles1.$tc'K5 - = TyCon - 17986294396600628264## - 15784122741796850983## - Roles1.$trModule - (TrNameS "'K5"#) -Roles1.$tcT4 - = TyCon - 5809060867006837344## - 8795972313583150301## - Roles1.$trModule - (TrNameS "T4"#) -Roles1.$tcT3 - = TyCon - 17827258502042208248## - 10404219359416482652## - Roles1.$trModule - (TrNameS "T3"#) -Roles1.$tcT2 - = TyCon - 14324923875690440398## - 17626224477681351106## - Roles1.$trModule - (TrNameS "T2"#) -Roles1.$tc'K2 - = TyCon - 17795591238510508397## - 10155757471958311507## - Roles1.$trModule - (TrNameS "'K2"#) -Roles1.$tcT1 - = TyCon - 12633763300352597178## - 11103726621424210926## - Roles1.$trModule - (TrNameS "T1"#) -Roles1.$tc'K1 - = TyCon - 1949157551035372857## - 3576433963139282451## - Roles1.$trModule - (TrNameS "'K1"#) +Roles1.$tcT7 = TyCon 0## 0## Roles1.$trModule (TrNameS "T7"#) +Roles1.$tc'K7 = TyCon 0## 0## Roles1.$trModule (TrNameS "'K7"#) +Roles1.$tcT6 = TyCon 0## 0## Roles1.$trModule (TrNameS "T6"#) +Roles1.$tc'K6 = TyCon 0## 0## Roles1.$trModule (TrNameS "'K6"#) +Roles1.$tcT5 = TyCon 0## 0## Roles1.$trModule (TrNameS "T5"#) +Roles1.$tc'K5 = TyCon 0## 0## Roles1.$trModule (TrNameS "'K5"#) +Roles1.$tcT4 = TyCon 0## 0## Roles1.$trModule (TrNameS "T4"#) +Roles1.$tc'K4 = TyCon 0## 0## Roles1.$trModule (TrNameS "'K4"#) +Roles1.$tcT3 = TyCon 0## 0## Roles1.$trModule (TrNameS "T3"#) +Roles1.$tc'K3 = TyCon 0## 0## Roles1.$trModule (TrNameS "'K3"#) +Roles1.$tcT2 = TyCon 0## 0## Roles1.$trModule (TrNameS "T2"#) +Roles1.$tc'K2 = TyCon 0## 0## Roles1.$trModule (TrNameS "'K2"#) +Roles1.$tcT1 = TyCon 0## 0## Roles1.$trModule (TrNameS "T1"#) +Roles1.$tc'K1 = TyCon 0## 0## Roles1.$trModule (TrNameS "'K1"#) Roles1.$trModule = Module (TrNameS "main"#) (TrNameS "Roles1"#) diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index 4b7b2cb18d..0af9862d2d 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 42, types: 18, coercions: 5} +Result size of Tidy Core = {terms: 51, types: 20, coercions: 5} -- RHS size: {terms: 2, types: 0, coercions: 0} a :: TrName @@ -20,43 +20,53 @@ Roles13.$trModule = Module a a1 -- RHS size: {terms: 2, types: 0, coercions: 0} a2 :: TrName [GblId, Caf=NoCafRefs, Str=DmdType] -a2 = TrNameS "Age"# +a2 = TrNameS "'MkAge"# -- RHS size: {terms: 5, types: 0, coercions: 0} -Roles13.$tcAge :: TyCon +Roles13.$tc'MkAge :: TyCon [GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] -Roles13.$tcAge = TyCon 0## 0## Roles13.$trModule a2 +Roles13.$tc'MkAge = TyCon 0## 0## Roles13.$trModule a2 -- RHS size: {terms: 2, types: 0, coercions: 0} a3 :: TrName [GblId, Caf=NoCafRefs, Str=DmdType] -a3 = TrNameS "'MkWrap"# +a3 = TrNameS "Age"# -- RHS size: {terms: 5, types: 0, coercions: 0} -Roles13.$tc'MkWrap :: TyCon +Roles13.$tcAge :: TyCon [GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] -Roles13.$tc'MkWrap = TyCon 0## 0## Roles13.$trModule a3 +Roles13.$tcAge = TyCon 0## 0## Roles13.$trModule a3 -- RHS size: {terms: 2, types: 0, coercions: 0} a4 :: TrName [GblId, Caf=NoCafRefs, Str=DmdType] -a4 = TrNameS "Wrap"# +a4 = TrNameS "'MkWrap"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +Roles13.$tc'MkWrap :: TyCon +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +Roles13.$tc'MkWrap = TyCon 0## 0## Roles13.$trModule a4 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a5 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a5 = TrNameS "Wrap"# -- RHS size: {terms: 5, types: 0, coercions: 0} Roles13.$tcWrap :: TyCon [GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] -Roles13.$tcWrap = TyCon 0## 0## Roles13.$trModule a4 +Roles13.$tcWrap = TyCon 0## 0## Roles13.$trModule a5 -- RHS size: {terms: 2, types: 2, coercions: 0} -a5 :: Wrap Age -> Wrap Age +a6 :: Wrap Age -> Wrap Age [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] -a5 = \ (ds :: Wrap Age) -> ds +a6 = \ (ds :: Wrap Age) -> ds -- RHS size: {terms: 1, types: 0, coercions: 5} convert :: Wrap Age -> Int [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] convert = - a5 + a6 `cast` (<Wrap Age>_R -> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0] :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int)) diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr index 08e3b8c504..52333753da 100644 --- a/testsuite/tests/roles/should_compile/Roles14.stderr +++ b/testsuite/tests/roles/should_compile/Roles14.stderr @@ -11,11 +11,8 @@ Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== -Roles12.$tcC2 - = TyCon - 4006088231579841122## - 4783761708993822739## - Roles12.$trModule - (TrNameS "C2"#) +Roles12.$tcC2 = TyCon 0## 0## Roles12.$trModule (TrNameS "C2"#) +Roles12.$tc'D:C2 + = TyCon 0## 0## Roles12.$trModule (TrNameS "'D:C2"#) Roles12.$trModule = Module (TrNameS "main"#) (TrNameS "Roles12"#) diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr index d885534a8d..0b8a8e0336 100644 --- a/testsuite/tests/roles/should_compile/Roles2.stderr +++ b/testsuite/tests/roles/should_compile/Roles2.stderr @@ -1,25 +1,19 @@ TYPE SIGNATURES TYPE CONSTRUCTORS data T1 a = K1 (IO a) + Kind: * -> * type role T2 phantom data T2 a = K2 (FunPtr a) + Kind: * -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== -Roles2.$tcT2 - = TyCon - 5934726586329293381## - 1923031187495159753## - Roles2.$trModule - (TrNameS "T2"#) -Roles2.$tcT1 - = TyCon - 13879106829711353992## - 15151456821588362072## - Roles2.$trModule - (TrNameS "T1"#) +Roles2.$tcT2 = TyCon 0## 0## Roles2.$trModule (TrNameS "T2"#) +Roles2.$tc'K2 = TyCon 0## 0## Roles2.$trModule (TrNameS "'K2"#) +Roles2.$tcT1 = TyCon 0## 0## Roles2.$trModule (TrNameS "T1"#) +Roles2.$tc'K1 = TyCon 0## 0## Roles2.$trModule (TrNameS "'K1"#) Roles2.$trModule = Module (TrNameS "main"#) (TrNameS "Roles2"#) diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index f09760224a..e2f304dc56 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -7,13 +7,15 @@ TYPE CONSTRUCTORS meth2 :: a ~ b => a -> b {-# MINIMAL meth2 #-} class C3 a b where - type family F3 b :: * open + type family F3 b open + Kind: * -> * meth3 :: a -> F3 b -> F3 b {-# MINIMAL meth3 #-} class C4 a b where meth4 :: a -> F4 b -> F4 b {-# MINIMAL meth4 #-} - type family F4 a :: * open + type family F4 a open + Kind: * -> * type Syn1 a = F4 a type Syn2 a = [a] COERCION AXIOMS @@ -29,29 +31,13 @@ Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== -Roles3.$tcC4 - = TyCon - 12861862461396457184## - 6389612623460961504## - Roles3.$trModule - (TrNameS "C4"#) -Roles3.$tcC3 - = TyCon - 5998139369941479154## - 6816352641934636458## - Roles3.$trModule - (TrNameS "C3"#) -Roles3.$tcC2 - = TyCon - 8833962732139387711## - 7891126688522429937## - Roles3.$trModule - (TrNameS "C2"#) -Roles3.$tcC1 - = TyCon - 16242970448469140073## - 10229725431456576413## - Roles3.$trModule - (TrNameS "C1"#) +Roles3.$tcC4 = TyCon 0## 0## Roles3.$trModule (TrNameS "C4"#) +Roles3.$tc'D:C4 = TyCon 0## 0## Roles3.$trModule (TrNameS "'D:C4"#) +Roles3.$tcC3 = TyCon 0## 0## Roles3.$trModule (TrNameS "C3"#) +Roles3.$tc'D:C3 = TyCon 0## 0## Roles3.$trModule (TrNameS "'D:C3"#) +Roles3.$tcC2 = TyCon 0## 0## Roles3.$trModule (TrNameS "C2"#) +Roles3.$tc'D:C2 = TyCon 0## 0## Roles3.$trModule (TrNameS "'D:C2"#) +Roles3.$tcC1 = TyCon 0## 0## Roles3.$trModule (TrNameS "C1"#) +Roles3.$tc'D:C1 = TyCon 0## 0## Roles3.$trModule (TrNameS "'D:C1"#) Roles3.$trModule = Module (TrNameS "main"#) (TrNameS "Roles3"#) diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr index 67b75cde86..fb6e88a597 100644 --- a/testsuite/tests/roles/should_compile/Roles4.stderr +++ b/testsuite/tests/roles/should_compile/Roles4.stderr @@ -16,17 +16,9 @@ Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== -Roles4.$tcC3 - = TyCon - 16502190608089501863## - 13971441568961069854## - Roles4.$trModule - (TrNameS "C3"#) -Roles4.$tcC1 - = TyCon - 11951908835899020229## - 6518430686554778113## - Roles4.$trModule - (TrNameS "C1"#) +Roles4.$tcC3 = TyCon 0## 0## Roles4.$trModule (TrNameS "C3"#) +Roles4.$tc'D:C3 = TyCon 0## 0## Roles4.$trModule (TrNameS "'D:C3"#) +Roles4.$tcC1 = TyCon 0## 0## Roles4.$trModule (TrNameS "C1"#) +Roles4.$tc'D:C1 = TyCon 0## 0## Roles4.$trModule (TrNameS "'D:C1"#) Roles4.$trModule = Module (TrNameS "main"#) (TrNameS "Roles4"#) diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index efb7488564..9ffe72ad16 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -5,7 +5,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role Map nominal representational newtype (Nominal k, Representational v) => Map k v = MkMap [(k, v)] - Promotable + Kind: * -> * -> * class Nominal a type role Representational representational class Representational a @@ -25,8 +25,12 @@ T8958.$tcMap = TyCon 0## 0## T8958.$trModule (TrNameS "Map"#) T8958.$tc'MkMap = TyCon 0## 0## T8958.$trModule (TrNameS "'MkMap"#) T8958.$tcRepresentational = TyCon 0## 0## T8958.$trModule (TrNameS "Representational"#) +T8958.$tc'D:Representational + = TyCon 0## 0## T8958.$trModule (TrNameS "'D:Representational"#) T8958.$tcNominal = TyCon 0## 0## T8958.$trModule (TrNameS "Nominal"#) +T8958.$tc'D:Nominal + = TyCon 0## 0## T8958.$trModule (TrNameS "'D:Nominal"#) T8958.$trModule = Module (TrNameS "main"#) (TrNameS "T8958"#) AbsBinds [a] [] {Exports: [T8958.$fRepresentationala <= $dRepresentational diff --git a/testsuite/tests/roles/should_compile/all.T b/testsuite/tests/roles/should_compile/all.T index b740d8ad3e..25a4a37272 100644 --- a/testsuite/tests/roles/should_compile/all.T +++ b/testsuite/tests/roles/should_compile/all.T @@ -1,9 +1,9 @@ -test('Roles1', only_ways('normal'), compile, ['-ddump-tc -fprint-explicit-foralls']) -test('Roles2', only_ways('normal'), compile, ['-ddump-tc -fprint-explicit-foralls']) -test('Roles3', only_ways('normal'), compile, ['-ddump-tc']) -test('Roles4', only_ways('normal'), compile, ['-ddump-tc']) +test('Roles1', only_ways('normal'), compile, ['-ddump-tc -fprint-explicit-foralls -dsuppress-uniques']) +test('Roles2', only_ways('normal'), compile, ['-ddump-tc -fprint-explicit-foralls -dsuppress-uniques']) +test('Roles3', only_ways('normal'), compile, ['-ddump-tc -dsuppress-uniques']) +test('Roles4', only_ways('normal'), compile, ['-ddump-tc -dsuppress-uniques']) test('Roles13', only_ways('normal'), compile, ['-ddump-simpl -dsuppress-uniques']) -test('Roles14', only_ways('normal'), compile, ['-ddump-tc']) +test('Roles14', only_ways('normal'), compile, ['-ddump-tc -dsuppress-uniques']) test('T8958', [normalise_fun(normalise_errmsg), only_ways('normal')], compile, ['-ddump-tc -dsuppress-uniques']) test('T10263', normal, compile, ['']) test('T9204b', extra_clean(['T9204b.o-boot', 'T9204b.hi-boot', 'T9204b2.hi', 'T9204b2.o']), multimod_compile, ['T9204b', '-v0']) diff --git a/testsuite/tests/rts/T9045.hs b/testsuite/tests/rts/T9045.hs index 1e581efa35..f01bf84e38 100644 --- a/testsuite/tests/rts/T9045.hs +++ b/testsuite/tests/rts/T9045.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ImpredicativeTypes #-} -- This is nofib/smp/threads006. It fails in GHC 7.8.2 with a GC crash. {-# OPTIONS_GHC -O2 #-} diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index eb6d74291c..a804768fa3 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -14,7 +14,7 @@ T11155: T8274: $(RM) -f T8274.o T8274.hi - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T8274.hs | grep '#' + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques T8274.hs | grep '#' T7865: $(RM) -f T7865.o T7865.hi diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 1cd13301f9..cc8c5a9056 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 55, types: 34, coercions: 0} +Result size of Tidy Core = {terms: 82, types: 42, coercions: 0} -- RHS size: {terms: 6, types: 3, coercions: 0} T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo @@ -45,6 +45,60 @@ T7360.$trModule :: Module T7360.$trModule = Module T7360.$trModule2 T7360.$trModule1 -- RHS size: {terms: 2, types: 0, coercions: 0} +T7360.$tc'Foo6 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T7360.$tc'Foo6 = TrNameS "'Foo3"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +T7360.$tc'Foo3 :: TyCon +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] +T7360.$tc'Foo3 = TyCon 0## 0## T7360.$trModule T7360.$tc'Foo6 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T7360.$tc'Foo5 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T7360.$tc'Foo5 = TrNameS "'Foo2"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +T7360.$tc'Foo2 :: TyCon +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] +T7360.$tc'Foo2 = TyCon 0## 0## T7360.$trModule T7360.$tc'Foo5 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T7360.$tc'Foo4 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T7360.$tc'Foo4 = TrNameS "'Foo1"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +T7360.$tc'Foo1 :: TyCon +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] +T7360.$tc'Foo1 = TyCon 0## 0## T7360.$trModule T7360.$tc'Foo4 + +-- RHS size: {terms: 2, types: 0, coercions: 0} T7360.$tcFoo1 :: TrName [GblId, Caf=NoCafRefs, @@ -84,7 +138,7 @@ T7360.fun4 :: Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.fun4 = I# 0# --- RHS size: {terms: 16, types: 12, coercions: 0} +-- RHS size: {terms: 16, types: 13, coercions: 0} fun2 :: forall a. [a] -> ((), Int) [GblId, Arity=1, diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout index 6c0e36f8f9..8d4236b282 100644 --- a/testsuite/tests/simplCore/should_compile/T8274.stdout +++ b/testsuite/tests/simplCore/should_compile/T8274.stdout @@ -1,10 +1,12 @@ T8274.$trModule2 = TrNameS "main"# T8274.$trModule1 = TrNameS "T8274"# +T8274.$tc'Positives1 = TrNameS "'Positives"# + TyCon 0## 0## T8274.$trModule T8274.$tc'Positives1 T8274.$tcP1 = TrNameS "P"# - 11095028091707994303## - 9476557054198009608## +T8274.$tcP = TyCon 0## 0## T8274.$trModule T8274.$tcP1 +T8274.$tc'Negatives1 = TrNameS "'Negatives"# + TyCon 0## 0## T8274.$trModule T8274.$tc'Negatives1 T8274.$tcN1 = TrNameS "N"# - 7479687563082171902## - 17616649989360543185## +T8274.$tcN = TyCon 0## 0## T8274.$trModule T8274.$tcN1 p = T8274.Positives 42# 4.23# 4.23## '4'# 4## n = T8274.Negatives -4# -4.0# -4.0## diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index 3bc95e42cc..cdf770b3f9 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 33, types: 19, coercions: 0} +Result size of Tidy Core = {terms: 33, types: 20, coercions: 0} -- RHS size: {terms: 2, types: 0, coercions: 0} a :: TrName @@ -17,7 +17,7 @@ T9400.$trModule :: Module [GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] T9400.$trModule = Module a a1 --- RHS size: {terms: 22, types: 14, coercions: 0} +-- RHS size: {terms: 22, types: 15, coercions: 0} main :: IO () [GblId, Str=DmdType] main = @@ -45,7 +45,7 @@ main = @ () @ () (putStrLn (unpackCString# "efg"#)) - (patError @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) + (patError @ 'Lifted @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#)))) diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr index f18696489c..844afc63d6 100644 --- a/testsuite/tests/simplCore/should_compile/rule2.stderr +++ b/testsuite/tests/simplCore/should_compile/rule2.stderr @@ -21,12 +21,12 @@ Total ticks: 13 1 EtaReduction 1 ds 7 BetaReduction 1 f - 1 m 1 a - 1 b 1 m + 1 b 1 m 1 b + 1 m 9 SimplifierDone 9 diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 17d3dbbdc5..09ae2f3ecb 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 172, types: 64, coercions: 0} +Result size of Tidy Core = {terms: 172, types: 65, coercions: 0} -- RHS size: {terms: 2, types: 0, coercions: 0} Roman.$trModule2 :: TrName @@ -29,11 +29,12 @@ Roman.$trModule :: Module WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] Roman.$trModule = Module Roman.$trModule2 Roman.$trModule1 --- RHS size: {terms: 2, types: 1, coercions: 0} +-- RHS size: {terms: 2, types: 2, coercions: 0} Roman.foo3 :: Int [GblId, Str=DmdType b] Roman.foo3 = - patError @ Int "spec-inline.hs:(19,5)-(29,25)|function go"# + patError + @ 'Lifted @ Int "spec-inline.hs:(19,5)-(29,25)|function go"# Rec { -- RHS size: {terms: 55, types: 9, coercions: 0} diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr index aa7a2ef8b6..d06e4ca86a 100644 --- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr +++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr @@ -1,5 +1,7 @@ ==================== Strictness signatures ==================== +DmdAnalGADTs.$tc'A: m +DmdAnalGADTs.$tc'B: m DmdAnalGADTs.$tcD: m DmdAnalGADTs.$trModule: m DmdAnalGADTs.diverges: b diff --git a/testsuite/tests/stranal/sigs/T8569.stderr b/testsuite/tests/stranal/sigs/T8569.stderr index 3013d769fb..84636c1916 100644 --- a/testsuite/tests/stranal/sigs/T8569.stderr +++ b/testsuite/tests/stranal/sigs/T8569.stderr @@ -1,5 +1,7 @@ ==================== Strictness signatures ==================== +T8569.$tc'Rdata: m +T8569.$tc'Rint: m T8569.$tcRep: m T8569.$trModule: m T8569.addUp: <S,1*U><L,U> diff --git a/testsuite/tests/th/T3177a.stderr b/testsuite/tests/th/T3177a.stderr index 33093fa2b1..fa80d0e864 100644 --- a/testsuite/tests/th/T3177a.stderr +++ b/testsuite/tests/th/T3177a.stderr @@ -1,10 +1,12 @@ -
-T3177a.hs:8:8: error:
- ‘Int’ is applied to too many type arguments
- In the type signature:
- f :: Int Int
-
-T3177a.hs:11:6: error:
- ‘Int’ is applied to too many type arguments
- In the type signature:
- g :: Int Int
+ +T3177a.hs:8:8: error: + • Expecting one fewer argument to ‘Int’ + Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ + • In the type signature: + f :: Int Int + +T3177a.hs:11:6: error: + • Expecting one fewer argument to ‘Int’ + Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ + • In the type signature: + g :: Int Int diff --git a/testsuite/tests/th/T3920.hs b/testsuite/tests/th/T3920.hs index 4d7ccef509..309ca8eeb2 100644 --- a/testsuite/tests/th/T3920.hs +++ b/testsuite/tests/th/T3920.hs @@ -9,7 +9,7 @@ $(return []) test :: String test = $(do - test <- [d| + test <- [d| type family T :: (* -> (* -> * -> *)) -> (* -> *) -> * |] blah <- reify ''S return (LitE (StringL (pprint test ++ "\n" ++ pprint blah)))) diff --git a/testsuite/tests/th/T7021a.hs b/testsuite/tests/th/T7021a.hs index b07ef55196..f2bc8f1891 100644 --- a/testsuite/tests/th/T7021a.hs +++ b/testsuite/tests/th/T7021a.hs @@ -3,7 +3,7 @@ module T7021a where -import GHC.Prim +import GHC.Exts import Language.Haskell.TH type IOable a = (Show a, Read a) diff --git a/testsuite/tests/th/T8953.stderr b/testsuite/tests/th/T8953.stderr index 94312eff6a..c18589d69c 100644 --- a/testsuite/tests/th/T8953.stderr +++ b/testsuite/tests/th/T8953.stderr @@ -15,5 +15,5 @@ type instance T8953.F GHC.Types.Char = (T8953.G (T8953.T1 :: * -> (* -> *) -> *) GHC.Types.Bool :: (* -> *) -> *) type family T8953.G (a_0 :: k_1) :: k_1 -type instance T8953.G (T8953.T1 :: k_2 -> - k1_3 -> *) = (T8953.T2 :: k_2 -> k1_3 -> *) +type instance T8953.G (T8953.T1 :: k1_2 -> + k2_3 -> *) = (T8953.T2 :: k1_2 -> k2_3 -> *) diff --git a/testsuite/tests/th/TH_RichKinds.hs b/testsuite/tests/th/TH_RichKinds.hs index 69e4239f43..3ec2dd8e8e 100644 --- a/testsuite/tests/th/TH_RichKinds.hs +++ b/testsuite/tests/th/TH_RichKinds.hs @@ -6,7 +6,7 @@ module TH_RichKinds where -import GHC.Prim +import GHC.Exts import Language.Haskell.TH $(do tys <- sequence [ [t| forall a. (a :: Bool) |] diff --git a/testsuite/tests/th/TH_RichKinds.stderr b/testsuite/tests/th/TH_RichKinds.stderr index 09a8e40bf8..eb402902ac 100644 --- a/testsuite/tests/th/TH_RichKinds.stderr +++ b/testsuite/tests/th/TH_RichKinds.stderr @@ -1,9 +1,9 @@ -TH_RichKinds.hs:12:3: Warning: +TH_RichKinds.hs:12:3: warning: forall a_0 . (a_0 :: GHC.Types.Bool) forall a_1 . (a_1 :: Constraint) forall a_2 . (a_2 :: [*]) forall a_3 . (a_3 :: (*, GHC.Types.Bool)) -forall a_4 . (a_4 :: GHC.Tuple.()) +forall a_4 . (a_4 :: ()) forall a_5 . (a_5 :: (* -> GHC.Types.Bool) -> (*, * -> *) -> GHC.Types.Bool) diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr index 7b68958fcc..fc264b12dd 100644 --- a/testsuite/tests/th/TH_Roles2.stderr +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -2,6 +2,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS type role T representational data T (a :: k) + Kind: forall k1. k1 -> * COERCION AXIOMS Dependent modules: [] Dependent packages: [array-0.5.1.0, base-4.9.0.0, deepseq-1.4.1.1, diff --git a/testsuite/tests/typecheck/should_compile/T5581.hs b/testsuite/tests/typecheck/should_compile/T5581.hs index 074a2babcd..f7762831b3 100644 --- a/testsuite/tests/typecheck/should_compile/T5581.hs +++ b/testsuite/tests/typecheck/should_compile/T5581.hs @@ -3,7 +3,7 @@ module TcShouldTerminate where -import GHC.Prim (Constraint) +import Data.Kind (Constraint) class C (p :: Constraint) class D (p :: Constraint) diff --git a/testsuite/tests/typecheck/should_compile/T5655.hs b/testsuite/tests/typecheck/should_compile/T5655.hs index c2eed90abc..8db7a485a3 100644 --- a/testsuite/tests/typecheck/should_compile/T5655.hs +++ b/testsuite/tests/typecheck/should_compile/T5655.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, GADTs, ConstraintKinds, RankNTypes #-} module T5655 where -import GHC.Prim (Constraint) +import Data.Kind (Constraint) class Show a => Twice a where twice :: a -> a diff --git a/testsuite/tests/typecheck/should_compile/T9834.stderr b/testsuite/tests/typecheck/should_compile/T9834.stderr index 3ce53a0c51..b3a6240a6b 100644 --- a/testsuite/tests/typecheck/should_compile/T9834.stderr +++ b/testsuite/tests/typecheck/should_compile/T9834.stderr @@ -1,71 +1,71 @@ -
-T9834.hs:23:10: warning:
- Couldn't match type ‘p’ with ‘(->) (p a0)’
- ‘p’ is a rigid type variable bound by
- the class declaration for ‘ApplicativeFix’ at T9834.hs:21:39
- Expected type: (forall (q :: * -> *).
- Applicative q =>
- Comp p q a -> Comp p q a)
- -> p a
- Actual type: (forall (q :: * -> *).
- Applicative q =>
- Nat (Comp p q) (Comp p q))
- -> p a0 -> p a0
- In the expression: wrapIdComp
- In an equation for ‘afix’: afix = wrapIdComp
- Relevant bindings include
- afix :: (forall (q :: * -> *).
- Applicative q =>
- Comp p q a -> Comp p q a)
- -> p a
- (bound at T9834.hs:23:3)
-
-T9834.hs:23:10: warning:
- Couldn't match type ‘a’ with ‘p a0’
- ‘a’ is a rigid type variable bound by
- the type signature for:
- afix :: forall a.
- (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a)
- -> p a
- at T9834.hs:22:11
- Expected type: (forall (q :: * -> *).
- Applicative q =>
- Comp p q a -> Comp p q a)
- -> p a
- Actual type: (forall (q :: * -> *).
- Applicative q =>
- Nat (Comp p q) (Comp p q))
- -> p a0 -> p a0
- In the expression: wrapIdComp
- In an equation for ‘afix’: afix = wrapIdComp
- Relevant bindings include
- afix :: (forall (q :: * -> *).
- Applicative q =>
- Comp p q a -> Comp p q a)
- -> p a
- (bound at T9834.hs:23:3)
-
-T9834.hs:23:10: warning:
- Couldn't match type ‘a’ with ‘a1’
- ‘a’ is a rigid type variable bound by
- the type signature for:
- afix :: forall a.
- (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a)
- -> p a
- at T9834.hs:22:11
- ‘a1’ is a rigid type variable bound by
- a type expected by the context:
- forall (q :: * -> *) a1.
- Applicative q =>
- Comp p q a1 -> Comp p q a1
- at T9834.hs:23:10
- Expected type: Comp p q a1 -> Comp p q a1
- Actual type: Comp p q a -> Comp p q a
- In the expression: wrapIdComp
- In an equation for ‘afix’: afix = wrapIdComp
- Relevant bindings include
- afix :: (forall (q :: * -> *).
- Applicative q =>
- Comp p q a -> Comp p q a)
- -> p a
- (bound at T9834.hs:23:3)
+ +T9834.hs:23:10: warning: + • Couldn't match type ‘a’ with ‘p a0’ + ‘a’ is a rigid type variable bound by + the type signature for: + afix :: forall a. + (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a) + -> p a + at T9834.hs:22:11 + Expected type: (forall (q :: * -> *). + Applicative q => + Comp p q a -> Comp p q a) + -> p a + Actual type: (forall (q :: * -> *). + Applicative q => + Nat (Comp p q) (Comp p q)) + -> p a0 -> p a0 + • In the expression: wrapIdComp + In an equation for ‘afix’: afix = wrapIdComp + • Relevant bindings include + afix :: (forall (q :: * -> *). + Applicative q => + Comp p q a -> Comp p q a) + -> p a + (bound at T9834.hs:23:3) + +T9834.hs:23:10: warning: + • Couldn't match type ‘p’ with ‘(->) (p a0)’ + ‘p’ is a rigid type variable bound by + the class declaration for ‘ApplicativeFix’ at T9834.hs:21:39 + Expected type: (forall (q :: * -> *). + Applicative q => + Comp p q a -> Comp p q a) + -> p a + Actual type: (forall (q :: * -> *). + Applicative q => + Nat (Comp p q) (Comp p q)) + -> p a0 -> p a0 + • In the expression: wrapIdComp + In an equation for ‘afix’: afix = wrapIdComp + • Relevant bindings include + afix :: (forall (q :: * -> *). + Applicative q => + Comp p q a -> Comp p q a) + -> p a + (bound at T9834.hs:23:3) + +T9834.hs:23:10: warning: + • Couldn't match type ‘a’ with ‘a1’ + ‘a’ is a rigid type variable bound by + the type signature for: + afix :: forall a. + (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a) + -> p a + at T9834.hs:22:11 + ‘a1’ is a rigid type variable bound by + a type expected by the context: + forall (q :: * -> *) a1. + Applicative q => + Comp p q a1 -> Comp p q a1 + at T9834.hs:23:10 + Expected type: Comp p q a1 -> Comp p q a1 + Actual type: Comp p q a -> Comp p q a + • In the expression: wrapIdComp + In an equation for ‘afix’: afix = wrapIdComp + • Relevant bindings include + afix :: (forall (q :: * -> *). + Applicative q => + Comp p q a -> Comp p q a) + -> p a + (bound at T9834.hs:23:3) diff --git a/testsuite/tests/typecheck/should_compile/T9939.stderr b/testsuite/tests/typecheck/should_compile/T9939.stderr index 86decf0a5e..106335e8ba 100644 --- a/testsuite/tests/typecheck/should_compile/T9939.stderr +++ b/testsuite/tests/typecheck/should_compile/T9939.stderr @@ -1,20 +1,20 @@ -
-T9939.hs:5:1: warning:
- Redundant constraint: Eq a
- In the type signature for:
- f1 :: (Eq a, Ord a) => a -> a -> Bool
-
-T9939.hs:9:1: warning:
- Redundant constraint: Eq a
- In the type signature for:
- f2 :: (Eq a, Ord a) => a -> a -> Bool
-
-T9939.hs:13:1: warning:
- Redundant constraint: Eq b
- In the type signature for:
- f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool
-
-T9939.hs:20:1: warning:
- Redundant constraint: Eq b
- In the type signature for:
- f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool
+ +T9939.hs:5:1: warning: + • Redundant constraint: Eq a + • In the type signature for: + f1 :: (Eq a, Ord a) => a -> a -> Bool + +T9939.hs:9:1: warning: + • Redundant constraint: Eq a + • In the type signature for: + f2 :: (Eq a, Ord a) => a -> a -> Bool + +T9939.hs:13:1: warning: + • Redundant constraint: Eq b + • In the type signature for: + f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool + +T9939.hs:20:1: warning: + • Redundant constraint: Eq a + • In the type signature for: + f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool diff --git a/testsuite/tests/typecheck/should_compile/tc141.stderr b/testsuite/tests/typecheck/should_compile/tc141.stderr index b5ee77b689..96858b1d3c 100644 --- a/testsuite/tests/typecheck/should_compile/tc141.stderr +++ b/testsuite/tests/typecheck/should_compile/tc141.stderr @@ -7,11 +7,11 @@ tc141.hs:11:12: error: In a pattern binding: (p :: a, q :: a) = x tc141.hs:11:31: error: - • Couldn't match expected type ‘a1’ with actual type ‘a’ - because type variable ‘a1’ would escape its scope + • Couldn't match expected type ‘a2’ with actual type ‘a’ + because type variable ‘a2’ would escape its scope This (rigid, skolem) type variable is bound by an expression type signature: - a1 + a2 at tc141.hs:11:31-34 • In the expression: q :: a In the expression: (q :: a, p) @@ -19,7 +19,7 @@ tc141.hs:11:31: error: p :: a (bound at tc141.hs:11:12) q :: a (bound at tc141.hs:11:17) x :: (a, a) (bound at tc141.hs:11:3) - f :: (a, a) -> (t, a) (bound at tc141.hs:11:1) + f :: (a, a) -> (a1, a) (bound at tc141.hs:11:1) tc141.hs:13:13: error: • You cannot bind scoped type variable ‘a’ @@ -34,15 +34,15 @@ tc141.hs:13:13: error: in v tc141.hs:15:18: error: - • Couldn't match expected type ‘a2’ with actual type ‘t’ - because type variable ‘a2’ would escape its scope + • Couldn't match expected type ‘a1’ with actual type ‘r1’ + because type variable ‘a1’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: - v :: a2 + v :: a1 at tc141.hs:14:14-19 • In the expression: b In an equation for ‘v’: v = b • Relevant bindings include - v :: a2 (bound at tc141.hs:15:14) - b :: t (bound at tc141.hs:13:5) - g :: a -> t -> a1 (bound at tc141.hs:13:1) + v :: a1 (bound at tc141.hs:15:14) + b :: r1 (bound at tc141.hs:13:5) + g :: r -> r1 -> a (bound at tc141.hs:13:1) diff --git a/testsuite/tests/typecheck/should_compile/tc167.stderr b/testsuite/tests/typecheck/should_compile/tc167.stderr index 5d869af801..634b50dd5b 100644 --- a/testsuite/tests/typecheck/should_compile/tc167.stderr +++ b/testsuite/tests/typecheck/should_compile/tc167.stderr @@ -1,5 +1,6 @@ -
-tc167.hs:8:15:
- Expecting a lifted type, but ‘Int#’ is unlifted
- In the type ‘(->) Int#’
- In the type declaration for ‘T’
+ +tc167.hs:8:15: + Expecting a lifted type, but ‘Int#’ is unlifted + In the first argument of ‘(->)’, namely ‘Int#’ + In the type ‘(->) Int#’ + In the type declaration for ‘T’ diff --git a/testsuite/tests/typecheck/should_compile/tc211.stderr b/testsuite/tests/typecheck/should_compile/tc211.stderr index 34a35f1781..d802dffe4e 100644 --- a/testsuite/tests/typecheck/should_compile/tc211.stderr +++ b/testsuite/tests/typecheck/should_compile/tc211.stderr @@ -1,5 +1,5 @@ -tc211.hs:17:8: +tc211.hs:17:8: error: Couldn't match expected type ‘forall a. a -> a’ with actual type ‘a2 -> a2’ In the expression: @@ -10,17 +10,17 @@ tc211.hs:17:8: (forall a. a -> a) -> [forall a. a -> a] -> [forall a. a -> a]) (head foo) foo -tc211.hs:18:22: +tc211.hs:18:22: error: Couldn't match type ‘forall a3. a3 -> a3’ with ‘a -> a’ - Expected type: [a -> a] - Actual type: [forall a. a -> a] + Expected type: [a -> a] + Actual type: [forall a. a -> a] In the first argument of ‘head’, namely ‘foo’ In the first argument of ‘(:) :: (forall a. a -> a) -> [forall a. a -> a] -> [forall a. a -> a]’, namely ‘(head foo)’ -tc211.hs:59:18: +tc211.hs:59:18: error: Couldn't match expected type ‘forall a. a -> a’ with actual type ‘a1 -> a1’ In the expression: @@ -33,7 +33,7 @@ tc211.hs:59:18: (forall a. a -> a) -> List (forall a. a -> a) -> List (forall a. a -> a) -tc211.hs:65:8: +tc211.hs:65:8: error: Couldn't match expected type ‘forall a. a -> a’ with actual type ‘a0 -> a0’ In the expression: @@ -46,11 +46,11 @@ tc211.hs:65:8: -> List (forall a. a -> a) -> List (forall a. a -> a)) (\ x -> x) Nil -tc211.hs:73:9: +tc211.hs:73:9: error: Couldn't match type ‘forall a4. a4 -> a4’ with ‘a3 -> a3’ - Expected type: List (forall a. a -> a) - -> (forall a. a -> a) -> a3 -> a3 - Actual type: List (a3 -> a3) -> (a3 -> a3) -> a3 -> a3 + Expected type: List (forall a. a -> a) + -> (forall a. a -> a) -> a3 -> a3 + Actual type: List (a3 -> a3) -> (a3 -> a3) -> a3 -> a3 In the expression: foo2 :: List (forall a. a -> a) -> (forall a. a -> a) -> (forall a. a -> a) diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr index 2377c13a0f..85ccc32954 100644 --- a/testsuite/tests/typecheck/should_compile/tc231.stderr +++ b/testsuite/tests/typecheck/should_compile/tc231.stderr @@ -6,9 +6,9 @@ TYPE SIGNATURES s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1 TYPE CONSTRUCTORS data Q s a chain = Node s a chain - Promotable + Kind: * -> * -> * -> * data Z a = Z a - Promotable + Kind: * -> * class Zork s a b | a -> b where huh :: Q s a chain -> ST s () {-# MINIMAL huh #-} diff --git a/testsuite/tests/typecheck/should_compile/tc243.stderr b/testsuite/tests/typecheck/should_compile/tc243.stderr index 31cc3c9fd2..98e0f5ae1e 100644 --- a/testsuite/tests/typecheck/should_compile/tc243.stderr +++ b/testsuite/tests/typecheck/should_compile/tc243.stderr @@ -1,3 +1,3 @@ -
-tc243.hs:10:1: Warning:
- Top-level binding with no type signature: (.+.) :: forall t. t
+ +tc243.hs:10:1: Warning: + Top-level binding with no type signature: (.+.) :: forall r. r diff --git a/testsuite/tests/typecheck/should_compile/tc255.hs b/testsuite/tests/typecheck/should_compile/tc255.hs index d77a7b688b..e5690bb08d 100644 --- a/testsuite/tests/typecheck/should_compile/tc255.hs +++ b/testsuite/tests/typecheck/should_compile/tc255.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds, UndecidableInstances #-} module Ctx where -import GHC.Prim( Constraint ) +import Data.Kind ( Constraint ) type family Indirect :: * -> Constraint type instance Indirect = Show diff --git a/testsuite/tests/typecheck/should_compile/tc256.hs b/testsuite/tests/typecheck/should_compile/tc256.hs index f06eabf1c3..d33f7a6401 100644 --- a/testsuite/tests/typecheck/should_compile/tc256.hs +++ b/testsuite/tests/typecheck/should_compile/tc256.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds, UndecidableInstances #-} module Ctx where -import GHC.Prim( Constraint ) +import Data.Kind ( Constraint ) type family Indirect :: * -> Constraint type instance Indirect = Show diff --git a/testsuite/tests/typecheck/should_compile/tc257.hs b/testsuite/tests/typecheck/should_compile/tc257.hs index efab2df224..d5742aa779 100644 --- a/testsuite/tests/typecheck/should_compile/tc257.hs +++ b/testsuite/tests/typecheck/should_compile/tc257.hs @@ -1,7 +1,7 @@ {-# LANGUAGE KindSignatures, ConstraintKinds, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} module Ctx where -import GHC.Prim( Constraint ) +import Data.Kind ( Constraint ) data Proxy (ctxt :: * -> Constraint) = Proxy @@ -22,4 +22,4 @@ instance ctxt Int => Foo ctxt Int where -- from the context (ctxt Int) -- The problem was that irreducible evidence did not interact with --- evidence of equal type.
\ No newline at end of file +-- evidence of equal type. diff --git a/testsuite/tests/typecheck/should_compile/tc258.hs b/testsuite/tests/typecheck/should_compile/tc258.hs index 353ec94c43..a4dca19526 100644 --- a/testsuite/tests/typecheck/should_compile/tc258.hs +++ b/testsuite/tests/typecheck/should_compile/tc258.hs @@ -2,7 +2,7 @@ module AltPrelude where -import GHC.Prim (Constraint) +import Data.Kind (Constraint) class MyFunctor f where type FunctorCtxt f a :: Constraint diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr index 4fbaaef199..71fc77d4ed 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr @@ -1,7 +1,7 @@ -
-AssocTyDef04.hs:6:18:
- Expecting one more argument to ‘Maybe’
- Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’
- In the type ‘Maybe’
- In the default type instance declaration for ‘Typ’
- In the class declaration for ‘Cls’
+ +AssocTyDef04.hs:6:18: + Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + In the type ‘Maybe’ + In the default type instance declaration for ‘Typ’ + In the class declaration for ‘Cls’ diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef06.hs b/testsuite/tests/typecheck/should_fail/AssocTyDef06.hs index fb595a3e27..e4f45669b7 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef06.hs +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef06.hs @@ -3,5 +3,5 @@ module AssocTyDef06 where class Cls a where type Typ a - type Typ a Int = Int - -- Too many params for default
\ No newline at end of file + type Typ a b = Int + -- Too many params for default diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr index 665ad223d2..d51ce8ff6c 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr @@ -1,6 +1,5 @@ -
-AssocTyDef06.hs:6:16:
- Unexpected type ‘Int’
- In the default declaration for ‘Typ’
- A default declaration should have form
- default Typ a b = ...
+ +AssocTyDef06.hs:6:5: + Number of parameters must match family declaration; expected 1 + In the default type instance declaration for ‘Typ’ + In the class declaration for ‘Cls’ diff --git a/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr index b545a10caa..6abb044c8e 100644 --- a/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr +++ b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr @@ -1,52 +1,47 @@ -FrozenErrorTests.hs:12:12: - Couldn't match type ‘Int’ with ‘Bool’ - Inaccessible code in - a pattern with constructor: MkT3 :: forall a. (a ~ Bool) => T a, - in a case alternative - In the pattern: MkT3 - In a case alternative: MkT3 -> () - In the expression: case x of { MkT3 -> () } +FrozenErrorTests.hs:12:12: error: + • Couldn't match type ‘Int’ with ‘Bool’ + Inaccessible code in + a pattern with constructor: MkT3 :: forall a. (a ~ Bool) => T a, + in a case alternative + • In the pattern: MkT3 + In a case alternative: MkT3 -> () + In the expression: case x of { MkT3 -> () } -FrozenErrorTests.hs:26:9: - Occurs check: cannot construct the infinite type: a ~ [a] - Expected type: [a] - Actual type: F a Bool - In the expression: goo1 False undefined - In an equation for ‘test1’: test1 = goo1 False undefined - Relevant bindings include - test1 :: a (bound at FrozenErrorTests.hs:26:1) +FrozenErrorTests.hs:26:9: error: + • Occurs check: cannot construct the infinite type: a ~ [a] + arising from a use of ‘goo1’ + • In the expression: goo1 False undefined + In an equation for ‘test1’: test1 = goo1 False undefined + • Relevant bindings include + test1 :: a (bound at FrozenErrorTests.hs:26:1) -FrozenErrorTests.hs:29:15: - Couldn't match type ‘Int’ with ‘[Int]’ - Expected type: [[Int]] - Actual type: F [Int] Bool - In the first argument of ‘goo2’, namely ‘(goo1 False undefined)’ - In the expression: goo2 (goo1 False undefined) - In an equation for ‘test2’: test2 = goo2 (goo1 False undefined) +FrozenErrorTests.hs:29:15: error: + • Couldn't match type ‘Int’ with ‘[Int]’ + arising from a use of ‘goo1’ + • In the first argument of ‘goo2’, namely ‘(goo1 False undefined)’ + In the expression: goo2 (goo1 False undefined) + In an equation for ‘test2’: test2 = goo2 (goo1 False undefined) -FrozenErrorTests.hs:30:9: - Couldn't match type ‘Int’ with ‘[Int]’ - Expected type: [[Int]] - Actual type: F [Int] Bool - In the expression: goo1 False (goo2 undefined) - In an equation for ‘test3’: test3 = goo1 False (goo2 undefined) +FrozenErrorTests.hs:30:9: error: + • Couldn't match type ‘Int’ with ‘[Int]’ + arising from a use of ‘goo1’ + • In the expression: goo1 False (goo2 undefined) + In an equation for ‘test3’: test3 = goo1 False (goo2 undefined) -FrozenErrorTests.hs:45:15: - Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’ - Expected type: T2 (M (T2 (T2 c c) c)) (T2 (T2 c c) c) - Actual type: F (T2 (T2 c c) c) Bool - In the first argument of ‘goo4’, namely ‘(goo3 False undefined)’ - In the expression: goo4 (goo3 False undefined) - In an equation for ‘test4’: test4 = goo4 (goo3 False undefined) - Relevant bindings include - test4 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:45:1) +FrozenErrorTests.hs:45:15: error: + • Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’ + arising from a use of ‘goo3’ + • In the first argument of ‘goo4’, namely ‘(goo3 False undefined)’ + In the expression: goo4 (goo3 False undefined) + In an equation for ‘test4’: test4 = goo4 (goo3 False undefined) + • Relevant bindings include + test4 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:45:1) -FrozenErrorTests.hs:46:9: - Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’ - Expected type: T2 (M (T2 (T2 c c) c)) (T2 (T2 c c) c) - Actual type: F (T2 (T2 c c) c) Bool - In the expression: goo3 False (goo4 undefined) - In an equation for ‘test5’: test5 = goo3 False (goo4 undefined) - Relevant bindings include - test5 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:46:1) +FrozenErrorTests.hs:46:9: error: + • Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’ + arising from a use of ‘goo3’ + • In the expression: goo3 False (goo4 undefined) + In an equation for ‘test5’: test5 = goo3 False (goo4 undefined) + • Relevant bindings include + test5 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:46:1) diff --git a/testsuite/tests/typecheck/should_fail/T10285.stderr b/testsuite/tests/typecheck/should_fail/T10285.stderr index b7bba0f575..ebc5f97503 100644 --- a/testsuite/tests/typecheck/should_fail/T10285.stderr +++ b/testsuite/tests/typecheck/should_fail/T10285.stderr @@ -3,7 +3,7 @@ T10285.hs:8:17: error: • Could not deduce: Coercible a b arising from a use of ‘coerce’ from the context: Coercible (N a) (N b) bound by a pattern with constructor: - Coercion :: forall (k :: BOX) (a :: k) (b :: k). + Coercion :: forall k (a :: k) (b :: k). Coercible a b => Coercion a b, in an equation for ‘oops’ diff --git a/testsuite/tests/typecheck/should_fail/T11112.stderr b/testsuite/tests/typecheck/should_fail/T11112.stderr index 3534d33b51..ec2154c8ce 100644 --- a/testsuite/tests/typecheck/should_fail/T11112.stderr +++ b/testsuite/tests/typecheck/should_fail/T11112.stderr @@ -1,5 +1,5 @@ T11112.hs:3:9: error: - • Constraint ‘Ord s’ used as a type + • Expected a type, but ‘Ord s’ has kind ‘Constraint’ • In the type signature: sort :: Ord s -> [s] -> [s] diff --git a/testsuite/tests/typecheck/should_fail/T1633.hs b/testsuite/tests/typecheck/should_fail/T1633.hs index 3fff8f2540..fb95956774 100644 --- a/testsuite/tests/typecheck/should_fail/T1633.hs +++ b/testsuite/tests/typecheck/should_fail/T1633.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} + -- This just tests what the kind error message looks like -- Trac #1633 diff --git a/testsuite/tests/typecheck/should_fail/T1633.stderr b/testsuite/tests/typecheck/should_fail/T1633.stderr index 63eced334d..300e6c3def 100644 --- a/testsuite/tests/typecheck/should_fail/T1633.stderr +++ b/testsuite/tests/typecheck/should_fail/T1633.stderr @@ -1,5 +1,5 @@ -T1633.hs:6:18: - The first argument of ‘Functor’ should have kind ‘* -> *’, - but ‘Bool’ has kind ‘*’ +T1633.hs:8:18: error: + Expected kind ‘* -> *’, but ‘Bool’ has kind ‘*’ + In the first argument of ‘Functor’, namely ‘Bool’ In the instance declaration for ‘Functor Bool’ diff --git a/testsuite/tests/typecheck/should_fail/T2994.stderr b/testsuite/tests/typecheck/should_fail/T2994.stderr index 83e96b45da..e833cd637d 100644 --- a/testsuite/tests/typecheck/should_fail/T2994.stderr +++ b/testsuite/tests/typecheck/should_fail/T2994.stderr @@ -1,16 +1,36 @@ -T2994.hs:11:10: +T2994.hs:11:10: error: Expecting one more argument to ‘MonadReader Int’ Expected a constraint, but ‘MonadReader Int’ has kind ‘* -> Constraint’ In the instance declaration for ‘MonadReader Int’ -T2994.hs:13:23: +T2994.hs:11:10: error: + Malformed instance head: MonadReader Int + In the instance declaration for ‘MonadReader Int’ + +T2994.hs:13:10: error: + Expecting one more argument to ‘MonadReader (Reader' r)’ + Expected a constraint, + but ‘MonadReader (Reader' r)’ has kind ‘* -> Constraint’ + In the instance declaration for ‘MonadReader (Reader' r)’ + +T2994.hs:13:10: error: + Malformed instance head: MonadReader (Reader' r) + In the instance declaration for ‘MonadReader (Reader' r)’ + +T2994.hs:13:23: error: Expecting one more argument to ‘Reader' r’ - The first argument of ‘MonadReader’ should have kind ‘*’, - but ‘Reader' r’ has kind ‘* -> *’ + Expected a type, but ‘Reader' r’ has kind ‘* -> *’ + In the first argument of ‘MonadReader’, namely ‘Reader' r’ In the instance declaration for ‘MonadReader (Reader' r)’ -T2994.hs:15:10: - ‘MonadReader’ is applied to too many type arguments +T2994.hs:15:10: error: + Expecting one fewer argument to ‘MonadReader r r’ + Expected kind ‘(* -> *) -> Constraint’, + but ‘MonadReader r r’ has kind ‘Constraint’ + In the instance declaration for ‘MonadReader r r (Reader' r)’ + +T2994.hs:15:10: error: + Malformed instance head: MonadReader r r (Reader' r) In the instance declaration for ‘MonadReader r r (Reader' r)’ diff --git a/testsuite/tests/typecheck/should_fail/T3540.stderr b/testsuite/tests/typecheck/should_fail/T3540.stderr index 75c9dc2ea1..03cd6565fc 100644 --- a/testsuite/tests/typecheck/should_fail/T3540.stderr +++ b/testsuite/tests/typecheck/should_fail/T3540.stderr @@ -1,25 +1,37 @@ T3540.hs:4:12: error: - • Constraint ‘a ~ Int’ used as a type + • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ • In the type signature: thing :: a ~ Int T3540.hs:7:20: error: - • Constraint ‘a ~ Int’ used as a type + • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ • In the type signature: thing1 :: Int -> (a ~ Int) T3540.hs:10:13: error: - • Constraint ‘a ~ Int’ used as a type + • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ • In the type signature: thing2 :: (a ~ Int) -> Int T3540.hs:13:12: error: - • Constraint ‘?dude :: Int’ used as a type + • Expected a type, but ‘?dude::Int’ has kind ‘Constraint’ • In the type signature: thing3 :: (?dude :: Int) -> Int +T3540.hs:16:10: error: + • Could not deduce (Eq a0) + from the context: Eq a + bound by the type signature for: + thing4 :: Eq a => Int + at T3540.hs:16:10-22 + The type variable ‘a0’ is ambiguous + • In the ambiguity check for ‘thing4’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the type signature: + thing4 :: (Eq a) -> Int + T3540.hs:16:11: error: - • Constraint ‘Eq a’ used as a type + • Expected a type, but ‘Eq a’ has kind ‘Constraint’ • In the type signature: thing4 :: (Eq a) -> Int diff --git a/testsuite/tests/typecheck/should_fail/T3950.stderr b/testsuite/tests/typecheck/should_fail/T3950.stderr index 1771e2f5e4..fab70fd01b 100644 --- a/testsuite/tests/typecheck/should_fail/T3950.stderr +++ b/testsuite/tests/typecheck/should_fail/T3950.stderr @@ -1,12 +1,12 @@ -T3950.hs:15:13: - Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - w :: (* -> * -> *) -> * - Sealed :: (* -> *) -> * - Expected type: w (Id p) - Actual type: Sealed (Id p0 x0) - In the first argument of ‘Just’, namely ‘rp'’ - In the expression: Just rp' - Relevant bindings include - rp :: Bool -> Maybe (w (Id p)) (bound at T3950.hs:15:1) +T3950.hs:15:13: error: + • Couldn't match kind ‘* -> *’ with ‘*’ + When matching types + w :: (* -> * -> *) -> * + Sealed :: (* -> *) -> * + Expected type: w (Id p) + Actual type: Sealed (Id p x0) + • In the first argument of ‘Just’, namely ‘rp'’ + In the expression: Just rp' + • Relevant bindings include + rp :: Bool -> Maybe (w (Id p)) (bound at T3950.hs:15:1) diff --git a/testsuite/tests/typecheck/should_fail/T4875.stderr b/testsuite/tests/typecheck/should_fail/T4875.stderr index 98584a44f0..80e1e0e99d 100644 --- a/testsuite/tests/typecheck/should_fail/T4875.stderr +++ b/testsuite/tests/typecheck/should_fail/T4875.stderr @@ -1,5 +1,7 @@ -
-T4875.hs:27:24: error:
- ‘r’ is applied to too many type arguments
- In the type signature: multiplicities :: r c -> [c]
- In the class declaration for ‘Morphic’
+ +T4875.hs:27:24: error: + • Expecting one fewer argument to ‘r’ + Expected kind ‘* -> *’, but ‘r’ has kind ‘*’ + • In the type signature: + multiplicities :: r c -> [c] + In the class declaration for ‘Morphic’ diff --git a/testsuite/tests/typecheck/should_fail/T5570.stderr b/testsuite/tests/typecheck/should_fail/T5570.stderr index 45cdfd5679..8c4ace5173 100644 --- a/testsuite/tests/typecheck/should_fail/T5570.stderr +++ b/testsuite/tests/typecheck/should_fail/T5570.stderr @@ -1,9 +1,7 @@ T5570.hs:7:16: error: - Couldn't match kind ‘*’ with ‘#’ - When matching types - r0 :: * - Double# :: # - In the second argument of ‘($)’, namely ‘D# $ 3.0##’ - In the expression: print $ D# $ 3.0## - In an equation for ‘main’: main = print $ D# $ 3.0## + • Couldn't match a lifted type with an unlifted type + When matching the kind of ‘Double#’ + • In the second argument of ‘($)’, namely ‘D# $ 3.0##’ + In the expression: print $ D# $ 3.0## + In an equation for ‘main’: main = print $ D# $ 3.0## diff --git a/testsuite/tests/typecheck/should_fail/T5853.stderr b/testsuite/tests/typecheck/should_fail/T5853.stderr index 231d57dcdd..dc23d4a064 100644 --- a/testsuite/tests/typecheck/should_fail/T5853.stderr +++ b/testsuite/tests/typecheck/should_fail/T5853.stderr @@ -1,18 +1,23 @@ T5853.hs:15:52: error: - Could not deduce: Subst t1 (Elem t2) ~ t2 - from the context: (F t, - Subst t (Elem t2) ~ t2, - Subst t2 (Elem t) ~ t, - F t1, - Subst t1 (Elem t) ~ t, - Subst t (Elem t1) ~ t1) - bound by the RULE "map/map" at T5853.hs:15:2-57 + • Could not deduce: Subst t1 (Elem t2) ~ t2 + arising from a use of ‘<$>’ + from the context: (F t, + Elem t ~ Elem t, + Elem t2 ~ Elem t2, + Subst t (Elem t2) ~ t2, + Subst t2 (Elem t) ~ t, + F t1, + Elem t1 ~ Elem t1, + Elem t ~ Elem t, + Subst t1 (Elem t) ~ t, + Subst t (Elem t1) ~ t1) + bound by the RULE "map/map" at T5853.hs:15:2-57 ‘t2’ is a rigid type variable bound by - the RULE "map/map" at T5853.hs:15:2 - In the expression: (f . g) <$> xs - When checking the transformation rule "map/map" - Relevant bindings include - f :: Elem t -> Elem t2 (bound at T5853.hs:15:19) - g :: Elem t1 -> Elem t (bound at T5853.hs:15:21) - xs :: t1 (bound at T5853.hs:15:23) + the RULE "map/map" at T5853.hs:15:2 + • In the expression: (f . g) <$> xs + When checking the transformation rule "map/map" + • Relevant bindings include + f :: Elem t -> Elem t2 (bound at T5853.hs:15:19) + g :: Elem t1 -> Elem t (bound at T5853.hs:15:21) + xs :: t1 (bound at T5853.hs:15:23) diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.stderr b/testsuite/tests/typecheck/should_fail/T6018fail.stderr index a0f5439a7d..ac5c2b6fe0 100644 --- a/testsuite/tests/typecheck/should_fail/T6018fail.stderr +++ b/testsuite/tests/typecheck/should_fail/T6018fail.stderr @@ -66,7 +66,7 @@ T6018fail.hs:59:10: error: T6018fail.hs:62:15: error: Type family equation violates injectivity annotation. - Kind variable ‘k1’ cannot be inferred from the right-hand side. + Kind variable ‘k’ cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: PolyKindVars '[] = '[] -- Defined at T6018fail.hs:62:15 @@ -76,7 +76,7 @@ T6018fail.hs:66:15: error: Kind variable ‘k’ cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: - forall (k :: BOX) (a :: k) (b :: k). + forall k (a :: k) (b :: k). Fc a b = Int -- Defined at T6018fail.hs:66:15 T6018fail.hs:70:15: error: @@ -85,7 +85,7 @@ T6018fail.hs:70:15: error: cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: - forall (k :: BOX) (a :: k) (b :: k). + forall k (a :: k) (b :: k). Gc a b = Int -- Defined at T6018fail.hs:70:15 T6018fail.hs:75:15: error: @@ -142,7 +142,7 @@ T6018fail.hs:118:15: error: cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: - forall (k :: BOX) a b (c :: k). + forall k a b (c :: k). G7 a b c = [G7a a b c] -- Defined at T6018fail.hs:118:15 T6018fail.hs:129:1: error: diff --git a/testsuite/tests/typecheck/should_fail/T6018failclosed.stderr b/testsuite/tests/typecheck/should_fail/T6018failclosed.stderr index 2afafbe4cd..c151553a3a 100644 --- a/testsuite/tests/typecheck/should_fail/T6018failclosed.stderr +++ b/testsuite/tests/typecheck/should_fail/T6018failclosed.stderr @@ -28,7 +28,7 @@ T6018failclosed.hs:25:5: error: cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: - forall (k :: BOX) (k1 :: BOX) (b :: k) (c :: k1). + forall k k1 (b :: k) (c :: k1). JClosed Int b c = Char -- Defined at T6018failclosed.hs:25:5 In the equations for closed type family ‘JClosed’ In the type family declaration for ‘JClosed’ @@ -44,7 +44,7 @@ T6018failclosed.hs:30:5: error: T6018failclosed.hs:35:5: error: Type family equation violates injectivity annotation. RHS of injective type family equation cannot be a type family: - forall (k :: BOX) (a :: k). + forall k (a :: k). LClosed a = MaybeSynClosed a -- Defined at T6018failclosed.hs:35:5 In the equations for closed type family ‘LClosed’ In the type family declaration for ‘LClosed’ @@ -63,6 +63,13 @@ T6018failclosed.hs:43:5: error: In the equations for closed type family ‘IClosed’ In the type family declaration for ‘IClosed’ +T6018failclosed.hs:49:3: error: + Type family equations violate injectivity annotation: + E2 'True = 'False -- Defined at T6018failclosed.hs:49:3 + E2 a = 'False -- Defined at T6018failclosed.hs:50:3 + In the equations for closed type family ‘E2’ + In the type family declaration for ‘E2’ + T6018failclosed.hs:50:3: error: Type family equation violates injectivity annotation. Type variable ‘a’ cannot be inferred from the right-hand side. @@ -83,7 +90,7 @@ T6018failclosed.hs:66:5: error: Kind variable ‘k’ cannot be inferred from the right-hand side. (enabling -fprint-explicit-kinds might help) In the type family equation: - forall (k :: BOX) (a :: k) (b :: k). + forall k (a :: k) (b :: k). Gc a b = Int -- Defined at T6018failclosed.hs:66:5 In the equations for closed type family ‘Gc’ In the type family declaration for ‘Gc’ diff --git a/testsuite/tests/typecheck/should_fail/T7368.stderr b/testsuite/tests/typecheck/should_fail/T7368.stderr index c6c11e81b7..1c538ac7f9 100644 --- a/testsuite/tests/typecheck/should_fail/T7368.stderr +++ b/testsuite/tests/typecheck/should_fail/T7368.stderr @@ -1,10 +1,6 @@ T7368.hs:3:10: error: - Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - c0 :: (* -> *) -> * - (->) a0 :: * -> * - Expected type: a0 -> b0 - Actual type: c0 Maybe - In the first argument of ‘b’, namely ‘(l Nothing)’ - In the expression: b (l Nothing) + • Couldn't match kind ‘*’ with ‘* -> *’ + When matching the kind of ‘Maybe’ + • In the first argument of ‘b’, namely ‘(l Nothing)’ + In the expression: b (l Nothing) diff --git a/testsuite/tests/typecheck/should_fail/T7368a.stderr b/testsuite/tests/typecheck/should_fail/T7368a.stderr index a4f796ce6f..e55aab0e62 100644 --- a/testsuite/tests/typecheck/should_fail/T7368a.stderr +++ b/testsuite/tests/typecheck/should_fail/T7368a.stderr @@ -1,12 +1,12 @@ T7368a.hs:8:6: error: - Couldn't match kind ‘*’ with ‘* -> *’ - When matching types - f :: * -> * - Bad :: (* -> *) -> * - Expected type: f (Bad f) - Actual type: Bad t0 - In the pattern: Bad x - In an equation for ‘fun’: fun (Bad x) = True - Relevant bindings include - fun :: f (Bad f) -> Bool (bound at T7368a.hs:8:1) + • Couldn't match kind ‘*’ with ‘* -> *’ + When matching types + f :: * -> * + Bad :: (* -> *) -> * + Expected type: f (Bad f) + Actual type: Bad (Bad f) + • In the pattern: Bad x + In an equation for ‘fun’: fun (Bad x) = True + • Relevant bindings include + fun :: f (Bad f) -> Bool (bound at T7368a.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/T7410.stderr b/testsuite/tests/typecheck/should_fail/T7410.stderr index 46c7a8c2fc..0ca86ed872 100644 --- a/testsuite/tests/typecheck/should_fail/T7410.stderr +++ b/testsuite/tests/typecheck/should_fail/T7410.stderr @@ -1,6 +1,6 @@ -
-T7410.hs:3:9: error:
- Expecting one more argument to ‘Either Int’
- The first argument of a tuple should have kind ‘*’,
- but ‘Either Int’ has kind ‘* -> *’
- In the type signature: foo :: (Either Int, Int)
+ +T7410.hs:3:9: error: + • Expecting one more argument to ‘Either Int’ + Expected a type, but ‘Either Int’ has kind ‘* -> *’ + • In the type signature: + foo :: (Either Int, Int) diff --git a/testsuite/tests/typecheck/should_fail/T7453.stderr b/testsuite/tests/typecheck/should_fail/T7453.stderr index d3b76c54bf..efbc7497e5 100644 --- a/testsuite/tests/typecheck/should_fail/T7453.stderr +++ b/testsuite/tests/typecheck/should_fail/T7453.stderr @@ -1,40 +1,50 @@ -T7453.hs:10:30: error: - • Couldn't match expected type ‘t1’ with actual type ‘t’ - because type variable ‘t1’ would escape its scope +T7453.hs:9:15: error: + • Couldn't match type ‘r’ with ‘t’ + because type variable ‘t’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: - z :: Id t1 + z :: Id t at T7453.hs:8:11-19 - • In the first argument of ‘Id’, namely ‘v’ - In the expression: Id v + Expected type: Id t + Actual type: Id r + • In the expression: aux + In an equation for ‘z’: + z = aux + where + aux = Id v • Relevant bindings include - aux :: Id t1 (bound at T7453.hs:10:21) - z :: Id t1 (bound at T7453.hs:9:11) - v :: t (bound at T7453.hs:7:7) - cast1 :: t -> a (bound at T7453.hs:7:1) + aux :: Id r (bound at T7453.hs:10:21) + z :: Id t (bound at T7453.hs:9:11) + v :: r (bound at T7453.hs:7:7) + cast1 :: r -> a (bound at T7453.hs:7:1) -T7453.hs:16:33: error: - • Couldn't match expected type ‘t2’ with actual type ‘t’ - because type variable ‘t2’ would escape its scope +T7453.hs:15:15: error: + • Couldn't match type ‘r’ with ‘t1’ + because type variable ‘t1’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: - z :: () -> t2 + z :: () -> t1 at T7453.hs:14:11-22 - • In the first argument of ‘const’, namely ‘v’ - In the expression: const v + Expected type: () -> t1 + Actual type: () -> r + • In the expression: aux + In an equation for ‘z’: + z = aux + where + aux = const v • Relevant bindings include - aux :: b -> t2 (bound at T7453.hs:16:21) - z :: () -> t2 (bound at T7453.hs:15:11) - v :: t (bound at T7453.hs:13:7) - cast2 :: t -> t1 (bound at T7453.hs:13:1) + aux :: forall b. b -> r (bound at T7453.hs:16:21) + z :: () -> t1 (bound at T7453.hs:15:11) + v :: r (bound at T7453.hs:13:7) + cast2 :: r -> t (bound at T7453.hs:13:1) T7453.hs:21:15: error: - • Couldn't match expected type ‘t2’ with actual type ‘t’ - because type variable ‘t2’ would escape its scope + • Couldn't match expected type ‘t1’ with actual type ‘r’ + because type variable ‘t1’ would escape its scope This (rigid, skolem) type variable is bound by the type signature for: - z :: t2 + z :: t1 at T7453.hs:20:11-16 • In the expression: v In an equation for ‘z’: @@ -42,7 +52,7 @@ T7453.hs:21:15: error: where aux = const v • Relevant bindings include - aux :: forall b. b -> t2 (bound at T7453.hs:22:21) - z :: t2 (bound at T7453.hs:21:11) - v :: t (bound at T7453.hs:19:7) - cast3 :: t -> t1 (bound at T7453.hs:19:1) + aux :: forall b. b -> r (bound at T7453.hs:22:21) + z :: t1 (bound at T7453.hs:21:11) + v :: r (bound at T7453.hs:19:7) + cast3 :: r -> t (bound at T7453.hs:19:1) diff --git a/testsuite/tests/typecheck/should_fail/T7609.stderr b/testsuite/tests/typecheck/should_fail/T7609.stderr index c5ed9fcad9..24339311b8 100644 --- a/testsuite/tests/typecheck/should_fail/T7609.stderr +++ b/testsuite/tests/typecheck/should_fail/T7609.stderr @@ -1,10 +1,17 @@ -
-T7609.hs:7:16: error:
- Expecting one more argument to ‘Maybe’
- The second argument of a tuple should have kind ‘*’,
- but ‘Maybe’ has kind ‘* -> *’
- In the type signature: f :: (a `X` a, Maybe)
-
-T7609.hs:10:7: error:
- Expected a constraint, but ‘a `X` a’ has kind ‘*’
- In the type signature: g :: (a `X` a) => Maybe
+ +T7609.hs:7:16: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type signature: + f :: (a `X` a, Maybe) + +T7609.hs:10:7: error: + • Expected a constraint, but ‘X a a’ has kind ‘*’ + • In the type signature: + g :: (a `X` a) => Maybe + +T7609.hs:10:19: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type signature: + g :: (a `X` a) => Maybe diff --git a/testsuite/tests/typecheck/should_fail/T7645.stderr b/testsuite/tests/typecheck/should_fail/T7645.stderr index 17420143f8..1b3fe0ad76 100644 --- a/testsuite/tests/typecheck/should_fail/T7645.stderr +++ b/testsuite/tests/typecheck/should_fail/T7645.stderr @@ -1,6 +1,6 @@ -
-T7645.hs:6:23: error:
- Expecting one more argument to ‘Maybe’
- The second argument of a tuple should have kind ‘*’,
- but ‘Maybe’ has kind ‘* -> *’
- In the type signature: f :: ((+) a (a :: *), Maybe)
+ +T7645.hs:6:23: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type signature: + f :: ((+) a (a :: *), Maybe) diff --git a/testsuite/tests/typecheck/should_fail/T7696.stderr b/testsuite/tests/typecheck/should_fail/T7696.stderr index 41f2296797..eef19a5cfc 100644 --- a/testsuite/tests/typecheck/should_fail/T7696.stderr +++ b/testsuite/tests/typecheck/should_fail/T7696.stderr @@ -1,7 +1,7 @@ T7696.hs:7:6: error: - • Couldn't match type ‘m0 a0’ with ‘()’ + • Couldn't match type ‘() a0’ with ‘()’ Expected type: ((), w ()) - Actual type: (m0 a0, t0 m0) + Actual type: (() a0, w ()) • In the expression: f1 In an equation for ‘f2’: f2 = f1 diff --git a/testsuite/tests/typecheck/should_fail/T7734.stderr b/testsuite/tests/typecheck/should_fail/T7734.stderr index 9cd71add8d..d4efb614df 100644 --- a/testsuite/tests/typecheck/should_fail/T7734.stderr +++ b/testsuite/tests/typecheck/should_fail/T7734.stderr @@ -1,16 +1,16 @@ -T7734.hs:4:13: - Occurs check: cannot construct the infinite type: t2 ~ t2 -> t1 - In the first argument of ‘x’, namely ‘x’ - In the expression: x x - Relevant bindings include - x :: t2 -> t1 (bound at T7734.hs:4:1) - f :: (t2 -> t1) -> t -> t1 (bound at T7734.hs:4:1) +T7734.hs:4:13: error: + • Occurs check: cannot construct the infinite type: r2 ~ r2 -> r1 + • In the first argument of ‘x’, namely ‘x’ + In the expression: x x + • Relevant bindings include + x :: r2 -> r1 (bound at T7734.hs:4:1) + f :: (r2 -> r1) -> r -> r1 (bound at T7734.hs:4:1) -T7734.hs:5:13: - Occurs check: cannot construct the infinite type: t2 ~ t2 -> t1 - In the first argument of ‘x’, namely ‘x’ - In the expression: x x - Relevant bindings include - x :: t2 -> t1 (bound at T7734.hs:5:5) - (&) :: (t2 -> t1) -> t -> t1 (bound at T7734.hs:5:1) +T7734.hs:5:13: error: + • Occurs check: cannot construct the infinite type: r2 ~ r2 -> r1 + • In the first argument of ‘x’, namely ‘x’ + In the expression: x x + • Relevant bindings include + x :: r2 -> r1 (bound at T7734.hs:5:5) + (&) :: (r2 -> r1) -> r -> r1 (bound at T7734.hs:5:1) diff --git a/testsuite/tests/typecheck/should_fail/T7778.stderr b/testsuite/tests/typecheck/should_fail/T7778.stderr index 7538c15cce..545d885129 100644 --- a/testsuite/tests/typecheck/should_fail/T7778.stderr +++ b/testsuite/tests/typecheck/should_fail/T7778.stderr @@ -1,5 +1,12 @@ -
-T7778.hs:3:19: error:
- Expecting one more argument to ‘Num’
- Expected a type, but ‘Num’ has kind ‘* -> Constraint’
- In the type signature: v :: ((Num Int => Num) ()) => ()
+ +T7778.hs:3:7: error: + • Expecting one fewer argument to ‘Num Int => Num’ + Expected kind ‘* -> Constraint’, but ‘Num Int => Num’ has kind ‘*’ + • In the type signature: + v :: ((Num Int => Num) ()) => () + +T7778.hs:3:19: error: + • Expecting one more argument to ‘Num’ + Expected a type, but ‘Num’ has kind ‘* -> Constraint’ + • In the type signature: + v :: ((Num Int => Num) ()) => () diff --git a/testsuite/tests/typecheck/should_fail/T7857.stderr b/testsuite/tests/typecheck/should_fail/T7857.stderr index e923a02472..2596efb51f 100644 --- a/testsuite/tests/typecheck/should_fail/T7857.stderr +++ b/testsuite/tests/typecheck/should_fail/T7857.stderr @@ -1,17 +1,17 @@ T7857.hs:8:11: error: - Could not deduce (PrintfType r0) arising from a use of ‘printf’ - from the context: PrintfArg t - bound by the inferred type of g :: PrintfArg t => t -> b - at T7857.hs:8:1-21 - The type variable ‘r0’ is ambiguous - These potential instances exist: - instance [safe] (a ~ ()) => PrintfType (IO a) - -- Defined in ‘Text.Printf’ - instance [safe] (PrintfArg a, PrintfType r) => PrintfType (a -> r) - -- Defined in ‘Text.Printf’ - instance [safe] IsChar c => PrintfType [c] - -- Defined in ‘Text.Printf’ - In the second argument of ‘($)’, namely ‘printf "" i’ - In the expression: f $ printf "" i - In an equation for ‘g’: g i = f $ printf "" i + • Could not deduce (PrintfType a0) arising from a use of ‘printf’ + from the context: PrintfArg t + bound by the inferred type of g :: PrintfArg t => t -> b + at T7857.hs:8:1-21 + The type variable ‘a0’ is ambiguous + These potential instances exist: + instance [safe] (a ~ ()) => PrintfType (IO a) + -- Defined in ‘Text.Printf’ + instance [safe] (PrintfArg a, PrintfType r) => PrintfType (a -> r) + -- Defined in ‘Text.Printf’ + instance [safe] IsChar c => PrintfType [c] + -- Defined in ‘Text.Printf’ + • In the second argument of ‘($)’, namely ‘printf "" i’ + In the expression: f $ printf "" i + In an equation for ‘g’: g i = f $ printf "" i diff --git a/testsuite/tests/typecheck/should_fail/T7892.stderr b/testsuite/tests/typecheck/should_fail/T7892.stderr index 559ac67270..d6120f936c 100644 --- a/testsuite/tests/typecheck/should_fail/T7892.stderr +++ b/testsuite/tests/typecheck/should_fail/T7892.stderr @@ -1,2 +1,2 @@ -T7892.hs:5:4: Couldn't match kind ‘*’ against ‘* -> *’ +T7892.hs:5:4: error: Expected kind ‘* -> *’, but ‘f’ has kind ‘*’ diff --git a/testsuite/tests/typecheck/should_fail/T8030.stderr b/testsuite/tests/typecheck/should_fail/T8030.stderr index c6c05f8cf1..6e902a4294 100644 --- a/testsuite/tests/typecheck/should_fail/T8030.stderr +++ b/testsuite/tests/typecheck/should_fail/T8030.stderr @@ -6,7 +6,7 @@ T8030.hs:9:3: error: • In the ambiguity check for ‘op1’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the class method: - op1 :: forall (k :: BOX) (a :: k). C a => Pr a + op1 :: forall k (a :: k). C a => Pr a In the class declaration for ‘C’ T8030.hs:10:3: error: @@ -14,9 +14,9 @@ T8030.hs:10:3: error: NB: ‘Pr’ is a type function, and may not be injective The type variable ‘a0’ is ambiguous Expected type: Pr a -> Pr a -> Pr a - Actual type: Pr a0 -> Pr a0 -> Pr a0 + Actual type: Pr a0 -> Pr a0 -> Pr a0 • In the ambiguity check for ‘op2’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the class method: - op2 :: forall (k :: BOX) (a :: k). C a => Pr a -> Pr a -> Pr a + op2 :: forall k (a :: k). C a => Pr a -> Pr a -> Pr a In the class declaration for ‘C’ diff --git a/testsuite/tests/typecheck/should_fail/T8262.stderr b/testsuite/tests/typecheck/should_fail/T8262.stderr index b6f7ef7711..45e201cc76 100644 --- a/testsuite/tests/typecheck/should_fail/T8262.stderr +++ b/testsuite/tests/typecheck/should_fail/T8262.stderr @@ -1,11 +1,7 @@ T8262.hs:5:15: error: - Couldn't match kind ‘*’ with ‘#’ - When matching types - a :: * - Int# :: # - In the first argument of ‘Just’, namely ‘(1#)’ - In the expression: Just (1#) - In an equation for ‘foo’: foo x = Just (1#) - Relevant bindings include - foo :: t -> Maybe a (bound at T8262.hs:5:1) + • Couldn't match a lifted type with an unlifted type + When matching the kind of ‘Int#’ + • In the first argument of ‘Just’, namely ‘(1#)’ + In the expression: Just (1#) + In an equation for ‘foo’: foo x = Just (1#) diff --git a/testsuite/tests/typecheck/should_fail/T8514.stderr b/testsuite/tests/typecheck/should_fail/T8514.stderr index 41aeb3b52e..e3ea4cb385 100644 --- a/testsuite/tests/typecheck/should_fail/T8514.stderr +++ b/testsuite/tests/typecheck/should_fail/T8514.stderr @@ -1,7 +1,6 @@ T8514.hs:3:16: Expecting one more argument to ‘Maybe’ - The second argument of a tuple should have kind ‘*’, - but ‘Maybe’ has kind ‘* -> *’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ In the type ‘(a, Maybe)’ In the type declaration for ‘T’ diff --git a/testsuite/tests/typecheck/should_fail/T8603.stderr b/testsuite/tests/typecheck/should_fail/T8603.stderr index a3d17ceb56..5bfd397167 100644 --- a/testsuite/tests/typecheck/should_fail/T8603.stderr +++ b/testsuite/tests/typecheck/should_fail/T8603.stderr @@ -6,14 +6,10 @@ T8603.hs:13:10: error: T8603.hs:29:17: error: • Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - t1 :: (* -> *) -> * -> * - (->) :: * -> * -> * - Expected type: [Integer] -> StateT s RV t0 - Actual type: t1 ((->) [a0]) (StateT s RV t0) + When matching the kind of ‘[[a0]]’ • The function ‘lift’ is applied to two arguments, - but its type ‘([a0] -> StateT s RV t0) - -> t1 ((->) [a0]) (StateT s RV t0)’ + but its type ‘[] [a0] (StateT s RV t0) + -> (->) [[a0]] (StateT s RV t0)’ has only one In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3] In the expression: @@ -22,7 +18,7 @@ T8603.hs:29:17: error: T8603.hs:29:22: error: • Couldn't match type ‘RV a0’ with ‘StateT s RV t0’ - Expected type: [a0] -> StateT s RV t0 + Expected type: [] [a0] (StateT s RV t0) Actual type: [a0] -> RV a0 • In the first argument of ‘lift’, namely ‘uniform’ In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3] diff --git a/testsuite/tests/typecheck/should_fail/T8806.stderr b/testsuite/tests/typecheck/should_fail/T8806.stderr index 0131dbd929..0c7a06291a 100644 --- a/testsuite/tests/typecheck/should_fail/T8806.stderr +++ b/testsuite/tests/typecheck/should_fail/T8806.stderr @@ -1,8 +1,20 @@ -
-T8806.hs:5:6: error:
- Expected a constraint, but ‘Int’ has kind ‘*’
- In the type signature: f :: Int => Int
-
-T8806.hs:8:7: error:
- Expected a constraint, but ‘Int’ has kind ‘*’
- In the type signature: g :: (Int => Show a) => Int
+ +T8806.hs:5:6: error: + • Expected a constraint, but ‘Int’ has kind ‘*’ + • In the type signature: + f :: Int => Int + +T8806.hs:8:7: error: + • Expected a constraint, but ‘Int’ has kind ‘*’ + • In the type signature: + g :: (Int => Show a) => Int + +T8806.hs:8:7: error: + • Expected a constraint, but ‘Show a’ has kind ‘*’ + • In the type signature: + g :: (Int => Show a) => Int + +T8806.hs:8:14: error: + • Expected a type, but ‘Show a’ has kind ‘Constraint’ + • In the type signature: + g :: (Int => Show a) => Int diff --git a/testsuite/tests/typecheck/should_fail/T9109.stderr b/testsuite/tests/typecheck/should_fail/T9109.stderr index afd77c4f81..defd77572e 100644 --- a/testsuite/tests/typecheck/should_fail/T9109.stderr +++ b/testsuite/tests/typecheck/should_fail/T9109.stderr @@ -1,14 +1,15 @@ -T9109.hs:8:13: - Couldn't match expected type ‘t’ with actual type ‘Bool’ - ‘t’ is untouchable - inside the constraints: t1 ~ Bool - bound by a pattern with constructor: GBool :: G Bool, - in an equation for ‘foo’ - at T9109.hs:8:5-9 - ‘t’ is a rigid type variable bound by - the inferred type of foo :: G t1 -> t at T9109.hs:8:1 - Possible fix: add a type signature for ‘foo’ - In the expression: True - In an equation for ‘foo’: foo GBool = True - Relevant bindings include foo :: G t1 -> t (bound at T9109.hs:8:1) +T9109.hs:8:13: error: + • Couldn't match expected type ‘r’ with actual type ‘Bool’ + ‘r’ is untouchable + inside the constraints: r1 ~ Bool + bound by a pattern with constructor: GBool :: G Bool, + in an equation for ‘foo’ + at T9109.hs:8:5-9 + ‘r’ is a rigid type variable bound by + the inferred type of foo :: G r1 -> r at T9109.hs:8:1 + Possible fix: add a type signature for ‘foo’ + • In the expression: True + In an equation for ‘foo’: foo GBool = True + • Relevant bindings include + foo :: G r1 -> r (bound at T9109.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/T9196.stderr b/testsuite/tests/typecheck/should_fail/T9196.stderr index fd10f24875..c6765a9a69 100644 --- a/testsuite/tests/typecheck/should_fail/T9196.stderr +++ b/testsuite/tests/typecheck/should_fail/T9196.stderr @@ -1,8 +1,15 @@ -
-T9196.hs:4:7: error:
- Illegal constraint: forall a. Eq a
- In the type signature: f :: (forall a. Eq a) => a -> a
-
-T9196.hs:7:7: error:
- Expected a constraint, but ‘Eq a => Ord a’ has kind ‘*’
- In the type signature: g :: (Eq a => Ord a) => a -> a
+ +T9196.hs:4:7: error: + • Illegal constraint: forall a. Eq a + • In the type signature: + f :: (forall a. Eq a) => a -> a + +T9196.hs:7:7: error: + • Expected a constraint, but ‘Ord a’ has kind ‘*’ + • In the type signature: + g :: (Eq a => Ord a) => a -> a + +T9196.hs:7:15: error: + • Expected a type, but ‘Ord a’ has kind ‘Constraint’ + • In the type signature: + g :: (Eq a => Ord a) => a -> a diff --git a/testsuite/tests/typecheck/should_fail/T9201.stderr b/testsuite/tests/typecheck/should_fail/T9201.stderr index 2f1d0a2dae..b6c187548b 100644 --- a/testsuite/tests/typecheck/should_fail/T9201.stderr +++ b/testsuite/tests/typecheck/should_fail/T9201.stderr @@ -1,6 +1,7 @@ T9201.hs:6:17: error: - The first argument of ‘f’ should have kind ‘x1’, - but ‘a’ has kind ‘y1’ - In the type signature: ret :: d a (f a) - In the class declaration for ‘MonoidalCCC’ + • Expected kind ‘x’, but ‘a’ has kind ‘y’ + • In the first argument of ‘f’, namely ‘a’ + In the second argument of ‘d’, namely ‘f a’ + In the type signature: + ret :: d a (f a) diff --git a/testsuite/tests/typecheck/should_fail/T9260.stderr b/testsuite/tests/typecheck/should_fail/T9260.stderr index a163b16cbd..0773da2bf5 100644 --- a/testsuite/tests/typecheck/should_fail/T9260.stderr +++ b/testsuite/tests/typecheck/should_fail/T9260.stderr @@ -1,7 +1,7 @@ T9260.hs:12:8: error: - Couldn't match type ‘2’ with ‘1’ - Expected type: Fin 1 - Actual type: Fin (1 + 1) - In the expression: Fsucc Fzero - In an equation for ‘test’: test = Fsucc Fzero + • Couldn't match type ‘2’ with ‘1’ + Expected type: Fin 1 + Actual type: Fin (1 + 1) + • In the expression: Fsucc Fzero + In an equation for ‘test’: test = Fsucc Fzero diff --git a/testsuite/tests/typecheck/should_fail/T9999.stderr b/testsuite/tests/typecheck/should_fail/T9999.stderr index 0defd090b0..934da44f38 100644 --- a/testsuite/tests/typecheck/should_fail/T9999.stderr +++ b/testsuite/tests/typecheck/should_fail/T9999.stderr @@ -1,10 +1,9 @@ T9999.hs:13:38: error: - No instance for (Typeable F1) arising from a use of ‘typeRep’ - GHC can't yet do polykinded Typeable (F1 :: k0 -> *) - In the second argument of ‘(==)’, namely - ‘typeRep (Proxy :: Proxy F1)’ - In the expression: - typeRep (Proxy :: Proxy F) == typeRep (Proxy :: Proxy F1) - In an equation for ‘main’: - main = typeRep (Proxy :: Proxy F) == typeRep (Proxy :: Proxy F1) + • No instance for (Typeable k0) arising from a use of ‘typeRep’ + • In the second argument of ‘(==)’, namely + ‘typeRep (Proxy :: Proxy F1)’ + In the expression: + typeRep (Proxy :: Proxy F) == typeRep (Proxy :: Proxy F1) + In an equation for ‘main’: + main = typeRep (Proxy :: Proxy F) == typeRep (Proxy :: Proxy F1) diff --git a/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr b/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr index c97acc25a7..8141caf5b5 100644 --- a/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr +++ b/testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr @@ -1,64 +1,68 @@ TcCoercibleFail.hs:11:8: error: - Couldn't match representation of type ‘Int’ with that of ‘()’ - arising from a use of ‘coerce’ - In the expression: coerce - In the expression: coerce $ one :: () - In an equation for ‘foo1’: foo1 = coerce $ one :: () + • Couldn't match representation of type ‘Int’ with that of ‘()’ + arising from a use of ‘coerce’ + • In the expression: coerce + In the expression: coerce $ one :: () + In an equation for ‘foo1’: foo1 = coerce $ one :: () TcCoercibleFail.hs:14:8: error: - Couldn't match representation of type ‘m Int’ with that of ‘m Age’ - arising from a use of ‘coerce’ - NB: We cannot know what roles the parameters to ‘m’ have; - we must assume that the role is nominal - In the expression: coerce - In the expression: coerce $ (return one :: m Int) - In an equation for ‘foo2’: foo2 = coerce $ (return one :: m Int) - Relevant bindings include - foo2 :: m Age (bound at TcCoercibleFail.hs:14:1) + • Couldn't match representation of type ‘m Int’ + with that of ‘m Age’ + arising from a use of ‘coerce’ + NB: We cannot know what roles the parameters to ‘m’ have; + we must assume that the role is nominal + • In the expression: coerce + In the expression: coerce $ (return one :: m Int) + In an equation for ‘foo2’: foo2 = coerce $ (return one :: m Int) + • Relevant bindings include + foo2 :: m Age (bound at TcCoercibleFail.hs:14:1) TcCoercibleFail.hs:16:8: error: - Couldn't match type ‘Int’ with ‘Age’ arising from a use of ‘coerce’ - In the expression: coerce - In the expression: coerce $ Map one () :: Map Age () - In an equation for ‘foo3’: foo3 = coerce $ Map one () :: Map Age () + • Couldn't match type ‘Int’ with ‘Age’ + arising from a use of ‘coerce’ + • In the expression: coerce + In the expression: coerce $ Map one () :: Map Age () + In an equation for ‘foo3’: foo3 = coerce $ Map one () :: Map Age () TcCoercibleFail.hs:18:8: error: - Couldn't match representation of type ‘Int’ with that of ‘Down Int’ - arising from a use of ‘coerce’ - The data constructor ‘Down’ of newtype ‘Down’ is not in scope - In the expression: coerce - In the expression: coerce $ one :: Down Int - In an equation for ‘foo4’: foo4 = coerce $ one :: Down Int + • Couldn't match representation of type ‘Int’ + with that of ‘Down Int’ + arising from a use of ‘coerce’ + The data constructor ‘Down’ of newtype ‘Down’ is not in scope + • In the expression: coerce + In the expression: coerce $ one :: Down Int + In an equation for ‘foo4’: foo4 = coerce $ one :: Down Int TcCoercibleFail.hs:21:8: error: - Couldn't match representation of type ‘Void’ with that of ‘()’ - arising from a use of ‘coerce’ - In the expression: coerce :: Void -> () - In an equation for ‘foo5’: foo5 = coerce :: Void -> () + • Couldn't match representation of type ‘Void’ with that of ‘()’ + arising from a use of ‘coerce’ + • In the expression: coerce :: Void -> () + In an equation for ‘foo5’: foo5 = coerce :: Void -> () TcCoercibleFail.hs:24:9: error: - Couldn't match representation of type ‘VoidBad ()’ - with that of ‘()’ - arising from a use of ‘coerce’ - In the expression: coerce :: (VoidBad ()) -> () - In an equation for ‘foo5'’: foo5' = coerce :: (VoidBad ()) -> () + • Couldn't match representation of type ‘VoidBad ()’ + with that of ‘()’ + arising from a use of ‘coerce’ + • In the expression: coerce :: (VoidBad ()) -> () + In an equation for ‘foo5'’: foo5' = coerce :: (VoidBad ()) -> () TcCoercibleFail.hs:28:8: error: - Reduction stack overflow; size = 201 - When simplifying the following type: Fix (Either Age) - Use -freduction-depth=0 to disable this check - (any upper bound you could choose might fail unpredictably with - minor updates to GHC, so disabling the check is recommended if - you're sure that type checking should terminate) - In the expression: coerce :: Fix (Either Int) -> Fix (Either Age) - In an equation for ‘foo6’: - foo6 = coerce :: Fix (Either Int) -> Fix (Either Age) + • Reduction stack overflow; size = 201 + When simplifying the following type: + Coercible (Fix (Either Int)) (Fix (Either Age)) + Use -freduction-depth=0 to disable this check + (any upper bound you could choose might fail unpredictably with + minor updates to GHC, so disabling the check is recommended if + you're sure that type checking should terminate) + • In the expression: coerce :: Fix (Either Int) -> Fix (Either Age) + In an equation for ‘foo6’: + foo6 = coerce :: Fix (Either Int) -> Fix (Either Age) TcCoercibleFail.hs:29:8: error: - Couldn't match representation of type ‘Either - Int (Fix (Either Int))’ - with that of ‘()’ - arising from a use of ‘coerce’ - In the expression: coerce :: Fix (Either Int) -> () - In an equation for ‘foo7’: foo7 = coerce :: Fix (Either Int) -> () + • Couldn't match representation of type ‘Either + Int (Fix (Either Int))’ + with that of ‘()’ + arising from a use of ‘coerce’ + • In the expression: coerce :: Fix (Either Int) -> () + In an equation for ‘foo7’: foo7 = coerce :: Fix (Either Int) -> () diff --git a/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.hs b/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.hs index 8d89b52639..d165648a32 100644 --- a/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.hs +++ b/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + import Data.Coerce (Coercible) instance Coercible () () diff --git a/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr b/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr index 29c268d22f..b121f91c65 100644 --- a/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr +++ b/testsuite/tests/typecheck/should_fail/TcCoercibleFail2.stderr @@ -1,5 +1,5 @@ -TcCoercibleFail2.hs:3:10: +TcCoercibleFail2.hs:5:10: error: Illegal instance declaration for ‘Coercible () ()’ - The class is abstract, manual instances are not permitted. + Manual instances of this class are not permitted. In the instance declaration for ‘Coercible () ()’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail002.stderr b/testsuite/tests/typecheck/should_fail/tcfail002.stderr index 4017239930..285b6bf577 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail002.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail002.stderr @@ -1,8 +1,8 @@ -tcfail002.hs:4:7: - Occurs check: cannot construct the infinite type: t ~ [t] - In the expression: z - In an equation for ‘c’: c z = z - Relevant bindings include - z :: [t] (bound at tcfail002.hs:4:3) - c :: [t] -> t (bound at tcfail002.hs:3:1) +tcfail002.hs:4:7: error: + • Occurs check: cannot construct the infinite type: r ~ [r] + • In the expression: z + In an equation for ‘c’: c z = z + • Relevant bindings include + z :: [r] (bound at tcfail002.hs:4:3) + c :: [r] -> r (bound at tcfail002.hs:3:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail004.stderr b/testsuite/tests/typecheck/should_fail/tcfail004.stderr index 9c51edc5b2..2294a6166f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail004.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail004.stderr @@ -1,9 +1,9 @@ -
-tcfail004.hs:3:9:
- Couldn't match expected type ‘(t, t1)’
- with actual type ‘(Integer, Integer, Integer)’
- In the expression: (1, 2, 3)
- In a pattern binding: (f, g) = (1, 2, 3)
- Relevant bindings include
- f :: t (bound at tcfail004.hs:3:2)
- g :: t1 (bound at tcfail004.hs:3:4)
+ +tcfail004.hs:3:9: error: + • Couldn't match expected type ‘(r, r1)’ + with actual type ‘(Integer, Integer, Integer)’ + • In the expression: (1, 2, 3) + In a pattern binding: (f, g) = (1, 2, 3) + • Relevant bindings include + f :: r (bound at tcfail004.hs:3:2) + g :: r1 (bound at tcfail004.hs:3:4) diff --git a/testsuite/tests/typecheck/should_fail/tcfail005.stderr b/testsuite/tests/typecheck/should_fail/tcfail005.stderr index c9d3360243..4c585af3da 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail005.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail005.stderr @@ -1,9 +1,9 @@ -
-tcfail005.hs:3:9:
- Couldn't match expected type ‘[t]’
- with actual type ‘(Integer, Char)’
- In the expression: (1, 'a')
- In a pattern binding: (h : i) = (1, 'a')
- Relevant bindings include
- h :: t (bound at tcfail005.hs:3:2)
- i :: [t] (bound at tcfail005.hs:3:4)
+ +tcfail005.hs:3:9: error: + • Couldn't match expected type ‘[r]’ + with actual type ‘(Integer, Char)’ + • In the expression: (1, 'a') + In a pattern binding: (h : i) = (1, 'a') + • Relevant bindings include + h :: r (bound at tcfail005.hs:3:2) + i :: [r] (bound at tcfail005.hs:3:4) diff --git a/testsuite/tests/typecheck/should_fail/tcfail010.stderr b/testsuite/tests/typecheck/should_fail/tcfail010.stderr index abffc1acd2..92ee3d8f8e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail010.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail010.stderr @@ -1,6 +1,6 @@ tcfail010.hs:3:17: - No instance for (Num [t0]) arising from a use of ‘+’ + No instance for (Num [r0]) arising from a use of ‘+’ In the expression: z + 2 In the expression: \ (y : z) -> z + 2 In an equation for ‘q’: q = \ (y : z) -> z + 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail013.stderr b/testsuite/tests/typecheck/should_fail/tcfail013.stderr index 2f200abcce..332f10e729 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail013.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail013.stderr @@ -1,6 +1,7 @@ -tcfail013.hs:4:3: - Couldn't match expected type ‘[t]’ with actual type ‘Bool’ - In the pattern: True - In an equation for ‘f’: f True = 2 - Relevant bindings include f :: [t] -> a (bound at tcfail013.hs:3:1) +tcfail013.hs:4:3: error: + • Couldn't match expected type ‘[r]’ with actual type ‘Bool’ + • In the pattern: True + In an equation for ‘f’: f True = 2 + • Relevant bindings include + f :: [r] -> a (bound at tcfail013.hs:3:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail014.stderr b/testsuite/tests/typecheck/should_fail/tcfail014.stderr index bf28aa76b7..92307b3830 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail014.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail014.stderr @@ -1,8 +1,8 @@ -tcfail014.hs:5:33: - Occurs check: cannot construct the infinite type: t8 ~ t8 -> t7 - In the first argument of ‘z’, namely ‘z’ - In the expression: z z - Relevant bindings include - z :: t8 -> t7 (bound at tcfail014.hs:5:27) - h :: (t8 -> t7) -> t7 (bound at tcfail014.hs:5:25) +tcfail014.hs:5:33: error: + • Occurs check: cannot construct the infinite type: r8 ~ r8 -> r7 + • In the first argument of ‘z’, namely ‘z’ + In the expression: z z + • Relevant bindings include + z :: r8 -> r7 (bound at tcfail014.hs:5:27) + h :: (r8 -> r7) -> r7 (bound at tcfail014.hs:5:25) diff --git a/testsuite/tests/typecheck/should_fail/tcfail018.stderr b/testsuite/tests/typecheck/should_fail/tcfail018.stderr index ef32705126..88c08a8a8b 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail018.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail018.stderr @@ -1,5 +1,5 @@ tcfail018.hs:5:10: - No instance for (Num [t0]) arising from the literal ‘1’ + No instance for (Num [r0]) arising from the literal ‘1’ In the expression: 1 In a pattern binding: (a : []) = 1 diff --git a/testsuite/tests/typecheck/should_fail/tcfail032.stderr b/testsuite/tests/typecheck/should_fail/tcfail032.stderr index 649acb0b07..05d33a5e05 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail032.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail032.stderr @@ -1,13 +1,13 @@ -tcfail032.hs:14:8: - Couldn't match expected type ‘a1 -> Int’ with actual type ‘t’ - because type variable ‘a1’ would escape its scope - This (rigid, skolem) type variable is bound by - an expression type signature: Eq a1 => a1 -> Int - at tcfail032.hs:14:8-30 - In the expression: (x :: (Eq a) => a -> Int) - In an equation for ‘f’: f x = (x :: (Eq a) => a -> Int) - Relevant bindings include - x :: t (bound at tcfail032.hs:14:3) - f :: t -> a -> Int (bound at tcfail032.hs:14:1) - +tcfail032.hs:14:8: error: + • Couldn't match expected type ‘a1 -> Int’ with actual type ‘r’ + because type variable ‘a1’ would escape its scope + This (rigid, skolem) type variable is bound by + an expression type signature: + Eq a1 => a1 -> Int + at tcfail032.hs:14:8-30 + • In the expression: (x :: (Eq a) => a -> Int) + In an equation for ‘f’: f x = (x :: (Eq a) => a -> Int) + • Relevant bindings include + x :: r (bound at tcfail032.hs:14:3) + f :: r -> a -> Int (bound at tcfail032.hs:14:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail036.hs b/testsuite/tests/typecheck/should_fail/tcfail036.hs index ade1720ccc..62c7b7e26b 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail036.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail036.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} + -- !!! prelude class name in an instance-tycon position -- module ShouldFail where diff --git a/testsuite/tests/typecheck/should_fail/tcfail036.stderr b/testsuite/tests/typecheck/should_fail/tcfail036.stderr index a9aef1192b..e94ba6a2a4 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail036.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail036.stderr @@ -1,11 +1,11 @@ -tcfail036.hs:6:10: +tcfail036.hs:8:10: Duplicate instance declarations: - instance Num NUM -- Defined at tcfail036.hs:6:10 instance Num NUM -- Defined at tcfail036.hs:8:10 + instance Num NUM -- Defined at tcfail036.hs:10:10 -tcfail036.hs:9:13: +tcfail036.hs:11:13: Expecting one more argument to ‘Num’ - The first argument of ‘Eq’ should have kind ‘*’, - but ‘Num’ has kind ‘* -> Constraint’ + Expected a type, but ‘Num’ has kind ‘* -> Constraint’ + In the first argument of ‘Eq’, namely ‘Num’ In the instance declaration for ‘Eq Num’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail049.stderr b/testsuite/tests/typecheck/should_fail/tcfail049.stderr index 12fc06db98..1b74ce0070 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail049.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail049.stderr @@ -1,2 +1,2 @@ -
-tcfail049.hs:3:7: error: Variable not in scope: g :: t1 -> t
+ +tcfail049.hs:3:7: error: Variable not in scope: g :: t -> t1 diff --git a/testsuite/tests/typecheck/should_fail/tcfail050.stderr b/testsuite/tests/typecheck/should_fail/tcfail050.stderr index 881e497b4d..2ca5065938 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail050.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail050.stderr @@ -1,3 +1,3 @@ -
-tcfail050.hs:3:7: error:
- Data constructor not in scope: B :: t1 -> t
+ +tcfail050.hs:3:7: error: + Data constructor not in scope: B :: t -> t1 diff --git a/testsuite/tests/typecheck/should_fail/tcfail057.stderr b/testsuite/tests/typecheck/should_fail/tcfail057.stderr index 07a8116173..945c81c1cd 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail057.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail057.stderr @@ -1,5 +1,5 @@ tcfail057.hs:5:7: error: - • Constraint ‘RealFrac a’ used as a type + • Expected a type, but ‘RealFrac a’ has kind ‘Constraint’ • In the type signature: f :: (RealFrac a) -> a -> a diff --git a/testsuite/tests/typecheck/should_fail/tcfail070.stderr b/testsuite/tests/typecheck/should_fail/tcfail070.stderr index d98857de4c..6236947709 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail070.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail070.stderr @@ -1,5 +1,6 @@ tcfail070.hs:15:15: - ‘[Int]’ is applied to too many type arguments + Expecting one fewer argument to ‘[Int]’ + Expected kind ‘* -> k0’, but ‘[Int]’ has kind ‘*’ In the type ‘[Int] Bool’ In the type declaration for ‘State’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail078.stderr b/testsuite/tests/typecheck/should_fail/tcfail078.stderr index 8a7837df00..f68b142340 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail078.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail078.stderr @@ -1,4 +1,6 @@ -
-tcfail078.hs:5:6: error:
- ‘Integer’ is applied to too many type arguments
- In the type signature: f :: Integer i => i
+ +tcfail078.hs:5:6: error: + • Expecting one fewer argument to ‘Integer’ + Expected kind ‘* -> Constraint’, but ‘Integer’ has kind ‘*’ + • In the type signature: + f :: Integer i => i diff --git a/testsuite/tests/typecheck/should_fail/tcfail088.stderr b/testsuite/tests/typecheck/should_fail/tcfail088.stderr index d9cd5427b7..1aedd2a43c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail088.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail088.stderr @@ -1,4 +1,4 @@ tcfail088.hs:9:19: - Illegal polymorphic or qualified type: forall s. T s a + Illegal polymorphic or qualified type: forall s1. T s1 a In the instance declaration for ‘Ord (forall s. T s a)’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail090.stderr b/testsuite/tests/typecheck/should_fail/tcfail090.stderr index 6c6f97d932..662d7da804 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail090.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail090.stderr @@ -1,8 +1,6 @@ tcfail090.hs:11:9: error: - Couldn't match kind ‘*’ with ‘#’ - When matching types - a0 :: * - ByteArray# :: # - In the expression: my_undefined - In an equation for ‘die’: die _ = my_undefined + • Couldn't match a lifted type with an unlifted type + When matching the kind of ‘ByteArray#’ + • In the expression: my_undefined + In an equation for ‘die’: die _ = my_undefined diff --git a/testsuite/tests/typecheck/should_fail/tcfail099.stderr b/testsuite/tests/typecheck/should_fail/tcfail099.stderr index 9fdccb3335..687fafb6da 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail099.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail099.stderr @@ -1,14 +1,14 @@ -
-tcfail099.hs:9:20:
- Couldn't match expected type ‘a’ with actual type ‘t’
- because type variable ‘a’ would escape its scope
- This (rigid, skolem) type variable is bound by
- a pattern with constructor: C :: forall a. (a -> Int) -> DS,
- in an equation for ‘call’
- at tcfail099.hs:9:7-9
- In the first argument of ‘f’, namely ‘arg’
- In the expression: f arg
- Relevant bindings include
- arg :: t (bound at tcfail099.hs:9:12)
- f :: a -> Int (bound at tcfail099.hs:9:9)
- call :: DS -> t -> Int (bound at tcfail099.hs:9:1)
+ +tcfail099.hs:9:20: error: + • Couldn't match expected type ‘a’ with actual type ‘r’ + because type variable ‘a’ would escape its scope + This (rigid, skolem) type variable is bound by + a pattern with constructor: C :: forall a. (a -> Int) -> DS, + in an equation for ‘call’ + at tcfail099.hs:9:7-9 + • In the first argument of ‘f’, namely ‘arg’ + In the expression: f arg + • Relevant bindings include + arg :: r (bound at tcfail099.hs:9:12) + f :: a -> Int (bound at tcfail099.hs:9:9) + call :: DS -> r -> Int (bound at tcfail099.hs:9:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail113.stderr b/testsuite/tests/typecheck/should_fail/tcfail113.stderr index 06837f6f73..b84151ac73 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail113.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail113.stderr @@ -1,14 +1,18 @@ -
-tcfail113.hs:12:7: error:
- Expecting one more argument to ‘Maybe’
- Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’
- In the type signature: f :: [Maybe]
-
-tcfail113.hs:15:8: error:
- The first argument of ‘T’ should have kind ‘* -> *’,
- but ‘Int’ has kind ‘*’
- In the type signature: g :: T Int
-
-tcfail113.hs:18:6: error:
- ‘Int’ is applied to too many type arguments
- In the type signature: h :: Int Int
+ +tcfail113.hs:12:7: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type signature: + f :: [Maybe] + +tcfail113.hs:15:8: error: + • Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ + • In the first argument of ‘T’, namely ‘Int’ + In the type signature: + g :: T Int + +tcfail113.hs:18:6: error: + • Expecting one fewer argument to ‘Int’ + Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ + • In the type signature: + h :: Int Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail122.stderr b/testsuite/tests/typecheck/should_fail/tcfail122.stderr index 47b391df6d..ab743441f9 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail122.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail122.stderr @@ -1,18 +1,15 @@ tcfail122.hs:8:9: error: - Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - c0 :: (* -> *) -> * - a :: * -> * - Expected type: a b - Actual type: c0 d0 - In the expression: - undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d - In the expression: - [undefined :: forall a b. a b, - undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d] - In an equation for ‘foo’: - foo - = [undefined :: forall a b. a b, - undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d] - Relevant bindings include foo :: [a b] (bound at tcfail122.hs:7:1) + • Couldn't match kind ‘* -> *’ with ‘*’ + When matching the kind of ‘a’ + • In the expression: + undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d + In the expression: + [undefined :: forall a b. a b, + undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d] + In an equation for ‘foo’: + foo + = [undefined :: forall a b. a b, + undefined :: forall (c :: (* -> *) -> *) (d :: * -> *). c d] + • Relevant bindings include + foo :: [a b] (bound at tcfail122.hs:7:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail123.stderr b/testsuite/tests/typecheck/should_fail/tcfail123.stderr index 396d63c9f8..00b8bbdd10 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail123.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail123.stderr @@ -1,9 +1,7 @@ tcfail123.hs:11:9: error: - Couldn't match kind ‘*’ with ‘#’ - When matching types - t0 :: * - Int# :: # + Couldn't match a lifted type with an unlifted type + When matching the kind of ‘Int#’ In the first argument of ‘f’, namely ‘3#’ In the expression: f 3# In an equation for ‘h’: h v = f 3# diff --git a/testsuite/tests/typecheck/should_fail/tcfail132.stderr b/testsuite/tests/typecheck/should_fail/tcfail132.stderr index 16fee3fbb4..9ec35d7d9f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail132.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail132.stderr @@ -1,6 +1,15 @@ -tcfail132.hs:17:37: - The first argument of ‘T’ should have kind ‘* -> * -> * -> *’, +tcfail132.hs:17:37: error: + Expecting one fewer argument to ‘Object f' f t’ + Expected kind ‘* -> * -> * -> *’, but ‘Object f' f t’ has kind ‘* -> * -> *’ + In the first argument of ‘T’, namely ‘Object f' f t’ + In the type ‘T (Object f' f t) (DUnit t)’ + In the type declaration for ‘LiftObject’ + +tcfail132.hs:17:53: error: + Expected kind ‘* -> * -> * -> *’, + but ‘DUnit t’ has kind ‘* -> * -> *’ + In the second argument of ‘T’, namely ‘DUnit t’ In the type ‘T (Object f' f t) (DUnit t)’ In the type declaration for ‘LiftObject’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr index 32f73422af..f629ea0140 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail133.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr @@ -3,9 +3,9 @@ tcfail133.hs:2:61: warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. tcfail133.hs:68:7: error: - Ambiguous type variable ‘r0’ arising from a use of ‘show’ - prevents the constraint ‘(Show r0)’ from being solved. - Probable fix: use a type annotation to specify what ‘r0’ should be. + Ambiguous type variable ‘a0’ arising from a use of ‘show’ + prevents the constraint ‘(Show a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance Show Module -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ @@ -18,7 +18,7 @@ tcfail133.hs:68:7: error: foo = show $ add (One :@ Zero) (One :@ One) tcfail133.hs:68:14: error: - No instance for (AddDigit (Zero :@ (One :@ One)) One r0) + No instance for (AddDigit (Zero :@ (One :@ One)) One a0) arising from a use of ‘add’ In the second argument of ‘($)’, namely ‘add (One :@ Zero) (One :@ One)’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.stderr b/testsuite/tests/typecheck/should_fail/tcfail140.stderr index 09eb70c588..41268ec6df 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail140.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail140.stderr @@ -1,38 +1,40 @@ -
-tcfail140.hs:10:7: error:
- Couldn't match expected type ‘Integer -> t’ with actual type ‘Int’
- The function ‘f’ is applied to two arguments,
- but its type ‘Int -> Int’ has only one
- In the expression: f 3 9
- In an equation for ‘bar’: bar = f 3 9
- Relevant bindings include bar :: t (bound at tcfail140.hs:10:1)
-
-tcfail140.hs:12:10: error:
- Couldn't match expected type ‘Integer -> t1’ with actual type ‘Int’
- The operator ‘f’ takes two arguments,
- but its type ‘Int -> Int’ has only one
- In the expression: 3 `f` 4
- In an equation for ‘rot’: rot xs = 3 `f` 4
- Relevant bindings include
- rot :: t -> t1 (bound at tcfail140.hs:12:1)
-
-tcfail140.hs:14:15: error:
- Couldn't match expected type ‘a -> b’ with actual type ‘Int’
- The operator ‘f’ takes two arguments,
- but its type ‘Int -> Int’ has only one
- In the first argument of ‘map’, namely ‘(3 `f`)’
- In the expression: map (3 `f`) xs
- Relevant bindings include
- xs :: [a] (bound at tcfail140.hs:14:5)
- bot :: [a] -> [b] (bound at tcfail140.hs:14:1)
-
-tcfail140.hs:16:8: error:
- The constructor ‘Just’ should have 1 argument, but has been given none
- In the pattern: Just
- In the expression: (\ Just x -> x) :: Maybe a -> a
- In the expression: ((\ Just x -> x) :: Maybe a -> a) (Just 1)
-
-tcfail140.hs:19:1: error:
- Couldn't match expected type ‘t0 -> Bool’ with actual type ‘Int’
- The equation(s) for ‘g’ have two arguments,
- but its type ‘Int -> Int’ has only one
+ +tcfail140.hs:10:7: error: + • Couldn't match expected type ‘Integer -> t’ + with actual type ‘Int’ + • The function ‘f’ is applied to two arguments, + but its type ‘Int -> Int’ has only one + In the expression: f 3 9 + In an equation for ‘bar’: bar = f 3 9 + • Relevant bindings include bar :: t (bound at tcfail140.hs:10:1) + +tcfail140.hs:12:10: error: + • Couldn't match expected type ‘Integer -> t’ + with actual type ‘Int’ + • The operator ‘f’ takes two arguments, + but its type ‘Int -> Int’ has only one + In the expression: 3 `f` 4 + In an equation for ‘rot’: rot xs = 3 `f` 4 + • Relevant bindings include + rot :: r -> t (bound at tcfail140.hs:12:1) + +tcfail140.hs:14:15: error: + • Couldn't match expected type ‘a -> b’ with actual type ‘Int’ + • The operator ‘f’ takes two arguments, + but its type ‘Int -> Int’ has only one + In the first argument of ‘map’, namely ‘(3 `f`)’ + In the expression: map (3 `f`) xs + • Relevant bindings include + xs :: [a] (bound at tcfail140.hs:14:5) + bot :: [a] -> [b] (bound at tcfail140.hs:14:1) + +tcfail140.hs:16:8: error: + • The constructor ‘Just’ should have 1 argument, but has been given none + • In the pattern: Just + In the expression: (\ Just x -> x) :: Maybe a -> a + In the expression: ((\ Just x -> x) :: Maybe a -> a) (Just 1) + +tcfail140.hs:19:1: error: + • Couldn't match expected type ‘t0 -> Bool’ with actual type ‘Int’ + • The equation(s) for ‘g’ have two arguments, + but its type ‘Int -> Int’ has only one diff --git a/testsuite/tests/typecheck/should_fail/tcfail146.stderr b/testsuite/tests/typecheck/should_fail/tcfail146.stderr index c1cce251a9..cf9341dfb3 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail146.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail146.stderr @@ -1,6 +1,6 @@ tcfail146.hs:7:22: error: - Constraint ‘SClass a’ used as a type - In the type ‘SClass a’ - In the definition of data constructor ‘SCon’ - In the data declaration for ‘SData’ + • Expected a type, but ‘SClass a’ has kind ‘Constraint’ + • In the type ‘SClass a’ + In the definition of data constructor ‘SCon’ + In the data declaration for ‘SData’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail147.stderr b/testsuite/tests/typecheck/should_fail/tcfail147.stderr index 68ec767eed..0c4db9a88e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail147.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail147.stderr @@ -1,7 +1,7 @@ -tcfail147.hs:7:19: +tcfail147.hs:7:19: error: Expecting one more argument to ‘XClass’ - Expected a type, but ‘XClass’ has kind ‘k0 -> Constraint’ + Expected a type, but ‘XClass’ has kind ‘* -> Constraint’ In the type ‘XClass’ In the definition of data constructor ‘XCon’ In the data declaration for ‘XData’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail151.stderr b/testsuite/tests/typecheck/should_fail/tcfail151.stderr index 3e675c2ef0..5e4dcfcf2f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail151.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail151.stderr @@ -6,3 +6,10 @@ tcfail151.hs:8:6: Expecting one more argument to ‘Name a’ Expected a constraint, but ‘Name a’ has kind ‘* -> Constraint’ In the data declaration for ‘Exp’ + +tcfail151.hs:8:30: + Expecting one more argument to ‘a’ + Expected a type, but ‘a’ has kind ‘* -> *’ + In the type ‘a’ + In the definition of data constructor ‘MkExp’ + In the data declaration for ‘Exp’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail159.stderr b/testsuite/tests/typecheck/should_fail/tcfail159.stderr index 48c4ceb406..e28363a707 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail159.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail159.stderr @@ -1,9 +1,7 @@ tcfail159.hs:9:11: error: - Couldn't match kind ‘*’ with ‘#’ - When matching types - t0 :: * - (# Int, Int #) :: # + Couldn't match a lifted type with an unlifted type + When matching the kind of ‘(# Int, Int #)’ In the pattern: ~(# p, q #) In a case alternative: ~(# p, q #) -> p In the expression: case h x of { ~(# p, q #) -> p } diff --git a/testsuite/tests/typecheck/should_fail/tcfail160.stderr b/testsuite/tests/typecheck/should_fail/tcfail160.stderr index 7e17d5c476..46a7640cf9 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail160.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail160.stderr @@ -1,5 +1,6 @@ -
-tcfail160.hs:7:8: error:
- The first argument of ‘T’ should have kind ‘* -> *’,
- but ‘Int’ has kind ‘*’
- In the type signature: g :: T Int
+ +tcfail160.hs:7:8: error: + • Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ + • In the first argument of ‘T’, namely ‘Int’ + In the type signature: + g :: T Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail161.stderr b/testsuite/tests/typecheck/should_fail/tcfail161.stderr index afe989206f..ce783bb5ab 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail161.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail161.stderr @@ -1,5 +1,6 @@ -
-tcfail161.hs:5:7: error:
- Expecting one more argument to ‘Maybe’
- Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’
- In the type signature: f :: [Maybe]
+ +tcfail161.hs:5:7: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type signature: + f :: [Maybe] diff --git a/testsuite/tests/typecheck/should_fail/tcfail181.stderr b/testsuite/tests/typecheck/should_fail/tcfail181.stderr index 6d483798b1..18309c10d1 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail181.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail181.stderr @@ -3,7 +3,7 @@ tcfail181.hs:17:9: error: Could not deduce (Monad m0) arising from a use of ‘foo’ from the context: Monad m bound by the inferred type of - wog :: Monad m => t -> Something (m Bool) e + wog :: Monad m => r -> Something (m Bool) e at tcfail181.hs:17:1-30 The type variable ‘m0’ is ambiguous These potential instances exist: diff --git a/testsuite/tests/typecheck/should_fail/tcfail184.stderr b/testsuite/tests/typecheck/should_fail/tcfail184.stderr index 8d349cd864..ed33280cf6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail184.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail184.stderr @@ -1,7 +1,7 @@ tcfail184.hs:8:19: Illegal polymorphic or qualified type: - forall a. Ord a => [a] -> [a] + forall a1. Ord a1 => [a1] -> [a1] Perhaps you intended to use RankNTypes or Rank2Types In the definition of data constructor ‘MkSwizzle’ In the newtype declaration for ‘Swizzle’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail195.stderr b/testsuite/tests/typecheck/should_fail/tcfail195.stderr index c1cb85abce..c044a37117 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail195.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail195.stderr @@ -1,5 +1,5 @@ -
-tcfail195.hs:6:3: error:
- Illegal polymorphic or qualified type: forall a. a
- In the definition of data constructor ‘Foo’
- In the data type declaration for ‘Foo’
+ +tcfail195.hs:6:3: error: + Illegal polymorphic or qualified type: forall a1. a1 + In the definition of data constructor ‘Foo’ + In the data type declaration for ‘Foo’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail196.stderr b/testsuite/tests/typecheck/should_fail/tcfail196.stderr index bcb2c32700..0dbbda8f13 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail196.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail196.stderr @@ -1,4 +1,5 @@ -
-tcfail196.hs:5:8: error:
- Illegal polymorphic or qualified type: forall a. a
- In the type signature: bar :: Num (forall a. a) => Int -> Int
+ +tcfail196.hs:5:8: error: + • Illegal polymorphic or qualified type: forall a1. a1 + • In the type signature: + bar :: Num (forall a. a) => Int -> Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail197.stderr b/testsuite/tests/typecheck/should_fail/tcfail197.stderr index 8b814870f2..802a77fa47 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail197.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail197.stderr @@ -1,5 +1,6 @@ -
-tcfail197.hs:5:8: error:
- Illegal polymorphic or qualified type: forall a. a
- GHC doesn't yet support impredicative polymorphism
- In the type signature: foo :: [forall a. a] -> Int
+ +tcfail197.hs:5:8: error: + • Illegal polymorphic or qualified type: forall a1. a1 + GHC doesn't yet support impredicative polymorphism + • In the type signature: + foo :: [forall a. a] -> Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail200.stderr b/testsuite/tests/typecheck/should_fail/tcfail200.stderr index 7570047d0c..c8a6fa94f2 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail200.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail200.stderr @@ -1,11 +1,7 @@ tcfail200.hs:5:15: error: - Couldn't match kind ‘*’ with ‘#’ - When matching types - t1 :: * - Int# :: # - In the expression: 1# - In the expression: (1#, 'c') - In an equation for ‘x’: x = (1#, 'c') - Relevant bindings include - x :: (t1, Char) (bound at tcfail200.hs:5:9) + • Couldn't match a lifted type with an unlifted type + When matching the kind of ‘Int#’ + • In the expression: 1# + In the expression: (1#, 'c') + In an equation for ‘x’: x = (1#, 'c') diff --git a/testsuite/tests/typecheck/should_fail/tcfail201.stderr b/testsuite/tests/typecheck/should_fail/tcfail201.stderr index 03efc08ff2..c19aa0c274 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail201.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail201.stderr @@ -3,7 +3,7 @@ tcfail201.hs:17:58: error: • Couldn't match expected type ‘a’ with actual type ‘HsDoc id0’ ‘a’ is a rigid type variable bound by the type signature for: - gfoldl' :: forall a (c :: * -> *). + gfoldl' :: forall (c :: * -> *) a. (forall a1 b. c (a1 -> b) -> a1 -> c b) -> (forall g. g -> c g) -> a -> c a at tcfail201.hs:15:12 diff --git a/testsuite/tests/typecheck/should_fail/tcfail212.stderr b/testsuite/tests/typecheck/should_fail/tcfail212.stderr index e14e62bddf..8eb7e6e57f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail212.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail212.stderr @@ -1,10 +1,22 @@ -
-tcfail212.hs:10:7: error:
- Expecting one more argument to ‘Maybe’
- The first argument of a tuple should have kind ‘*’,
- but ‘Maybe’ has kind ‘* -> *’
- In the type signature: f :: (Maybe, Either Int)
-
-tcfail212.hs:13:7: error:
- Expecting a lifted type, but ‘Int#’ is unlifted
- In the type signature: g :: (Int#, Int#)
+ +tcfail212.hs:10:7: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type signature: + f :: (Maybe, Either Int) + +tcfail212.hs:10:14: error: + • Expecting one more argument to ‘Either Int’ + Expected a type, but ‘Either Int’ has kind ‘* -> *’ + • In the type signature: + f :: (Maybe, Either Int) + +tcfail212.hs:13:7: error: + • Expecting a lifted type, but ‘Int#’ is unlifted + • In the type signature: + g :: (Int#, Int#) + +tcfail212.hs:13:13: error: + • Expecting a lifted type, but ‘Int#’ is unlifted + • In the type signature: + g :: (Int#, Int#) diff --git a/testsuite/tests/typecheck/should_fail/tcfail213.hs b/testsuite/tests/typecheck/should_fail/tcfail213.hs index c93c4ad999..f9e44f8cf4 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail213.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail213.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds #-} module ShouldFail where -import GHC.Prim( Constraint ) +import GHC.Exts( Constraint ) type family F a :: Constraint diff --git a/testsuite/tests/typecheck/should_fail/tcfail214.hs b/testsuite/tests/typecheck/should_fail/tcfail214.hs index 81162e678e..a88bbf2196 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail214.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail214.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds #-} module ShouldFail where -import GHC.Prim( Constraint ) +import GHC.Exts( Constraint ) type family F a :: Constraint diff --git a/testsuite/tests/typecheck/should_fail/tcfail217.stderr b/testsuite/tests/typecheck/should_fail/tcfail217.stderr index c51b97d8b5..0dc1a593b1 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail217.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail217.stderr @@ -1,4 +1,4 @@ -tcfail217.hs:7:1: +tcfail217.hs:7:1: error: Cycle in class declaration (via superclasses): A -> Aish -> A In the class declaration for ‘A’ diff --git a/testsuite/tests/typecheck/should_run/T10284.hs b/testsuite/tests/typecheck/should_run/T10284.hs index 8fc86351a0..c703284e51 100644 --- a/testsuite/tests/typecheck/should_run/T10284.hs +++ b/testsuite/tests/typecheck/should_run/T10284.hs @@ -1,17 +1,16 @@ {-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} import Control.Exception +import Data.Functor a :: Int a = 'a' main :: IO () main = do - catch (evaluate a) + catch (void $ evaluate a) (\e -> do let err = show (e :: TypeError) - putStrLn ("As expected, TypeError: " ++ err) - return "") - catch (evaluate a) + putStrLn ("As expected, TypeError: " ++ err)) + catch (void $ evaluate a) (\e -> do let err = show (e :: ErrorCall) - putStrLn ("Something went horribly wrong: " ++ err) - return "") + putStrLn ("Something went horribly wrong: " ++ err)) diff --git a/testsuite/tests/typecheck/should_run/T10284.stderr b/testsuite/tests/typecheck/should_run/T10284.stderr index c7133f0172..622e2bfa45 100644 --- a/testsuite/tests/typecheck/should_run/T10284.stderr +++ b/testsuite/tests/typecheck/should_run/T10284.stderr @@ -1,5 +1,5 @@ -T10284: T10284.hs:14:19: error: - Couldn't match expected type ‘()’ with actual type ‘Int’ - In the first argument of ‘evaluate’, namely ‘a’ - In the first argument of ‘catch’, namely ‘(evaluate a)’ +T10284: T10284.hs:7:5: error: + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the expression: 'a' + In an equation for ‘a’: a = 'a' (deferred type error) diff --git a/testsuite/tests/typecheck/should_run/T10284.stdout b/testsuite/tests/typecheck/should_run/T10284.stdout index 82f9518fc7..5d5c564c18 100644 --- a/testsuite/tests/typecheck/should_run/T10284.stdout +++ b/testsuite/tests/typecheck/should_run/T10284.stdout @@ -1,4 +1,4 @@ -As expected, TypeError: T10284.hs:6:5: error: +As expected, TypeError: T10284.hs:7:5: error: • Couldn't match expected type ‘Int’ with actual type ‘Char’ • In the expression: 'a' In an equation for ‘a’: a = 'a' diff --git a/testsuite/tests/typecheck/should_run/T7861.stdout b/testsuite/tests/typecheck/should_run/T7861.stdout index 6578f4363d..0f2678faac 100644 --- a/testsuite/tests/typecheck/should_run/T7861.stdout +++ b/testsuite/tests/typecheck/should_run/T7861.stdout @@ -1,2 +1 @@ "Hello 1" -"Hello 2" diff --git a/testsuite/tests/typecheck/should_run/tcrun043.hs b/testsuite/tests/typecheck/should_run/tcrun043.hs index 4a745cf0b0..78accb8604 100644 --- a/testsuite/tests/typecheck/should_run/tcrun043.hs +++ b/testsuite/tests/typecheck/should_run/tcrun043.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, TypeFamilies, ConstraintKinds #-} -import GHC.Prim ( Constraint ) +import GHC.Exts ( Constraint ) type Showish = Show diff --git a/testsuite/tests/typecheck/should_run/tcrun044.hs b/testsuite/tests/typecheck/should_run/tcrun044.hs index 029c4f9050..3e2f99381c 100644 --- a/testsuite/tests/typecheck/should_run/tcrun044.hs +++ b/testsuite/tests/typecheck/should_run/tcrun044.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds #-} import qualified Data.Set as S -import GHC.Prim ( Constraint ) +import GHC.Exts ( Constraint ) class RMonad m where type RMonadCtxt m a :: Constraint @@ -22,7 +22,7 @@ instance RMonad S.Set where main = do - print $ (returnR 1 ++ returnR 2) `bindR` + print $ (returnR 1 ++ returnR 2) `bindR` (\x -> returnR (x + 1) ++ returnR (x + 2)) - print $ (returnR 1 `S.union` returnR 2) `bindR` + print $ (returnR 1 `S.union` returnR 2) `bindR` (\x -> returnR (x + 1) `S.union` returnR (x + 2)) diff --git a/testsuite/tests/warnings/should_compile/T11077.stderr b/testsuite/tests/warnings/should_compile/T11077.stderr index 3cb2cba2d0..b2cfa61546 100644 --- a/testsuite/tests/warnings/should_compile/T11077.stderr +++ b/testsuite/tests/warnings/should_compile/T11077.stderr @@ -1,3 +1,3 @@ T11077.hs:3:1: warning: - Top-level binding with no type signature: foo :: forall t. t + Top-level binding with no type signature: foo :: forall r. r diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 2a5218e678..dc755706db 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -782,7 +782,7 @@ ppTyVar "a" = "alphaTyVar" ppTyVar "b" = "betaTyVar" ppTyVar "c" = "gammaTyVar" ppTyVar "s" = "deltaTyVar" -ppTyVar "o" = "openAlphaTyVar" +ppTyVar "o" = "levity1TyVar, openAlphaTyVar" ppTyVar _ = error "Unknown type var" ppType :: Ty -> String diff --git a/utils/haddock b/utils/haddock -Subproject f4ef2548954bedf26674adc7a06574e718898d1 +Subproject bd61e8e22b11d1c4f03dd6ddc45a794e3362d45 |