diff options
| author | Max Bolingbroke <batterseapower@hotmail.com> | 2011-09-06 17:22:47 +0100 |
|---|---|---|
| committer | Max Bolingbroke <batterseapower@hotmail.com> | 2011-09-06 20:48:41 +0100 |
| commit | 9729fe7c3e54597ccf29c43c8c8ad0eaa2402ced (patch) | |
| tree | 1ad67ec5008c8f30a7a8a01fa44cb35b9ce619d4 /compiler | |
| parent | b98267adc04266e0001019fb17746be570cc79ae (diff) | |
| download | haskell-9729fe7c3e54597ccf29c43c8c8ad0eaa2402ced.tar.gz | |
Implement -XConstraintKind
Basically as documented in http://hackage.haskell.org/trac/ghc/wiki/KindFact,
this patch adds a new kind Constraint such that:
Show :: * -> Constraint
(?x::Int) :: Constraint
(Int ~ a) :: Constraint
And you can write *any* type with kind Constraint to the left of (=>):
even if that type is a type synonym, type variable, indexed type or so on.
The following (somewhat related) changes are also made:
1. We now box equality evidence. This is required because we want
to give (Int ~ a) the *lifted* kind Constraint
2. For similar reasons, implicit parameters can now only be of
a lifted kind. (?x::Int#) => ty is now ruled out
3. Implicit parameter constraints are now allowed in superclasses
and instance contexts (this just falls out as OK with the new
constraint solver)
Internally the following major changes were made:
1. There is now no PredTy in the Type data type. Instead
GHC checks the kind of a type to figure out if it is a predicate
2. There is now no AClass TyThing: we represent classes as TyThings
just as a ATyCon (classes had TyCons anyway)
3. What used to be (~) is now pretty-printed as (~#). The box
constructor EqBox :: (a ~# b) -> (a ~ b)
4. The type LCoercion is used internally in the constraint solver
and type checker to represent coercions with free variables
of type (a ~ b) rather than (a ~# b)
Diffstat (limited to 'compiler')
121 files changed, 2580 insertions, 2326 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 14ef2c5876..e892316bf8 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -44,7 +44,8 @@ module BasicTypes( Boxity(..), isBoxed, - TupCon(..), tupleParens, + TupleSort(..), tupleSortBoxity, boxityNormalTupleSort, + tupleParens, OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc, @@ -168,9 +169,10 @@ early in the hierarchy), but also in HsSyn. \begin{code} newtype IPName name = IPName name -- ?x - deriving( Eq, Ord, Data, Typeable ) - -- Ord is used in the IP name cache finite map - -- (used in HscTypes.OrigIParamCache) + deriving( Eq, Data, Typeable ) + +instance Functor IPName where + fmap = mapIPName ipNameName :: IPName name -> name ipNameName (IPName n) = n @@ -284,7 +286,7 @@ instance Outputable TopLevelFlag where %************************************************************************ %* * - Top-level/not-top level flag + Boxity flag %* * %************************************************************************ @@ -382,14 +384,25 @@ pprSafeOverlap False = empty %************************************************************************ \begin{code} -data TupCon = TupCon Boxity Arity - -instance Eq TupCon where - (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2 - -tupleParens :: Boxity -> SDoc -> SDoc -tupleParens Boxed p = parens p -tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") +data TupleSort + = BoxedTuple + | UnboxedTuple + | FactTuple + deriving( Eq, Data, Typeable ) + +tupleSortBoxity :: TupleSort -> Boxity +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity FactTuple = Boxed + +boxityNormalTupleSort :: Boxity -> TupleSort +boxityNormalTupleSort Boxed = BoxedTuple +boxityNormalTupleSort Unboxed = UnboxedTuple + +tupleParens :: TupleSort -> SDoc -> SDoc +tupleParens BoxedTuple p = parens p +tupleParens FactTuple p = parens p -- The user can't write fact tuples directly, we overload the (,,) syntax +tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") \end{code} %************************************************************************ diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 6e02ed9f0a..c773d58a75 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -47,11 +47,11 @@ import TyCon import Class import Name import Var -import BasicTypes import Outputable import Unique import ListSetOps import Util +import BasicTypes import FastString import Module @@ -535,7 +535,7 @@ mkDataCon name declared_infix -- source-language arguments. We add extra ones for the -- dictionary arguments right here. full_theta = eqSpecPreds eq_spec ++ theta - real_arg_tys = mkPredTys full_theta ++ orig_arg_tys + real_arg_tys = full_theta ++ orig_arg_tys real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts -- Representation arguments and demands @@ -551,8 +551,9 @@ eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] mk_dict_strict_mark :: PredType -> HsBang -mk_dict_strict_mark pred | isStrictPred pred = HsStrict - | otherwise = HsNoBang +mk_dict_strict_mark pred | isEqPred pred = HsUnpack + | otherwise = HsNoBang + \end{code} \begin{code} @@ -658,7 +659,7 @@ dataConStrictMarks = dcStrictMarks -- | Strictness of evidence arguments to the wrapper function dataConExStricts :: DataCon -> [HsBang] -- Usually empty, so we don't bother to cache this -dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc) +dataConExStricts dc = map mk_dict_strict_mark (dataConTheta dc) -- | Source-level arity of the data constructor dataConSourceArity :: DataCon -> Arity @@ -746,7 +747,7 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ - mkFunTys (mkPredTys theta) $ + mkFunTys theta $ mkFunTys arg_tys $ res_ty @@ -841,11 +842,16 @@ dataConCannotMatch tys con | all isTyVarTy tys = False -- Also common | otherwise = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2) - | EqPred ty1 ty2 <- theta ] + | (ty1, ty2) <- concatMap (predEqs . predTypePredTree) theta ] where dc_tvs = dataConUnivTyVars con theta = dataConTheta con subst = zipTopTvSubst dc_tvs tys + + -- TODO: could gather equalities from superclasses too + predEqs (EqPred ty1 ty2) = [(ty1, ty2)] + predEqs (TuplePred ts) = concatMap predEqs ts + predEqs _ = [] \end{code} %************************************************************************ @@ -935,4 +941,4 @@ computeRep stricts tys where (_tycon, _tycon_args, arg_dc, arg_tys) = deepSplitProductType "unbox_strict_arg_ty" ty -\end{code} +\end{code}
\ No newline at end of file diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 7993b05deb..5ad9b0ec90 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -293,20 +293,23 @@ mkDataConIds wrap_name wkr_name data_con -- extra constraints where necessary. wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs - ev_tys = mkPredTys other_theta + ev_tys = other_theta wrap_ty = mkForAllTys wrap_tvs $ mkFunTys ev_tys $ mkFunTys orig_arg_tys $ res_ty ----------- Wrappers for algebraic data types -------------- alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info - alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + alg_wrap_info = noCafIdInfo `setArityInfo` wrap_arity -- It's important to specify the arity, so that partial -- applications are treated as values `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` wrap_unf `setStrictnessInfo` Just wrap_sig + -- We need to get the CAF info right here because TidyPgm + -- does not tidy the IdInfo of implicit bindings (like the wrapper) + -- so it not make sure that the CAF info is sane all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info) @@ -339,6 +342,8 @@ mkDataConIds wrap_name wkr_name data_con `mkVarApps` ex_tvs `mkCoApps` map (mkReflCo . snd) eq_spec `mkVarApps` reverse rep_ids + -- Dont box the eq_spec coercions since they are + -- marked as HsUnpack by mk_dict_strict_mark (ev_args,i2) = mkLocals 1 ev_tys (id_args,i3) = mkLocals i2 orig_arg_tys @@ -481,7 +486,7 @@ mkDictSelId no_unf name clas the_arg_id = arg_ids !! val_index pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 $ mkPredTy pred + dict_id = mkTemplateLocal 1 pred arg_ids = mkTemplateLocalsNum 2 arg_tys rhs = mkLams tyvars (Lam dict_id rhs_body) @@ -838,7 +843,7 @@ mkDictFunId dfun_name tvs theta clas tys mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type mkDictFunTy tvs theta clas tys - = mkSigmaTy tvs theta (mkDictTy clas tys) + = mkSigmaTy tvs theta (mkClassPred clas tys) \end{code} @@ -1038,7 +1043,7 @@ voidArgId -- :: State# RealWorld coercionTokenId :: Id -- :: () ~ () coercionTokenId -- Used to replace Coercion terms when we go to STG = pcMiscPrelId coercionTokenName - (mkTyConApp eqPredPrimTyCon [unitTy, unitTy]) + (mkTyConApp eqPrimTyCon [unitTy, unitTy]) noCafIdInfo \end{code} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 94ad72dade..db24f7508b 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -40,7 +40,7 @@ module Name ( mkSystemName, mkSystemNameAt, mkInternalName, mkDerivedInternalName, mkSystemVarName, mkSysTvName, - mkFCallName, mkIPName, + mkFCallName, mkTickBoxOpName, mkExternalName, mkWiredInName, @@ -302,14 +302,6 @@ mkTickBoxOpName :: Unique -> String -> Name mkTickBoxOpName uniq str = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, n_occ = mkVarOcc str, n_loc = noSrcSpan } - --- | Make the name of an implicit parameter -mkIPName :: Unique -> OccName -> Name -mkIPName uniq occ - = Name { n_uniq = getKeyFastInt uniq, - n_sort = Internal, - n_occ = occ, - n_loc = noSrcSpan } \end{code} \begin{code} diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 3ae9b54085..3b1b41f5e5 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -51,7 +51,7 @@ module OccName ( mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, @@ -541,12 +541,12 @@ isDerivedOccName occ = \begin{code} mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, - mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, - mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkGenD, mkGenR, mkGenRCo, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc + mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have @@ -555,8 +555,7 @@ mkWorkerOcc = mk_simple_deriv varName "$w" 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 -mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon +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 -- for datacons from classes mkDictOcc = mk_simple_deriv varName "$d" @@ -624,8 +623,8 @@ mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 -> OccName -- ^ Class, e.g. @Ord@ -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ -mkSuperDictSelOcc index cls_occ - = mk_deriv varName "$p" (show index ++ occNameString cls_occ) +mkSuperDictSelOcc index cls_tc_occ + = mk_deriv varName "$p" (show index ++ occNameString cls_tc_occ) mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' -> OccName -- ^ Local name, e.g. @sat@ @@ -751,24 +750,43 @@ tidyOccName in_scope occ@(OccName occ_sp fs) %************************************************************************ \begin{code} -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName -mkTupleOcc ns bx ar = OccName ns (mkFastString str) +mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName +mkTupleOcc ns sort ar = OccName ns (mkFastString str) where -- no need to cache these, the caching is done in the caller -- (TysWiredIn.mk_tuple) - str = case bx of - Boxed -> '(' : commas ++ ")" - Unboxed -> '(' : '#' : commas ++ "#)" + str = case sort of + UnboxedTuple -> '(' : '#' : commas ++ "#)" + BoxedTuple -> '(' : commas ++ ")" + FactTuple -> '(' : commas ++ ")" + -- Cute hack: reuse the standard tuple OccNames (and hence code) + -- for fact tuples, but give them different Uniques so they are not equal. + -- + -- You might think that this will go wrong because isTupleOcc_maybe won't + -- be able to tell the difference between boxed tuples and fact tuples. BUT: + -- 1. Fact tuples never occur directly in user code, so it doesn't matter + -- that we can't detect them in Orig OccNames originating from the user + -- programs (or those built by setRdrNameSpace used on an Exact tuple Name) + -- 2. Interface files have a special representation for tuple *occurrences* + -- in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case + -- alternatives). Thus we don't rely on the OccName to figure out what kind + -- of tuple an occurrence was trying to use in these situations. + -- 3. We *don't* represent tuple data type declarations specially, so those + -- are still turned into wired-in names via isTupleOcc_maybe. But that's OK + -- because we don't actually need to declare fact tuples thanks to this hack. + -- + -- So basically any OccName like (,,) flowing to isTupleOcc_maybe will always + -- refer to the standard boxed tuple. Cool :-) commas = take (ar-1) (repeat ',') -isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity) +isTupleOcc_maybe :: OccName -> Maybe (NameSpace, TupleSort, Arity) -- Tuples are special, because there are so many of them! isTupleOcc_maybe (OccName ns fs) = case unpackFS fs of - '(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest) - '(':',':rest -> Just (ns, Boxed, 2 + count_commas rest) - _other -> Nothing + '(':'#':',':rest -> Just (ns, UnboxedTuple, 2 + count_commas rest) + '(':',':rest -> Just (ns, BoxedTuple, 2 + count_commas rest) + _other -> Nothing where count_commas (',':rest) = 1 + count_commas rest count_commas _ = 0 diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index b89d55e62b..c39f7145b0 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -99,6 +99,10 @@ data RealSrcLoc {-# UNPACK #-} !Int -- line number, begins at 1 {-# UNPACK #-} !Int -- column number, begins at 1 +#ifdef DEBUG + deriving Show -- debugging +#endif + data SrcLoc = RealSrcLoc {-# UNPACK #-}!RealSrcLoc | UnhelpfulLoc FastString -- Just a general indication diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index 3ebf95023b..87c22aa63b 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -34,9 +34,7 @@ module Unique ( newTagUnique, -- Used in CgCase initTyVarUnique, - isTupleKey, - - -- ** Making built-in uniques + -- ** Making built-in uniques -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] @@ -47,7 +45,7 @@ module Unique ( mkPreludeTyConUnique, mkPreludeClassUnique, mkPArrDataConUnique, - mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, mkBuiltinUnique, @@ -105,8 +103,6 @@ getKeyFastInt :: Unique -> FastInt -- for Var incrUnique :: Unique -> Unique deriveUnique :: Unique -> Int -> Unique newTagUnique :: Unique -> Char -> Unique - -isTupleKey :: Unique -> Bool \end{code} @@ -311,9 +307,9 @@ Allocation of unique supply characters: mkAlphaTyVarUnique :: Int -> Unique mkPreludeClassUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique -mkTupleTyConUnique :: Boxity -> Int -> Unique +mkTupleTyConUnique :: TupleSort -> Int -> Unique mkPreludeDataConUnique :: Int -> Unique -mkTupleDataConUnique :: Boxity -> Int -> Unique +mkTupleDataConUnique :: TupleSort -> Int -> Unique mkPrimOpIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique mkPArrDataConUnique :: Int -> Unique @@ -327,8 +323,9 @@ mkPreludeClassUnique i = mkUnique '2' i -- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. mkPreludeTyConUnique i = mkUnique '3' (3*i) -mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) -mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) +mkTupleTyConUnique BoxedTuple a = mkUnique '4' (3*a) +mkTupleTyConUnique UnboxedTuple a = mkUnique '5' (3*a) +mkTupleTyConUnique FactTuple a = mkUnique 'k' (3*a) -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that @@ -337,13 +334,9 @@ mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) -- representation). mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic -mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) -mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) - --- This one is used for a tiresome reason --- to improve a consistency-checking error check in the renamer -isTupleKey u = case unpkUnique u of - (tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8' +mkTupleDataConUnique BoxedTuple a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) +mkTupleDataConUnique UnboxedTuple a = mkUnique '8' (2*a) +mkTupleDataConUnique FactTuple a = mkUnique 'h' (2*a) mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index 5cbf89b932..3319fdfe1e 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -32,7 +32,7 @@ module Var ( -- * The main data type and synonyms - Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId, + Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId, -- ** Taking 'Var's apart varName, varUnique, varType, @@ -98,11 +98,12 @@ type DFunId = Id -- A dictionary function type EvId = Id -- Term-level evidence: DictId or IpId type DictId = EvId -- A dictionary variable type IpId = EvId -- A term-level implicit parameter +type EqVar = EvId -- Boxed equality evidence type TyVar = Var type CoVar = Id -- A coercion variable is simply an Id - -- variable of kind @ty1 ~ ty2@. Hence its - -- 'varType' is always @PredTy (EqPred t1 t2)@ + -- variable of kind @#@. Its + -- 'varType' is always @ty1 ~# ty2@ \end{code} %************************************************************************ diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 04f7acb68c..66eeb34c5f 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -1091,15 +1091,9 @@ getTyDescription ty AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon - PredTy sty -> getPredTyDescription sty ForAllTy _ ty -> getTyDescription ty } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other - -getPredTyDescription :: PredType -> String -getPredTyDescription (ClassP cl _) = getOccString cl -getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) -getPredTyDescription (EqPred _ _) = "Type equality" \end{code} diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 12624ba2b6..712263a156 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -855,18 +855,12 @@ getTyDescription ty AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon - PredTy sty -> getPredTyDescription sty ForAllTy _ ty -> getTyDescription ty } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other -getPredTyDescription :: PredType -> String -getPredTyDescription (ClassP cl _) = getOccString cl -getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) -getPredTyDescription (EqPred {}) = "Type equality" - -------------------------------------- -- CmmInfoTable-related things -------------------------------------- diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 7bc82cf607..db3a108784 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -20,6 +20,7 @@ import Bag import Literal import DataCon import TysWiredIn +import TysPrim import Var import VarEnv import VarSet @@ -27,13 +28,12 @@ import Name import Id import PprCore import ErrUtils +import Coercion import SrcLoc import Kind import Type import TypeRep -import Coercion import TyCon -import Class import BasicTypes import StaticFlags import ListSetOps @@ -281,10 +281,24 @@ lintCoreExpr (Let (Rec pairs) body) bndrs = map fst pairs (_, dups) = removeDups compare bndrs -lintCoreExpr e@(App fun arg) - = do { fun_ty <- lintCoreExpr fun - ; addLoc (AnExpr e) $ - lintCoreArg fun_ty arg } +lintCoreExpr e@(App _ _) + | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments + -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds, + -- we should do this properly + , Just dc <- isDataConWorkId_maybe x + , dc == eqBoxDataCon + , [Type arg_ty1, Type arg_ty2, co_e] <- args + = do arg_kind1 <- lintType arg_ty1 + arg_kind2 <- lintType arg_ty2 + unless (arg_kind1 `eqKind` arg_kind2) + (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2)) + + lintCoreArg (mkCoercionType arg_ty1 arg_ty2 `mkFunTy` mkEqPred (arg_ty1, arg_ty2)) co_e + | otherwise + = do { fun_ty <- lintCoreExpr fun + ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } + where + (fun, args) = collectArgs e lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ @@ -339,7 +353,7 @@ lintCoreExpr (Type ty) lintCoreExpr (Coercion co) = do { co' <- lintInCo co ; let Pair ty1 ty2 = coercionKind co' - ; return (mkPredTy $ EqPred ty1 ty2) } + ; return (mkCoercionType ty1 ty2) } \end{code} %************************************************************************ @@ -646,6 +660,10 @@ lintCoercion (ForAllCo v co) ; return (ForAllTy v s, ForAllTy v t) } 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 ; return (coVarKind cv) } @@ -716,7 +734,9 @@ lintType ty@(FunTy t1 t2) = lint_ty_app ty (tyConKind funTyCon) [t1,t2] lintType ty@(TyConApp tc tys) - | tc `hasKey` eqPredPrimTyConKey -- See Note [The (~) TyCon] in TysPrim + | tc `hasKey` eqPrimTyConKey -- See Note [The ~# TyCon] in TysPrim + = lint_prim_eq_pred ty tys + | tc `hasKey` eqTyConKey = lint_eq_pred ty tys | tyConHasKind tc = lint_ty_app ty (tyConKind tc) tys @@ -727,20 +747,6 @@ lintType (ForAllTy tv ty) = do { lintTyBndrKind tv ; addInScopeVar tv (lintType ty) } -lintType ty@(PredTy (ClassP cls tys)) - = lint_ty_app ty (tyConKind (classTyCon cls)) tys - -lintType (PredTy (IParam _ p_ty)) - = lintType p_ty - -lintType ty@(PredTy (EqPred t1 t2)) - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; unless (k1 `eqKind` k2) - (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:") - , nest 2 (ppr ty) ])) - ; return unliftedTypeKind } - ---------------- lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind lint_ty_app ty k tys @@ -748,7 +754,21 @@ lint_ty_app ty k tys ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks } lint_eq_pred :: Type -> [OutType] -> LintM Kind -lint_eq_pred ty arg_tys +lint_eq_pred ty arg_tys = case arg_tys of + [ty1, ty2] -> do { k1 <- lintType ty1 + ; k2 <- lintType ty2 + ; unless (k1 `eqKind` k2) + (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:") + , nest 2 (ppr ty) ])) + ; return constraintKind } + [ty1] -> do { k1 <- lintType ty1; + return (k1 `mkFunTy` constraintKind) } + [] -> do { return (typeKind ty) } + _ -> failWithL (ptext (sLit "Oversaturated (~) type") <+> ppr ty) + + +lint_prim_eq_pred :: Type -> [OutType] -> LintM Kind +lint_prim_eq_pred ty arg_tys | [ty1,ty2] <- arg_tys = do { k1 <- lintType ty1 ; k2 <- lintType ty2 @@ -756,7 +776,7 @@ lint_eq_pred ty arg_tys (ptext (sLit "Mismatched arg kinds:") <+> ppr ty) ; return unliftedTypeKind } | otherwise - = failWithL (ptext (sLit "Unsaturated (~) type") <+> ppr ty) + = failWithL (ptext (sLit "Unsaturated ~# type") <+> ppr ty) ---------------- check_co_app :: Coercion -> Kind -> [OutType] -> LintM () @@ -926,7 +946,7 @@ lookupIdInScope id oneTupleDataConId :: Id -- Should not happen -oneTupleDataConId = dataConWorkId (tupleCon Boxed 1) +oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1) checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id @@ -1127,6 +1147,14 @@ mkStrictMsg binder ] +mkEqBoxKindErrMsg :: Type -> Type -> Message +mkEqBoxKindErrMsg ty1 ty2 + = vcat [ptext (sLit "Kinds don't match in type arguments of Eq#:"), + hang (ptext (sLit "Arg type 1:")) + 4 (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)), + hang (ptext (sLit "Arg type 2:")) + 4 (ppr ty2 <+> dcolon <+> ppr (typeKind ty2))] + mkKindErrMsg :: TyVar -> Type -> Message mkKindErrMsg tyvar arg_ty = vcat [ptext (sLit "Kinds don't match in type application:"), diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 8de2c4ff0b..be1d7ae93c 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -51,6 +51,7 @@ import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substC import OptCoercion ( optCoercion ) import PprCore ( pprCoreBindings, pprRules ) +import PrelNames ( eqBoxDataConKey ) import Module ( Module ) import VarSet import VarEnv @@ -768,6 +769,28 @@ InlVanilla. The WARN is just so I can see if it happens a lot. %* * %************************************************************************ +Note [Optimise coercion boxes agressively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The simple expression optimiser has special cases for 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. + + 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. + +We do this for two reasons: + + 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) + + 2. The test T4356 fails Lint because it creates a coercion between types + of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this + inlining agressively we can collapse away the intermediate coercion between + these two types and hence pass Lint again. (This is a sort of a hack.) + \begin{code} simpleOptExpr :: CoreExpr -> CoreExpr -- Do simple optimisation on an expression @@ -775,6 +798,9 @@ simpleOptExpr :: CoreExpr -> CoreExpr -- inline non-recursive bindings that are used only once, -- or where the RHS is trivial -- +-- We also inline bindings that bind a Eq# box: see +-- See Note [Optimise coercion boxes agressively]. +-- -- The result is NOT guaranteed occurence-analysed, becuase -- in (let x = y in ....) we substitute for x; so y's occ-info -- may change radically @@ -849,10 +875,19 @@ simple_opt_expr' subst expr (subst', Just bind) -> Let bind (simple_opt_expr subst' body) go lam@(Lam {}) = go_lam [] subst lam - go (Case e b ty as) = Case (go e) b' (substTy subst ty) - (map (go_alt subst') as) - where - (subst', b') = subst_opt_bndr subst b + go (Case e b ty as) + | [(DataAlt dc, [cov], e_alt)] <- as -- See Note [Optimise coercion boxes agressively] + , dc `hasKey` eqBoxDataConKey + , (Var fun, [Type _, Type _, Coercion co]) <- collectArgs e' + , isDataConWorkId fun + , isDeadBinder b + = simple_opt_expr (extendCvSubst subst cov co) e_alt + | otherwise + = Case (go e) b' (substTy subst ty) + (map (go_alt subst') as) + where + e' = go e + (subst', b') = subst_opt_bndr subst b ---------------------- go_alt subst (con, bndrs, rhs) @@ -944,8 +979,14 @@ maybe_substitute subst b r safe_to_inline :: OccInfo -> Bool safe_to_inline (IAmALoopBreaker {}) = False safe_to_inline IAmDead = True - safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || exprIsTrivial r - safe_to_inline NoOccInfo = exprIsTrivial r + safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial + safe_to_inline NoOccInfo = trivial + + trivial | exprIsTrivial r = True + | (Var fun, _args) <- collectArgs r + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` eqBoxDataConKey = True -- See Note [Optimise coercion boxes agressively] + | otherwise = False ---------------------- subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar) diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index b6bc7d4b37..214615866d 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -13,6 +13,12 @@ module MkCore ( mkIntegerExpr, mkFloatExpr, mkDoubleExpr, mkCharExpr, mkStringExpr, mkStringExprFS, + + -- * Constructing/deconstructing implicit parameter boxes + mkIPUnbox, mkIPBox, + + -- * Constructing/deconstructing equality evidence boxes + mkEqBox, -- * Constructing general big tuples -- $big_tuples @@ -45,7 +51,7 @@ module MkCore ( #include "HsVersions.h" import Id -import Var ( EvVar, setTyVarUnique ) +import Var ( IpId, EvVar, setTyVarUnique ) import CoreSyn import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) @@ -55,19 +61,21 @@ import HscTypes import TysWiredIn import PrelNames -import TcType ( mkSigmaTy ) +import IParam ( ipCoAxiom ) +import TcType ( mkSigmaTy, evVarPred ) import Type import Coercion import TysPrim import DataCon ( DataCon, dataConWorkId ) import IdInfo ( vanillaIdInfo, setStrictnessInfo, setArityInfo ) import Demand -import Name +import Name hiding ( varName ) import Outputable import FastString import UniqSupply import BasicTypes import Util ( notNull, zipEqual ) +import Pair import Constants import Data.Char ( ord ) @@ -151,7 +159,7 @@ mk_val_app fun arg arg_ty res_ty -- fragmet of it as the fun part of a 'mk_val_app'. mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred = mkWildValBinder (mkPredTy pred) +mkWildEvBinder pred = mkWildValBinder pred -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site. Do not use it at @@ -286,6 +294,29 @@ mkStringExprFS str safeChar c = ord c >= 1 && ord c <= 0x7F \end{code} +\begin{code} + +mkIPBox :: IPName IpId -> CoreExpr -> CoreExpr +mkIPBox ipx e = e `Cast` mkSymCo (mkAxInstCo (ipCoAxiom ip) [ty]) + where x = ipNameName ipx + Just (ip, ty) = getIPPredTy_maybe (evVarPred x) + -- NB: don't use the DataCon work id because we don't generate code for it + +mkIPUnbox :: IPName IpId -> CoreExpr +mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty] + where x = ipNameName ipx + Just (ip, ty) = getIPPredTy_maybe (evVarPred x) + +\end{code} + +\begin{code} + +mkEqBox :: Coercion -> CoreExpr +mkEqBox co = Var (dataConWorkId eqBoxDataCon) `mkTyApps` [ty1, ty2] `App` Coercion co + where Pair ty1 ty2 = coercionKind co + +\end{code} + %************************************************************************ %* * \subsection{Tuple constructors} @@ -360,7 +391,7 @@ mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) mkCoreTup :: [CoreExpr] -> CoreExpr mkCoreTup [] = Var unitDataConId mkCoreTup [c] = c -mkCoreTup cs = mkConApp (tupleCon Boxed (length cs)) +mkCoreTup cs = mkConApp (tupleCon BoxedTuple (length cs)) (map (Type . exprType) cs ++ cs) -- | Build a big tuple holding the specified variables @@ -444,7 +475,7 @@ mkSmallTupleSelector [var] should_be_the_same_var _ scrut mkSmallTupleSelector vars the_var scrut_var scrut = ASSERT( notNull vars ) Case scrut scrut_var (idType the_var) - [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] + [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)] \end{code} \begin{code} @@ -501,7 +532,7 @@ mkSmallTupleCase [var] body _scrut_var scrut = bindNonRec var scrut body mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement? - = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)] + = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)] \end{code} %************************************************************************ diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 71c07c313a..940e058e3d 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -14,7 +14,6 @@ import CoreSyn import HscTypes import TyCon -- import Class --- import TysPrim( eqPredPrimTyCon ) import TypeRep import Type import PprExternalCore () -- Instances @@ -228,8 +227,6 @@ make_ty' (TyConApp tc ts) = make_tyConApp tc ts -- expose the representation in interface files, which definitely isn't right. -- Maybe CoreTidy should know whether to expand newtypes or not? -make_ty' (PredTy p) = make_ty (predTypeRep p) - make_tyConApp :: TyCon -> [Type] -> C.Ty make_tyConApp tc ts = foldl C.Tapp (C.Tcon (qtc tc)) diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index cf9292408f..94f3e04a39 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -143,7 +143,7 @@ ppr_expr add_par expr@(App {}) -- Notice that we print the *worker* -- for tuples in paren'd format. Just dc | saturated && isTupleTyCon tc - -> tupleParens (tupleTyConBoxity tc) pp_tup_args + -> tupleParens (tupleTyConSort tc) pp_tup_args where tc = dataConTyCon dc saturated = val_args `lengthIs` idArity f @@ -241,7 +241,7 @@ pprCoreAlt (con, args, rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc ppr_case_pat (DataAlt dc) args | isTupleTyCon tc - = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) + = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args))) where ppr_bndr = pprBndr CaseBind tc = dataConTyCon dc diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index 735f7dd43b..120b67654f 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -510,7 +510,6 @@ lkT env ty m go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv - go (PredTy {}) = panic "lkT" -- Dealt with by coreView ----------------- xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a @@ -525,7 +524,6 @@ xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME e |>> xtBndr env tv f } xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc |>> xtList (xtT env) tys f } -xtT _ (PredTy {}) _ _ = panic "xtT" -- Dealt with by coreView fdT :: (a -> b -> b) -> TypeMap a -> b -> b fdT _ EmptyTM = \z -> z diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 59c102f884..49d9f3de1c 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -690,7 +690,7 @@ tidy_pat (PArrPat ps ty) (mkPArrTy ty) tidy_pat (TuplePat ps boxity ty) - = unLoc $ mkPrefixConPat (tupleCon boxity arity) + = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) (map tidy_lpat ps) ty where arity = length ps diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 2c5a3c820b..6cbda9e09e 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -185,18 +185,16 @@ dsImpSpecs imp_specs ; let (spec_binds, spec_rules) = unzip spec_prs ; return (concatOL spec_binds, spec_rules) } -combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind] +combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] -- Top-level bindings can include coercion bindings, but not via superclasses -- See Note [Top-level evidence] combineEvBinds [] val_prs = [Rec val_prs] -combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs +combineEvBinds (NonRec b r : bs) val_prs | isId b = combineEvBinds bs ((b,r):val_prs) | otherwise = NonRec b r : combineEvBinds bs val_prs -combineEvBinds (LetEvBind (Rec prs) : bs) val_prs +combineEvBinds (Rec prs : bs) val_prs = combineEvBinds bs (prs ++ val_prs) -combineEvBinds (CaseEvBind x _ _ : _) _ - = pprPanic "topEvBindPairs" (ppr x) \end{code} Note [Top-level evidence] diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 7f798f81f7..d7d5e7023b 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -135,7 +135,7 @@ coreCaseTuple uniqs scrut_var vars body coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body = Case (Var scrut_var) scrut_var (exprType body) - [(DataAlt (tupleCon Boxed 2), [var1, var2], body)] + [(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)] \end{code} \begin{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 7eceeb247f..c73940e5ee 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -11,8 +11,8 @@ lower levels it is preserved with @let@/@letrec@s). \begin{code} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, - DsEvBind(..), AutoScc(..) + dsHsWrapper, dsTcEvBinds, dsEvBinds, + AutoScc(..) ) where #include "HsVersions.h" @@ -34,15 +34,16 @@ import CoreUnfold import CoreFVs import Digraph +import TyCon ( isTupleTyCon, tyConDataCons_maybe ) import TcType import Type -import Coercion +import Coercion hiding (substCo) +import TysWiredIn ( eqBoxDataCon, tupleCon ) import CostCentre import Module import Id -import TyCon ( tyConDataCons ) import Class -import DataCon ( dataConRepType ) +import DataCon ( dataConWorkId ) import Name ( localiseName ) import MkId ( seqId ) import Var @@ -133,7 +134,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts rhs = addAutoScc auto_scc global $ wrap_fn $ -- Usually the identity mkLams tyvars $ mkLams dicts $ - wrapDsEvBinds ds_ev_binds $ + mkCoreLets ds_ev_binds $ Let core_bind $ Var local @@ -161,7 +162,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts tup_expr = mkBigCoreVarTup locals tup_ty = exprType tup_expr poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - wrapDsEvBinds ds_ev_binds $ + mkCoreLets ds_ev_binds $ Let core_bind $ tup_expr locals = map abe_mono exports @@ -187,28 +188,11 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts concatOL export_binds_s) } -------------------------------------- -data DsEvBind - = LetEvBind -- Dictionary or coercion - CoreBind -- recursive or non-recursive - - | CaseEvBind -- Coercion binding by superclass selection - -- Desugars to case d of d { K _ g _ _ _ -> ... } - DictId -- b The dictionary - AltCon -- K Its constructor - [CoreBndr] -- _ g _ _ _ The binders in the alternative - -wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr -wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds - where - body_ty = exprType body - wrap_one (LetEvBind b) body = Let b body - wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)] - -dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind] +dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this dsTcEvBinds (EvBinds bs) = dsEvBinds bs -dsEvBinds :: Bag EvBind -> DsM [DsEvBind] +dsEvBinds :: Bag EvBind -> DsM [CoreBind] dsEvBinds bs = return (map dsEvGroup sccs) where sccs :: [SCC EvBind] @@ -223,45 +207,60 @@ dsEvBinds bs = return (map dsEvGroup sccs) free_vars_of :: EvTerm -> [EvVar] free_vars_of (EvId v) = [v] free_vars_of (EvCast v co) = v : varSetElems (tyCoVarsOfCo co) - free_vars_of (EvCoercion co) = varSetElems (tyCoVarsOfCo co) + free_vars_of (EvCoercionBox co) = varSetElems (tyCoVarsOfCo co) free_vars_of (EvDFunApp _ _ vs) = vs + free_vars_of (EvTupleSel v _) = [v] + free_vars_of (EvTupleMk vs) = vs free_vars_of (EvSuperClass d _) = [d] -dsEvGroup :: SCC EvBind -> DsEvBind -dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n))) - | isCoVar co_var -- An equality superclass - = ASSERT( null other_data_cons ) - CaseEvBind dict (DataAlt data_con) bndrs - where - (cls, tys) = getClassPredTys (evVarPred dict) - (data_con:other_data_cons) = tyConDataCons (classTyCon cls) - (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys) - (arg_tys, _) = splitFunTys rho - bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..]) - ++ map mkWildValBinder arg_tys - mk_wild_pred (p, i) | i==n = ASSERT( p `eqPred` (coVarPred co_var)) - co_var - | otherwise = mkWildEvBinder p - +dsEvGroup :: SCC EvBind -> CoreBind + dsEvGroup (AcyclicSCC (EvBind v r)) - = LetEvBind (NonRec v (dsEvTerm r)) + = NonRec v (dsEvTerm r) dsEvGroup (CyclicSCC bs) - = LetEvBind (Rec (map ds_pair bs)) + = Rec (map ds_pair bs) where ds_pair (EvBind v r) = (v, dsEvTerm r) +dsLCoercion :: LCoercion -> (Coercion -> CoreExpr) -> CoreExpr +dsLCoercion co k = foldr go (k (substCo subst co)) eqvs_covs + where + -- We use the same uniques for the EqVars and the CoVars, and just change + -- the type. So the CoVars shadow the EqVars + -- + -- NB: DON'T try to cheat and not substitute into the LCoercion to change the + -- types of the free variables: -ddump-ds will panic if you do this since it + -- runs before we substitute CoVar occurrences out for their binding sites. + eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2) + | eqv <- varSetElems (coVarsOfCo co) + , let (ty1, ty2) = getEqPredTys (evVarPred eqv)] + + subst = extendCvSubstList (mkEmptySubst (mkInScopeSet (tyCoVarsOfCo co))) + [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] + + go (eqv, cov) e = Case (Var eqv) (mkWildValBinder (varType eqv)) (exprType e) + [(DataAlt eqBoxDataCon, [cov], e)] + dsEvTerm :: EvTerm -> CoreExpr dsEvTerm (EvId v) = Var v -dsEvTerm (EvCast v co) = Cast (Var v) co +dsEvTerm (EvCast v co) = dsLCoercion co $ Cast (Var v) dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars -dsEvTerm (EvCoercion co) = Coercion co +dsEvTerm (EvCoercionBox co) = dsLCoercion co mkEqBox +dsEvTerm (EvTupleSel v n) + = ASSERT( isTupleTyCon tc ) + Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')] + where + (tc, tys) = splitTyConApp (evVarPred v) + Just [dc] = tyConDataCons_maybe tc + v' = v `setVarType` ty_want + xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after + (tys_before, ty_want:tys_after) = splitAt n tys +dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs + where dc = tupleCon FactTuple (length vs) + tys = map varType vs dsEvTerm (EvSuperClass d n) - = ASSERT( isClassPred (classSCTheta cls !! n) ) - -- We can only select *dictionary* superclasses - -- in terms. Equality superclasses are dealt with - -- in dsEvGroup, where they can generate a case expression - Var sc_sel_id `mkTyApps` tys `App` Var d + = Var sc_sel_id `mkTyApps` tys `App` Var d where sc_sel_id = classSCSelId cls n -- Zero-indexed (cls, tys) = getClassPredTys (evVarPred d) @@ -736,12 +735,14 @@ dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) dsHsWrapper WpHole = return (\e -> e) dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty)) dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds - ; return (wrapDsEvBinds ds_ev_binds) } + ; return (mkCoreLets ds_ev_binds) } dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 ; k2 <- dsHsWrapper c2 ; return (k1 . k2) } -dsHsWrapper (WpCast co) = return (\e -> Cast e co) +dsHsWrapper (WpCast co) + = return (\e -> dsLCoercion co (Cast e)) dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e) dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e) -dsHsWrapper (WpEvApp evtrm) = return (\e -> App e (dsEvTerm evtrm)) +dsHsWrapper (WpEvApp evtrm) + = return (\e -> App e (dsEvTerm evtrm)) \end{code} diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 9adbac181f..bdacc9f07e 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -263,7 +263,7 @@ boxResult result_ty _ -> [] return_result state anss - = mkConApp (tupleCon Unboxed (2 + length extra_result_tys)) + = mkConApp (tupleCon UnboxedTuple (2 + length extra_result_tys)) (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) ++ (state : anss)) @@ -327,9 +327,9 @@ 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) + ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity) (realWorldStatePrimTy : ls) - the_alt = ( DataAlt (tupleCon Unboxed arity) + the_alt = ( DataAlt (tupleCon UnboxedTuple arity) , (state_id : args_ids) , the_rhs ) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 743874d8e4..6b476a6ca3 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -86,14 +86,14 @@ dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ip_binds ev_binds) body = do { ds_ev_binds <- dsTcEvBinds ev_binds - ; let inner = wrapDsEvBinds ds_ev_binds body + ; let inner = mkCoreLets ds_ev_binds body -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where ds_ip_bind (L _ (IPBind n e)) body = do e' <- dsLExpr e - return (Let (NonRec (ipNameName n) e') body) + return (Let (NonRec (ipNameName n) (mkIPBox n e')) body) ------------------------- ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr @@ -139,7 +139,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) body1 binds - ; return (wrapDsEvBinds ds_ev_binds body2) } + ; return (mkCoreLets ds_ev_binds body2) } dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn , fun_tick = tick, fun_infix = inf }) body @@ -218,7 +218,7 @@ dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] -dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) +dsExpr (HsIPVar ip) = return (mkIPUnbox ip) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit @@ -312,7 +312,7 @@ dsExpr (ExplicitTuple tup_args boxity) -- The reverse is because foldM goes left-to-right ; return $ mkCoreLams lam_vars $ - mkConApp (tupleCon boxity (length tup_args)) + mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) (map (Type . exprType) args ++ args) } dsExpr (HsSCC cc expr) = do @@ -550,21 +550,21 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) -- Tediously wrap the application in a cast -- Note [Update for GADTs] - wrapped_rhs | null eq_spec = rhs - | otherwise = mkLHsWrap (WpCast wrap_co) rhs - wrap_co = mkTyConAppCo tycon [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys] + wrap_co = mkTyConAppCo tycon + [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ] lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of Just co' -> co' Nothing -> mkReflCo ty - wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var)) - | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] + wrap_subst = mkVarEnv [ (tv, mkSymCo (mkEqVarLCo eq_var)) + | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds , pat_args = PrefixCon $ map nlVarPat arg_ids , pat_ty = in_ty } + ; let wrapped_rhs | null eq_spec = rhs + | otherwise = mkLHsWrap (WpCast wrap_co) rhs ; return (mkSimpleMatch [pat] wrapped_rhs) } \end{code} diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 1d94cf68ee..4f78a4534e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -312,14 +312,16 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now -- the selector Ids, not to fresh names (Trac #5410) -- do { cxt1 <- repContext cxt - ; inst_ty1 <- repPredTy (HsClassP cls tys) + ; cls_tcon <- repTy (HsTyVar cls) + ; cls_tys <- repLTys tys + ; inst_ty1 <- repTapps cls_tcon cls_tys ; binds1 <- rep_binds binds ; ats1 <- repLAssocFamInst ats ; decls <- coreList decQTyConName (ats1 ++ binds1) ; repInst cxt1 inst_ty1 decls } ; return (loc, dec) } where - (tvs, cxt, L _ cls, tys) = splitHsInstDeclTy ty + Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport name typ (CImport cc s ch cis))) @@ -420,7 +422,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty) = go (eq_pred : cxt) subst rest where loc = getLoc ty - eq_pred = L loc (HsEqualP (L loc (HsTyVar data_tv)) ty) + eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty) is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty @@ -450,8 +452,11 @@ repDerivs (Just ctxt) where rep_deriv :: LHsType Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form - rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls - rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other) + rep_deriv ty + | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty) + = lookupOcc cls + | otherwise + = notHandled "Non-H98 deriving clause" (ppr ty) ------------------------------------------------------- @@ -602,30 +607,24 @@ repContext ctxt = do -- represent a type predicate -- -repLPred :: LHsPred Name -> DsM (Core TH.PredQ) +repLPred :: LHsType Name -> DsM (Core TH.PredQ) repLPred (L _ p) = repPred p -repPred :: HsPred Name -> DsM (Core TH.PredQ) -repPred (HsClassP cls tys) +repPred :: HsType Name -> DsM (Core TH.PredQ) +repPred ty + | Just (cls, tys) <- splitHsClassTy_maybe ty = do cls1 <- lookupOcc cls tys1 <- repLTys tys tys2 <- coreList typeQTyConName tys1 repClassP cls1 tys2 -repPred (HsEqualP tyleft tyright) +repPred (HsEqTy tyleft tyright) = do tyleft1 <- repLTy tyleft tyright1 <- repLTy tyright repEqualP tyleft1 tyright1 -repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p) - -repPredTy :: HsPred Name -> DsM (Core TH.TypeQ) -repPredTy (HsClassP cls tys) - = do - tcon <- repTy (HsTyVar cls) - tys1 <- repLTys tys - repTapps tcon tys1 -repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error" +repPred ty + = notHandled "Exotic predicate type" (ppr ty) -- yield the representation of a list of types -- @@ -669,18 +668,18 @@ repTy (HsPArrTy t) = do t1 <- repLTy t tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 -repTy (HsTupleTy Boxed tys) = do +repTy (HsTupleTy (HsBoxyTuple kind) tys) + | kind `eqKind` liftedTypeKind = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTupleTy Unboxed tys) = do +repTy (HsTupleTy HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) repTapps tcon tys1 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy t) = repLTy t -repTy (HsPredTy pred) = repPredTy pred repTy (HsKindSig t k) = do t1 <- repLTy t k1 <- repKind k diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 06d677f886..798b8ba386 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -22,7 +22,6 @@ module DsMonad ( UniqSupply, newUniqueSupply, getDOptsDs, getGhcModeDs, doptDs, woptDs, dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon, - dsLookupClass, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, @@ -47,10 +46,8 @@ import HscTypes import Bag import DataCon import TyCon -import Class import Id import Module -import Var import Outputable import SrcLoc import Type @@ -231,13 +228,7 @@ duplicateLocalDs old_local newPredVarDs :: PredType -> DsM Var newPredVarDs pred - | isEqPred pred - = do { uniq <- newUnique; - ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co_pv")) - kind = mkPredTy pred - ; return (mkCoVar name kind) } - | otherwise - = newSysLocalDs (mkPredTy pred) + = newSysLocalDs pred newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDs = mkSysLocalM (fsLit "ds") @@ -326,10 +317,6 @@ dsLookupTyCon name dsLookupDataCon :: Name -> DsM DataCon dsLookupDataCon name = tyThingDataCon <$> dsLookupGlobal name - -dsLookupClass :: Name -> DsM Class -dsLookupClass name - = tyThingClass <$> dsLookupGlobal name \end{code} \begin{code} diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 292ebaec82..462137ade8 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -662,7 +662,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id -- A vanilla tuple pattern simply gets its type from its sub-patterns mkVanillaTuplePat pats box - = TuplePat pats box (mkTupleTy box (map hsLPatType pats)) + = TuplePat pats box (mkTupleTy (boxityNormalTupleSort box) (map hsLPatType pats)) -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [Id] -> LHsExpr Id diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 25dab9370c..d2a56d1848 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -37,6 +37,7 @@ import Maybes import Util import Name import Outputable +import BasicTypes ( boxityNormalTupleSort ) import FastString import Control.Monad( when ) @@ -515,7 +516,7 @@ tidy1 _ (TuplePat pats boxity ty) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty + tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 _ (LitPat lit) @@ -911,17 +912,17 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- equating different ways of writing a coercion) wrap WpHole WpHole = True wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpCast c) (WpCast c') = coreEqCoercion c c' - wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2 - wrap (WpTyApp t) (WpTyApp t') = eqType t t' + wrap (WpCast co) (WpCast co') = co `coreEqCoercion` 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 -- if it seems useful (lams and lets) wrap _ _ = False --------- ev_term :: EvTerm -> EvTerm -> Bool - ev_term (EvId a) (EvId b) = a==b - ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b + ev_term (EvId a) (EvId b) = a==b + ev_term (EvCoercionBox a) (EvCoercionBox b) = coreEqCoercion a b ev_term _ _ = False --------- diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index d84b9013cc..adaa48e18c 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -25,6 +25,7 @@ import DataCon import TcType import DsMonad import DsUtils +import MkCore ( mkCoreLets ) import Util ( all2, takeList, zipEqual ) import ListSetOps ( runs ) import Id @@ -140,7 +141,7 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor = do { ds_ev_binds <- dsTcEvBinds bind ; return (wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) - . wrapDsEvBinds ds_ev_binds, + . mkCoreLets ds_ev_binds, eqn { eqn_pats = conArgPats arg_tys args ++ pats }) } -- Choose the right arg_vars in the right order for this group diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index d553e5d63c..eea42bf981 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -413,6 +413,7 @@ Library TcCanonical TcSMonad Class + IParam Coercion FamInstEnv FunDeps diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 4891509ce1..340899fa8a 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -34,7 +34,6 @@ import Linker import DataCon import Type import qualified Unify as U -import TypeRep -- I know I know, this is cheating import Var import TcRnMonad import TcType @@ -1138,14 +1137,6 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) -------------------------------------------------------------------------------- -- Restore Class predicates out of a representation type dictsView :: Type -> Type --- dictsView ty = ty -dictsView (FunTy (TyConApp tc_dict args) ty) - | Just c <- tyConClass_maybe tc_dict - = FunTy (PredTy (ClassP c args)) (dictsView ty) -dictsView ty - | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty - , Just c <- tyConClass_maybe tc_dict - = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2] dictsView ty = ty diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index f84776546a..afb6933e30 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -7,7 +7,7 @@ This module converts Template Haskell syntax into HsSyn \begin{code} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, - convertToHsType, convertToHsPred, + convertToHsType, thRdrNameGuesses ) where import HsSyn as Hs @@ -59,10 +59,6 @@ convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) convertToHsType loc t = initCvt loc $ wrapMsg "type" t $ cvtType t -convertToHsPred :: SrcSpan -> TH.Pred -> Either Message (LHsPred RdrName) -convertToHsPred loc t - = initCvt loc $ wrapMsg "type" t $ cvtPred t - ------------------------------------------------------------------- newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } -- Push down the source location; @@ -190,8 +186,8 @@ cvtDec (ClassD ctxt cl tvs fds decs) cvtDec (InstanceD ctxt ty decs) = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs ; ctxt' <- cvtContext ctxt - ; L loc pred' <- cvtPredTy ty - ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc $ HsPredTy pred' + ; L loc ty' <- cvtType ty + ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') } cvtDec (ForeignD ford) @@ -356,7 +352,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (Just cs') } where cvt_one c = do { c' <- tconName c - ; returnL $ HsPredTy $ HsClassP c' [] } + ; returnL $ HsTyVar c' } cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName)) cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') } @@ -783,27 +779,18 @@ cvt_tv (TH.KindedTV nm ki) cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } -cvtPred :: TH.Pred -> CvtM (LHsPred RdrName) +cvtPred :: TH.Pred -> CvtM (LHsType RdrName) cvtPred (TH.ClassP cla tys) = do { cla' <- if isVarName cla then tName cla else tconName cla ; tys' <- mapM cvtType tys - ; returnL $ HsClassP cla' tys' + ; mk_apps (HsTyVar cla') tys' } cvtPred (TH.EqualP ty1 ty2) = do { ty1' <- cvtType ty1 ; ty2' <- cvtType ty2 - ; returnL $ HsEqualP ty1' ty2' + ; returnL $ HsEqTy ty1' ty2' } -cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName) -cvtPredTy ty - = do { (head, tys') <- split_ty_app ty - ; case head of - ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' } - VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' } - _ -> failWith (ptext (sLit "Malformed predicate") <+> - text (TH.pprint ty)) } - cvtType :: TH.Type -> CvtM (LHsType RdrName) cvtType ty = do { (head_ty, tys') <- split_ty_app ty @@ -812,18 +799,18 @@ cvtType ty | length tys' == n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) - else returnL (HsTupleTy Boxed tys') + else returnL (HsTupleTy (HsBoxyTuple liftedTypeKind) tys') | n == 1 -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys' UnboxedTupleT n | length tys' == n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) - else returnL (HsTupleTy Unboxed tys') + else returnL (HsTupleTy HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' @@ -848,10 +835,11 @@ cvtType ty _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty)) } - where - mk_apps head_ty [] = returnL head_ty - mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty - ; mk_apps (HsAppTy head_ty' ty) tys } + +mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName) +mk_apps head_ty [] = returnL head_ty +mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty + ; mk_apps (HsAppTy head_ty' ty) tys } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) split_ty_app ty = go ty [] @@ -992,8 +980,8 @@ isBuiltInOcc ctxt_ns occ go_tuple _ _ = Nothing tup_name n - | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n) - | otherwise = Name.getName (tupleCon Boxed n) + | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n) + | otherwise = Name.getName (tupleCon BoxedTuple n) -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> String -> OccName.OccName diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 4a57727785..7bc74e295b 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -432,9 +432,6 @@ instance (OutputableBndr id) => Outputable (IPBind id) where %************************************************************************ \begin{code} --- A HsWrapper is an expression with a hole in it --- We need coercions to have concrete form so that we can zonk them - data HsWrapper = WpHole -- The identity coercion @@ -444,8 +441,8 @@ data HsWrapper -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) - | WpCast Coercion -- A cast: [] `cast` co - -- Guaranteed not the identity coercion + | WpCast LCoercion -- A cast: [] `cast` co + -- Guaranteed not the identity coercion -- Evidence abstraction and application -- (both dictionaries and coercions) @@ -502,24 +499,24 @@ data EvBind = EvBind EvVar EvTerm data EvTerm = EvId EvId -- Term-level variable-to-variable bindings - -- (no coercion variables! they come via EvCoercion) + -- (no coercion variables! they come via EvCoercionBox) - | EvCoercion Coercion -- Coercion bindings + | EvCoercionBox LCoercion -- (Boxed) coercion bindings - | EvCast EvVar Coercion -- d |> co + | EvCast EvVar LCoercion -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvVar] + [Type] [EvVar] + + | EvTupleSel EvId Int -- n'th component of the tuple + + | EvTupleMk [EvId] -- tuple built from this stuff | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no -- selector Id. We count up from _0_ deriving( Data, Typeable) - -evVarTerm :: EvVar -> EvTerm -evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v) - | otherwise = EvId v \end{code} Note [EvBinds/EvTerm] @@ -560,7 +557,7 @@ mkWpEvApps :: [EvTerm] -> HsWrapper mkWpEvApps args = mk_co_app_fn WpEvApp args mkWpEvVarApps :: [EvVar] -> HsWrapper -mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs) +mkWpEvVarApps vs = mkWpEvApps (map EvId vs) mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids @@ -630,11 +627,14 @@ instance Outputable EvBindsVar where instance Outputable EvBind where ppr (EvBind v e) = ppr v <+> equals <+> ppr e + -- 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`")) <+> pprParendCo co - ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvCoercionBox co) = ptext (sLit "CO") <+> ppr co + ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) + ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 9d441b707d..995c66068c 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -425,7 +425,7 @@ ppr_expr (SectionR op expr) pp_infixly v = sep [pprHsInfix v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) - = tupleParens boxity (fcat (ppr_tup_args exprs)) + = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs)) where ppr_tup_args [] = [] ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 71dfe1d969..5c404a6ae8 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -252,7 +252,7 @@ pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) -pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) pprPat (ConPatIn con details) = pprUserCon con details pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index f8b7be47af..89a002b63c 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -11,9 +11,8 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, - HsExplicitFlag(..), + HsTupleSort(..), HsExplicitFlag(..), HsContext, LHsContext, - HsPred(..), LHsPred, HsQuasiQuote(..), LBangType, BangType, HsBang(..), @@ -25,7 +24,10 @@ module HsTypes ( hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName, hsTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, - splitHsInstDeclTy, splitHsFunType, + splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, + splitHsForAllTy, splitLHsForAllTy, + splitHsClassTy_maybe, splitLHsClassTy_maybe, + splitHsFunType, splitHsAppTys, mkHsAppTys, -- Type place holder @@ -37,7 +39,7 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import NameSet( FreeVars ) +import NameSet ( FreeVars ) import Type import HsDoc import BasicTypes @@ -124,14 +126,7 @@ This is the syntax for types as seen in type signatures. \begin{code} type LHsContext name = Located (HsContext name) -type HsContext name = [LHsPred name] - -type LHsPred name = Located (HsPred name) - -data HsPred name = HsClassP name [LHsType name] -- class constraint - | HsEqualP (LHsType name) (LHsType name)-- equality constraint - | HsIParam (IPName name) (LHsType name) - deriving (Data, Typeable) +type HsContext name = [LHsType name] type LHsType name = Located (HsType name) @@ -156,7 +151,7 @@ data HsType name | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] - | HsTupleTy Boxity + | HsTupleTy HsTupleSort [LHsType name] -- Element types (length gives arity) | HsOpTy (LHsType name) (Located name) (LHsType name) @@ -165,12 +160,11 @@ data HsType name -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - | HsPredTy (HsPred name) -- Only used in the type of an instance - -- declaration, eg. Eq [a] -> Eq a - -- ^^^^ - -- HsPredTy - -- Note no need for location info on the - -- Enclosed HsPred; the one on the type will do + | HsIParamTy (IPName name) -- (?x :: ty) + (LHsType name) -- Implicit parameters as they occur in contexts + + | HsEqTy (LHsType name) -- ty1 ~ ty2 + (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule | HsKindSig (LHsType name) -- (ty :: kind) Kind -- A type with a kind signature @@ -191,6 +185,10 @@ data HsType name deriving (Data, Typeable) +data HsTupleSort = HsUnboxedTuple + | HsBoxyTuple Kind -- Either a Constraint or normal tuple: resolved during type checking + deriving (Data, Typeable) + data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable) data ConDeclField name -- Record fields have Haddoc docs on them @@ -223,7 +221,7 @@ mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty -mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty +mk_forall_ty exp tvs ty = HsForAllTy exp tvs (noLoc []) ty -- Even if tvs is empty, we still make a HsForAll! -- In the Implicit case, this signals the place to do implicit quantification -- In the Explicit case, it prevents implicit quantification @@ -305,22 +303,53 @@ mkHsAppTys fun_ty (arg_ty:arg_tys) -- Add noLocs for inner nodes of the application; -- they are never used -splitHsInstDeclTy - :: OutputableBndr name - => LHsType name - -> ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name]) - -- Split up an instance decl type, returning the pieces +splitHsInstDeclTy_maybe :: HsType name + -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) +splitHsInstDeclTy_maybe ty + = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty) -splitHsInstDeclTy linst_ty@(L _ inst_ty) - = case inst_ty of - HsParTy ty -> splitHsInstDeclTy ty - HsForAllTy _ tvs cxt ty -> split_tau tvs (unLoc cxt) ty - _ -> split_tau [] [] linst_ty - -- The type vars should have been computed by now, even if they were implicit +splitLHsInstDeclTy_maybe + :: LHsType name + -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name]) + -- Split up an instance decl type, returning the pieces +splitLHsInstDeclTy_maybe inst_ty = do + let (tvs, cxt, ty) = splitLHsForAllTy inst_ty + (cls, tys) <- splitLHsClassTy_maybe ty + return (tvs, cxt, cls, tys) + +splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name) +splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty) + +splitLHsForAllTy + :: LHsType name + -> ([LHsTyVarBndr name], HsContext name, LHsType name) +splitLHsForAllTy poly_ty + = case unLoc poly_ty of + HsParTy ty -> splitLHsForAllTy ty + HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty) + _ -> ([], [], poly_ty) + -- The type vars should have been computed by now, even if they were implicit + +splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name]) +splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty) + +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 - split_tau tvs cxt (L loc (HsPredTy (HsClassP cls tys))) = (tvs, cxt, L loc cls, tys) - split_tau tvs cxt (L _ (HsParTy ty)) = split_tau tvs cxt ty - split_tau _ _ _ = pprPanic "splitHsInstDeclTy" (ppr inst_ty) + checkl (L l ty) args = case ty of + HsTyVar t -> Just (L l t, args) + HsAppTy l r -> checkl l (r:args) + HsOpTy l tc r -> checkl (fmap HsTyVar tc) (l:r:args) + HsParTy t -> checkl t args + HsKindSig ty _ -> checkl ty args + _ -> Nothing -- Splits HsType into the (init, last) parts -- Breaks up any parens in the result type: @@ -348,15 +377,6 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name _) = ppr name ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind] -instance OutputableBndr name => Outputable (HsPred name) where - ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys) - ppr (HsEqualP t1 t2) = hsep [pprLHsType t1, ptext (sLit "~"), - pprLHsType t2] - ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] - -pprLHsType :: OutputableBndr name => LHsType name -> SDoc -pprLHsType = pprParendHsType . unLoc - pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll exp tvs cxt | show_forall = forall_part <+> pprHsContext (unLoc cxt) @@ -369,16 +389,9 @@ pprHsForAll exp tvs cxt pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext [] = empty -pprHsContext [L _ pred] - | noParenHsPred pred = ppr pred <+> darrow +pprHsContext [L _ pred] = ppr pred <+> darrow pprHsContext cxt = ppr_hs_context cxt <+> darrow -noParenHsPred :: HsPred name -> Bool --- c.f. TypeRep.noParenPred -noParenHsPred (HsClassP {}) = True -noParenHsPred (HsEqualP {}) = True -noParenHsPred (HsIParam {}) = False - ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc ppr_hs_context [] = empty ppr_hs_context cxt = parens (interpp'SP cxt) @@ -446,14 +459,21 @@ ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds ppr_mono_ty _ (HsTyVar name) = ppr name ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 -ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys) +ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) + where std_con = case con of + HsUnboxedTuple -> UnboxedTuple + HsBoxyTuple _ -> BoxedTuple ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPredTy pred) = ppr pred +ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty1 <+> char '~' <+> ppr_mono_lty pREC_OP ty2 + ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index cd95571964..3451e4ce6c 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -173,15 +173,15 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id mkHsWrap co_fn e | isIdHsWrapper co_fn = e | otherwise = HsWrap co_fn e -mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id +mkHsWrapCo :: LCoercion -> HsExpr id -> HsExpr id mkHsWrapCo (Refl _) e = e mkHsWrapCo co e = mkHsWrap (WpCast co) e -mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo :: LCoercion -> LHsExpr id -> LHsExpr id mkLHsWrapCo (Refl _) e = e mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e) -coToHsWrapper :: Coercion -> HsWrapper +coToHsWrapper :: LCoercion -> HsWrapper coToHsWrapper (Refl _) = idHsWrapper coToHsWrapper co = WpCast co @@ -189,7 +189,7 @@ mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat co_fn p ty -mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo :: LCoercion -> Pat id -> Type -> Pat id mkHsWrapPatCo (Refl _) pat _ = pat mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 26b3d9c886..3df9f1a338 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -651,23 +651,16 @@ instance Binary HsBang where 2 -> do return HsUnpack _ -> do return HsUnpackFailed -instance Binary Boxity where - put_ bh Boxed = putByte bh 0 - put_ bh Unboxed = putByte bh 1 +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh FactTuple = putByte bh 2 get bh = do - h <- getByte bh - case h of - 0 -> do return Boxed - _ -> do return Unboxed - -instance Binary TupCon where - put_ bh (TupCon ab ac) = do - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - return (TupCon ab ac) + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return FactTuple instance Binary RecFlag where put_ bh Recursive = do @@ -896,24 +889,22 @@ instance Binary IfaceType where putByte bh 3 put_ bh ag put_ bh ah - put_ bh (IfacePredTy aq) = do - putByte bh 5 - put_ bh aq - + -- Simple compression for common cases of TyConApp put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6 put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7 put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8 put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty } -- Unit tuple and pairs - put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10 - put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 } + put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10 + put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 } -- Kind cases put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12 put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13 put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 + put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 21 put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases @@ -936,21 +927,20 @@ instance Binary IfaceType where 3 -> do ag <- get bh ah <- get bh return (IfaceFunTy ag ah) - 5 -> do ap <- get bh - return (IfacePredTy ap) - + -- Now the special cases for TyConApp 6 -> return (IfaceTyConApp IfaceIntTc []) 7 -> return (IfaceTyConApp IfaceCharTc []) 8 -> return (IfaceTyConApp IfaceBoolTc []) 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) } - 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) []) - 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) } + 10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) + 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) } 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc []) 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc []) 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) + 21 -> return (IfaceTyConApp IfaceConstraintKindTc []) 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } @@ -969,9 +959,11 @@ instance Binary IfaceTyCon where put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 put_ bh IfaceUbxTupleKindTc = putByte bh 9 put_ bh IfaceArgTypeKindTc = putByte bh 10 + put_ bh IfaceConstraintKindTc = putByte bh 15 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } - put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } + put_ bh (IfaceIPTc n) = do { putByte bh 13; put_ bh n } + put_ bh (IfaceAnyTc k) = do { putByte bh 14; put_ bh k } get bh = do h <- getByte bh @@ -986,9 +978,11 @@ instance Binary IfaceTyCon where 8 -> return IfaceUnliftedTypeKindTc 9 -> return IfaceUbxTupleKindTc 10 -> return IfaceArgTypeKindTc + 15 -> return IfaceConstraintKindTc 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } 12 -> do { ext <- get bh; return (IfaceTc ext) } - _ -> do { k <- get bh; return (IfaceAnyTc k) } + 13 -> do { n <- get bh; return (IfaceIPTc n) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } instance Binary IfaceCoCon where put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } @@ -998,6 +992,7 @@ instance Binary IfaceCoCon where put_ bh IfaceTransCo = putByte bh 4 put_ bh IfaceInstCo = putByte bh 5 put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + put_ bh (IfaceIPCoAx ip) = do { putByte bh 7; put_ bh ip } get bh = do h <- getByte bh @@ -1008,34 +1003,8 @@ instance Binary IfaceCoCon where 3 -> return IfaceSymCo 4 -> return IfaceTransCo 5 -> return IfaceInstCo - _ -> do { d <- get bh; return (IfaceNthCo d) } - -instance Binary IfacePredType where - put_ bh (IfaceClassP aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (IfaceIParam ac ad) = do - putByte bh 1 - put_ bh ac - put_ bh ad - put_ bh (IfaceEqPred ac ad) = do - putByte bh 2 - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (IfaceClassP aa ab) - 1 -> do ac <- get bh - ad <- get bh - return (IfaceIParam ac ad) - 2 -> do ac <- get bh - ad <- get bh - return (IfaceEqPred ac ad) - _ -> panic ("get IfacePredType " ++ show h) + 6 -> do { d <- get bh; return (IfaceNthCo d) } + _ -> do { ip <- get bh; return (IfaceIPCoAx ip) } ------------------------------------------------------------------------- -- IfaceExpr and friends @@ -1094,6 +1063,10 @@ instance Binary IfaceExpr where putByte bh 13 put_ bh m put_ bh ix + put_ bh (IfaceTupId aa ab) = do + putByte bh 14 + put_ bh aa + put_ bh ab get bh = do h <- getByte bh case h of @@ -1135,6 +1108,9 @@ instance Binary IfaceExpr where 13 -> do m <- get bh ix <- get bh return (IfaceTick m ix) + 14 -> do aa <- get bh + ab <- get bh + return (IfaceTupId aa ab) _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceConAlt where diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 7f2ade20cd..4f61197fb6 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -8,8 +8,8 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, - TcMethInfo, buildClass, - distinctAbstractTyConRhs, totallyAbstractTyConRhs, + TcMethInfo, buildClass, + distinctAbstractTyConRhs, totallyAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs, newImplicitBinder ) where @@ -216,7 +216,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ - tyVarsOfPred pred `intersectVarSet` arg_tyvars + tyVarsOfType pred `intersectVarSet` arg_tyvars \end{code} @@ -236,10 +236,9 @@ buildClass :: Bool -- True <=> do not include unfoldings -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec +buildClass no_unf tycon_name tvs sc_theta fds ats sig_stuff tc_isrec = do { traceIf (text "buildClass") - ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc - ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc + ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc -- The class name is the 'parent' for this datacon, not its tycon, -- because one should import the class to get the binding for -- the datacon @@ -250,7 +249,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec -- Build the selector id and default method id -- Make selectors for the superclasses - ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) + ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc) [1..length sc_theta] ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names] @@ -262,13 +261,12 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; let use_newtype = isSingleton arg_tys && not (any isEqPred sc_theta) + ; let use_newtype = isSingleton arg_tys -- Use a newtype if the data constructor -- (a) has exactly one value field -- i.e. exactly one operation or superclass taken together - -- (b) it's of lifted type - -- (NB: for (b) don't look at the classes in sc_theta, because - -- they are part of the knot! Hence isEqPred.) + -- (b) that value is of lifted type (which they always are, because + -- we box equality superclasses) -- See note [Class newtypes and equality predicates] -- We treat the dictionary superclasses as ordinary arguments. @@ -278,7 +276,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec args = sc_sel_names ++ op_names op_tys = [ty | (_,_,ty) <- sig_stuff] op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = map mkPredTy sc_theta ++ op_tys + arg_tys = sc_theta ++ op_tys rec_tycon = classTyCon rec_clas ; dict_con <- buildDataCon datacon_name @@ -296,7 +294,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec then mkNewTyConRhs tycon_name rec_tycon dict_con else return (mkDataTyConRhs [dict_con]) - ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind + ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) constraintKind ; tycon = mkClassTyCon tycon_name clas_kind tvs rhs rec_clas tc_isrec @@ -310,7 +308,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec -- type] ; atTyCons = [tycon | ATyCon tycon <- ats] - ; result = mkClass class_name tvs fds + ; result = mkClass tvs fds sc_theta sc_sel_ids atTyCons op_items tycon } @@ -344,4 +342,3 @@ Moreover, Here we can't use a newtype either, even though there is only one field, because equality predicates are unboxed, and classes are boxed. - diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index cf8a57ca75..0b28525148 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -2,10 +2,10 @@ \begin{code} module IfaceEnv ( - newGlobalBinder, newIPName, newImplicitBinder, + newGlobalBinder, newImplicitBinder, lookupIfaceTop, lookupOrig, lookupOrigNameCache, extendNameCache, - newIfaceName, newIfaceNames, + newIPName, newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar, tcIfaceTick, @@ -23,6 +23,7 @@ import TcRnMonad import TysWiredIn import HscTypes import TyCon +import Type import DataCon import Var import Name @@ -31,9 +32,9 @@ import Module import UniqFM import FastString import UniqSupply -import BasicTypes import SrcLoc import MkId +import BasicTypes import Outputable import Exception ( evaluate ) @@ -148,21 +149,19 @@ lookupOrig mod occ in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}} -newIPName :: IPName OccName -> TcRnIf m n (IPName Name) -newIPName occ_name_ip = +newIPName :: FastString -> TcRnIf m n (IPName Name) +newIPName ip = updNameCache $ \name_cache -> - let - ipcache = nsIPs name_cache - key = occ_name_ip -- Ensures that ?x and %x get distinct Names - in - case Map.lookup key ipcache of - Just name_ip -> (name_cache, name_ip) - Nothing -> (new_ns, name_ip) - where - (uniq, us') = takeUniqFromSupply (nsUniqs name_cache) - name_ip = mapIPName (mkIPName uniq) occ_name_ip - new_ipcache = Map.insert key name_ip ipcache - new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache} + let ipcache = nsIPs name_cache + in case Map.lookup ip ipcache of + Just name_ip -> (name_cache, name_ip) + Nothing -> (new_ns, name_ip) + where + (us_here, us') = splitUniqSupply (nsUniqs name_cache) + tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here + name_ip = mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u + new_ipcache = Map.insert ip name_ip ipcache + new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache} \end{code} %************************************************************************ @@ -174,16 +173,18 @@ newIPName occ_name_ip = \begin{code} lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache _ mod occ + -- Don't need to mention gHC_UNIT here because it is explicitly + -- included in TysWiredIn.wiredInTyCons | mod == gHC_TUPLE || mod == gHC_PRIM, -- Boxed tuples from one, Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other = -- Special case for tuples; there are too many -- of them to pre-populate the original-name cache Just (mk_tup_name tup_info) where - mk_tup_name (ns, boxity, arity) - | ns == tcName = tyConName (tupleTyCon boxity arity) - | ns == dataName = dataConName (tupleCon boxity arity) - | otherwise = Var.varName (dataConWorkId (tupleCon boxity arity)) + mk_tup_name (ns, sort, arity) + | ns == tcName = tyConName (tupleTyCon sort arity) + | ns == dataName = dataConName (tupleCon sort arity) + | otherwise = Var.varName (dataConWorkId (tupleCon sort arity)) lookupOrigNameCache nc mod occ -- The normal case = case lookupModuleEnv nc mod of @@ -231,7 +232,7 @@ initNameCache :: UniqSupply -> [Name] -> NameCache initNameCache us names = NameCache { nsUniqs = us, nsNames = initOrigNames names, - nsIPs = Map.empty } + nsIPs = Map.empty } initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index eb09c2f10f..c406d04e9d 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -40,6 +40,7 @@ import BasicTypes import Outputable import FastString import Module +import TysWiredIn ( eqTyConName ) infixl 3 &&& \end{code} @@ -84,7 +85,7 @@ data IfaceDecl } | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class + ifName :: OccName, -- Name of the class TyCon ifTyVars :: [IfaceTvBndr], -- Type variables ifFDs :: [FunDep FastString], -- Functional dependencies ifATs :: [IfaceDecl], -- Associated type families @@ -224,9 +225,10 @@ data IfaceUnfolding data IfaceExpr = IfaceLcl IfLclName | IfaceExt IfExtName + | IfaceTupId TupleSort Arity | IfaceType IfaceType | IfaceCo IfaceType -- We re-use IfaceType for coercions - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr | IfaceCase IfaceExpr IfLclName [IfaceAlt] @@ -247,7 +249,7 @@ type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) data IfaceConAlt = IfaceDefault | IfaceDataAlt IfExtName - | IfaceTupleAlt Boxity + | IfaceTupleAlt TupleSort | IfaceLitAlt Literal data IfaceBinding @@ -371,12 +373,9 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, has_wrapper = ifConWrapper con_decl -- This is the reason for -- having the ifConWrapper field! -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, ifSigs = sigs, ifATs = ats }) - = -- dictionary datatype: - -- type constructor - tc_occ : - -- (possibly) newtype coercion + = -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) -- data worker (Id namespace) @@ -385,17 +384,16 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, -- associated types [ifName at | at <- ats ] ++ -- superclass selectors - [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++ + [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ -- operation selectors [op | IfaceClassOp op _ _ <- sigs] where n_ctxt = length sc_ctxt n_sigs = length sigs - tc_occ = mkClassTyConOcc cls_occ - dc_occ = mkClassDataConOcc cls_occ - co_occs | is_newtype = [mkNewTyCoOcc tc_occ] + co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] | otherwise = [] dcww_occ = mkDataConWorkerOcc dc_occ + dc_occ = mkClassDataConOcc cls_tc_occ is_newtype = n_sigs + n_ctxt == 1 -- Sigh ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, @@ -478,6 +476,9 @@ pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) (map (pprIfaceConDecl tc) cs)) +mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType +mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2] + pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, @@ -498,7 +499,7 @@ pprIfaceConDecl tc main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) + eq_ctxt = [(mkIfaceEqPred (IfaceTyVar (occNameFS tv)) ty) | (tv,ty) <- eq_spec] -- A bit gruesome this, but we can't form the full con_tau, and ppr it, @@ -555,6 +556,7 @@ pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc pprIfaceExpr _ (IfaceLcl v) = ppr v pprIfaceExpr _ (IfaceExt v) = ppr v +pprIfaceExpr _ (IfaceTupId c n) = tupleParens c (hcat (replicate (n - 1) (char ','))) pprIfaceExpr _ (IfaceLit l) = ppr l pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix) @@ -720,7 +722,7 @@ freeNamesIfTcFam Nothing = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet -freeNamesIfContext = fnList freeNamesIfPredType +freeNamesIfContext = fnList freeNamesIfType freeNamesIfDecls :: [IfaceDecl] -> NameSet freeNamesIfDecls = fnList freeNamesIfDecl @@ -741,18 +743,9 @@ freeNamesIfConDecl c = fnList freeNamesIfType (ifConArgTys c) &&& fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints -freeNamesIfPredType :: IfacePredType -> NameSet -freeNamesIfPredType (IfaceClassP cl tys) = - unitNameSet cl &&& fnList freeNamesIfType tys -freeNamesIfPredType (IfaceIParam _n ty) = - freeNamesIfType ty -freeNamesIfPredType (IfaceEqPred ty1 ty2) = - freeNamesIfType ty1 &&& freeNamesIfType ty2 - freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t -freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& fnList freeNamesIfType ts freeNamesIfType (IfaceForAllTy tv t) = @@ -800,6 +793,7 @@ freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceTupId _ _) = emptyNameSet freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty freeNamesIfExpr (IfaceCo co) = freeNamesIfType co @@ -839,6 +833,7 @@ freeNamesIfTc _ = emptyNameSet freeNamesIfCo :: IfaceCoCon -> NameSet freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc +-- ToDo: include IfaceIPCoAx? Probably not necessary. freeNamesIfCo _ = emptyNameSet freeNamesIfRule :: IfaceRule -> NameSet diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 89cc755876..b9fcb8f27d 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -7,9 +7,9 @@ This module defines interface types and binders \begin{code} module IfaceType ( - IfExtName, IfLclName, + IfExtName, IfLclName, IfIPName, - IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..), + IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, ifaceTyConName, @@ -22,7 +22,7 @@ module IfaceType ( coToIfaceType, -- Printing - pprIfaceType, pprParendIfaceType, pprIfaceContext, + pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs, tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart @@ -30,6 +30,8 @@ module IfaceType ( import Coercion import TypeRep hiding( maybeParen ) +import Type (tyConAppTyCon_maybe) +import IParam (ipFastString) import TyCon import Id import Var @@ -53,6 +55,8 @@ type IfLclName = FastString -- A local name in iface syntax type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn -- (However Internal or System Names never should) +type IfIPName = FastString -- Represent implicit parameters simply as a string + data IfaceBndr -- Local (non-top-level) binders = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr @@ -69,16 +73,11 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci | IfaceAppTy IfaceType IfaceType | IfaceFunTy IfaceType IfaceType | IfaceForAllTy IfaceTvBndr IfaceType - | IfacePredTy IfacePredType | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated -- Includes newtypes, synonyms, tuples | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated -data IfacePredType -- NewTypes are handled as ordinary TyConApps - = IfaceClassP IfExtName [IfaceType] - | IfaceIParam (IPName OccName) IfaceType - | IfaceEqPred IfaceType IfaceType - +type IfacePredType = IfaceType type IfaceContext = [IfacePredType] data IfaceTyCon -- Encodes type consructors, kind constructors @@ -86,17 +85,19 @@ data IfaceTyCon -- Encodes type consructors, kind constructors = IfaceTc IfExtName -- The common case | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc - | IfaceTupTc Boxity Arity + | IfaceTupTc TupleSort Arity + | IfaceIPTc IfIPName -- Used for implicit parameter TyCons | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim) -- other than 'Any :: *' itself - + -- Kind constructors | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc - | IfaceUbxTupleKindTc | IfaceArgTypeKindTc + | IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc -- Coercion constructors data IfaceCoCon = IfaceCoAx IfExtName + | IfaceIPCoAx FastString | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo | IfaceTransCo | IfaceInstCo | IfaceNthCo Int @@ -113,9 +114,12 @@ ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName +ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName ifaceTyConName (IfaceTc ext) = ext -ifaceTyConName (IfaceAnyTc k) = pprPanic "ifaceTyConName" (ppr k) +ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n) +ifaceTyConName (IfaceAnyTc k) = pprPanic "ifaceTyConName:AnyTc" (ppr k) -- Note [The Name of an IfaceAnyTc] + -- The same caveat applies to IfaceIPTc \end{code} Note [The Name of an IfaceAnyTc] @@ -137,20 +141,20 @@ than solve this potential problem now, I'm going to defer it until it happens! \begin{code} -splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], IfaceContext, IfaceType) +splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes splitIfaceSigmaTy ty - = (tvs,theta,tau) + = (tvs, theta, tau) where - (tvs, rho) = split_foralls ty - (theta, tau) = split_rho rho + (tvs, 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 rho = ([], rho) - split_rho (IfaceFunTy (IfacePredTy st) ty) - = case split_rho ty of { (sts, tau) -> (st:sts, tau) } + split_rho (IfaceFunTy ty1 ty2) + | isIfacePredTy ty1 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) \end{code} @@ -218,11 +222,14 @@ pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc pprIfaceType = ppr_ty tOP_PREC pprParendIfaceType = ppr_ty tYCON_PREC +isIfacePredTy :: IfaceType -> Bool +isIfacePredTy _ = False +-- FIXME: fix this to print iface pred tys correctly +-- isIfacePredTy ty = ifaceTypeKind ty `eqKind` constraintKind ppr_ty :: Int -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys -ppr_ty _ (IfacePredTy st) = ppr st ppr_ty ctxt_prec (IfaceCoConApp tc tys) = maybeParen ctxt_prec tYCON_PREC @@ -234,10 +241,13 @@ ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) maybeParen ctxt_prec fUN_PREC $ sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2) where + arr | isIfacePredTy ty1 = darrow + | otherwise = arrow + ppr_fun_tail (IfaceFunTy ty1 ty2) - = (arrow <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2 + = (arr <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2 ppr_fun_tail other_ty - = [arrow <+> pprIfaceType other_ty] + = [arr <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) = maybeParen ctxt_prec tYCON_PREC $ @@ -247,14 +257,14 @@ ppr_ty ctxt_prec ty@(IfaceForAllTy _ _) = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau)) where (tvs, theta, tau) = splitIfaceSigmaTy ty - -------------------- + + ------------------- pprIfaceForAllPart :: [IfaceTvBndr] -> IfaceContext -> SDoc -> SDoc pprIfaceForAllPart tvs ctxt doc = sep [ppr_tvs, pprIfaceContext ctxt, doc] where ppr_tvs | null tvs = empty - | otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot + | otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot ------------------- ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc @@ -264,6 +274,7 @@ ppr_tc_app _ IfacePArrTc [ty] = pabrackets (pprIfaceType ty) ppr_tc_app _ (IfaceTupTc bx arity) tys | arity == length tys = tupleParens bx (sep (punctuate comma (map pprIfaceType tys))) +ppr_tc_app _ (IfaceIPTc n) [ty] = parens (ppr (IPName n) <> dcolon <> pprIfaceType ty) ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))]) @@ -274,39 +285,34 @@ ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc) ppr_tc tc = ppr tc ------------------- -instance Outputable IfacePredType where - -- Print without parens - ppr (IfaceEqPred ty1 ty2)= hsep [ppr ty1, ptext (sLit "~"), ppr ty2] - ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty] - ppr (IfaceClassP cls ts) = parenSymOcc (getOccName cls) (ppr cls) - <+> sep (map pprParendIfaceType ts) - instance Outputable IfaceTyCon where + ppr (IfaceIPTc n) = ppr (IPName n) ppr (IfaceAnyTc k) = ptext (sLit "Any") <> pprParendIfaceType k - -- We can't easily get the Name of an IfaceAnyTc + -- We can't easily get the Name of an IfaceAnyTc/IfaceIPTc -- (see Note [The Name of an IfaceAnyTc]) -- so we fake it. It's only for debug printing! ppr other_tc = ppr (ifaceTyConName other_tc) instance Outputable IfaceCoCon where - ppr (IfaceCoAx n) = ppr n - ppr IfaceReflCo = ptext (sLit "Refl") - ppr IfaceUnsafeCo = ptext (sLit "Unsafe") - ppr IfaceSymCo = ptext (sLit "Sym") - ppr IfaceTransCo = ptext (sLit "Trans") - ppr IfaceInstCo = ptext (sLit "Inst") - ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d + ppr (IfaceCoAx n) = ppr n + ppr (IfaceIPCoAx ip) = ppr (IPName ip) + ppr IfaceReflCo = ptext (sLit "Refl") + ppr IfaceUnsafeCo = ptext (sLit "Unsafe") + ppr IfaceSymCo = ptext (sLit "Sym") + ppr IfaceTransCo = ptext (sLit "Trans") + ppr IfaceInstCo = ptext (sLit "Inst") + ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d ------------------- pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow -pprIfaceContext [] = empty +pprIfaceContext [] = empty pprIfaceContext theta = ppr_preds theta <+> darrow ppr_preds :: [IfacePredType] -> SDoc -ppr_preds [pred] = ppr pred -- No parens +ppr_preds [pred] = ppr pred -- No parens ppr_preds preds = parens (sep (punctuate comma (map ppr preds))) - + ------------------- pabrackets :: SDoc -> SDoc pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") @@ -343,7 +349,6 @@ toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) -toIfaceType (PredTy st) = IfacePredTy (toIfacePred toIfaceType st) toIfaceTyVar :: TyVar -> FastString toIfaceTyVar = occNameFS . getOccName @@ -361,9 +366,10 @@ toIfaceCoVar = occNameFS . getOccName toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc - | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) - | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) - | otherwise = toIfaceTyCon_name (tyConName tc) + | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) + | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) + | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) + | otherwise = toIfaceTyCon_name (tyConName tc) toIfaceTyCon_name :: Name -> IfaceTyCon toIfaceTyCon_name nm @@ -374,8 +380,9 @@ toIfaceTyCon_name nm toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon toIfaceWiredInTyCon tc nm - | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) + | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) | nm == intTyConName = IfaceIntTc | nm == boolTyConName = IfaceBoolTc | nm == charTyConName = IfaceCharTc @@ -385,6 +392,7 @@ toIfaceWiredInTyCon tc nm | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc | nm == openTypeKindTyConName = IfaceOpenTypeKindTc | nm == argTypeKindTyConName = IfaceArgTypeKindTc + | nm == constraintKindTyConName = IfaceConstraintKindTc | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc | otherwise = IfaceTc nm @@ -393,14 +401,8 @@ toIfaceTypes :: [Type] -> [IfaceType] toIfaceTypes ts = map toIfaceType ts ---------------- -toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType -toIfacePred to (ClassP cls ts) = IfaceClassP (getName cls) (map to ts) -toIfacePred to (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (to t) -toIfacePred to (EqPred ty1 ty2) = IfaceEqPred (to ty1) (to ty2) - ----------------- toIfaceContext :: ThetaType -> IfaceContext -toIfaceContext cs = map (toIfacePred toIfaceType) cs +toIfaceContext = toIfaceTypes ---------------- coToIfaceType :: Coercion -> IfaceType @@ -412,7 +414,7 @@ coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1) coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v) (coToIfaceType co) coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceCoVar cv) -coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con)) +coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (coAxiomToIfaceType con) (map coToIfaceType cos) coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo [ toIfaceType ty1 @@ -427,5 +429,13 @@ coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d) coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo [ coToIfaceType co , toIfaceType ty ] + +coAxiomToIfaceType :: CoAxiom -> IfaceCoCon +coAxiomToIfaceType con + | Just tc <- tyConAppTyCon_maybe (co_ax_lhs con) + , Just ip <- tyConIP_maybe tc + = IfaceIPCoAx (ipFastString ip) + | otherwise + = IfaceCoAx (coAxiomName con) \end{code} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b73e00a731..7ab38d241d 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1325,38 +1325,10 @@ tyThingToIfaceDecl (AnId id) ifIdDetails = toIfaceIdDetails (idDetails id), ifIdInfo = toIfaceIdInfo (idInfo id) } -tyThingToIfaceDecl (AClass clas) - = IfaceClass { ifCtxt = toIfaceContext sc_theta, - ifName = getOccName clas, - ifTyVars = toIfaceTvBndrs clas_tyvars, - ifFDs = map toIfaceFD clas_fds, - ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats, - ifSigs = map toIfaceClassOp op_stuff, - ifRec = boolToRecFlag (isRecursiveTyCon tycon) } - where - (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) - = classExtraBigSig clas - tycon = classTyCon clas - - toIfaceClassOp (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) - IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) - op_ty = funResultTy rho_ty - - toDmSpec NoDefMeth = NoDM - toDmSpec (GenDefMeth _) = GenericDM - toDmSpec (DefMeth _) = VanillaDM - - toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) - tyThingToIfaceDecl (ATyCon tycon) + | Just clas <- tyConClass_maybe tycon + = classToIfaceDecl clas + | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, @@ -1424,6 +1396,39 @@ tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier +classToIfaceDecl :: Class -> IfaceDecl +classToIfaceDecl clas + = IfaceClass { ifCtxt = toIfaceContext sc_theta, + ifName = getOccName (classTyCon clas), + ifTyVars = toIfaceTvBndrs clas_tyvars, + ifFDs = map toIfaceFD clas_fds, + ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifRec = boolToRecFlag (isRecursiveTyCon tycon) } + where + (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas + tycon = classTyCon clas + + toIfaceClassOp (sel_id, def_meth) + = ASSERT(sel_tyvars == clas_tyvars) + IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty) + where + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) + op_ty = funResultTy rho_ty + + toDmSpec NoDefMeth = NoDM + toDmSpec (GenDefMeth _) = GenericDM + toDmSpec (DefMeth _) = VanillaDM + + toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) + + getFS :: NamedThing a => a -> FastString getFS x = occNameFS (getOccName x) @@ -1633,8 +1638,10 @@ toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r) --------------------- toIfaceCon :: AltCon -> IfaceConAlt -toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) - | otherwise = IfaceDataAlt (getName dc) +toIfaceCon (DataAlt dc) | isTupleTyCon tc + = IfaceTupleAlt (tupleTyConSort tc) + | otherwise + = IfaceDataAlt (getName dc) where tc = dataConTyCon dc @@ -1648,7 +1655,7 @@ toIfaceApp (Var v) as = case isDataConWorkId_maybe v of -- We convert the *worker* for tuples into IfaceTuples Just dc | isTupleTyCon tc && saturated - -> IfaceTuple (tupleTyConBoxity tc) tup_args + -> IfaceTuple (tupleTyConSort tc) tup_args where val_args = dropWhile isTypeArg as saturated = val_args `lengthIs` idArity v @@ -1664,13 +1671,15 @@ mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as --------------------- toIfaceVar :: Id -> IfaceExpr -toIfaceVar v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) +toIfaceVar v = case isDataConWorkId_maybe v of + Just dc | isTupleTyCon tc -> IfaceTupId (tupleTyConSort tc) (tupleTyConArity tc) + where tc = dataConTyCon dc + -- Tuple workers also have special syntax, so we get their + -- Uniques right (they are wired-in but infinite) + _ | Just fcall <- isFCallId_maybe v -> IfaceFCall fcall (toIfaceType (idType v)) -- Foreign calls have special syntax - | isExternalName name = IfaceExt name - | Just (TickBox m ix) <- isTickBoxOp_maybe v - = IfaceTick m ix - | otherwise = IfaceLcl (getFS name) - where - name = idName v + | isExternalName name -> IfaceExt name + | Just (TickBox m ix) <- isTickBoxOp_maybe v -> IfaceTick m ix + | otherwise -> IfaceLcl (getFS name) + where name = idName v \end{code} diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 87fac027e3..642bcf4120 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -36,6 +36,7 @@ import Id import MkId import IdInfo import Class +import IParam import TyCon import DataCon import TysWiredIn @@ -467,21 +468,21 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; return (SynonymTyCon rhs_ty) } tc_iface_decl _parent ignore_prags - (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, - ifTyVars = tv_bndrs, ifFDs = rdr_fds, + (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, + ifTyVars = tv_bndrs, ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, 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 - { cls_name <- lookupIfaceTop occ_name + { tc_name <- lookupIfaceTop tc_occ ; ctxt <- tcIfaceCtxt rdr_ctxt ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats - ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec } - ; return (AClass cls) } + ; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec } + ; return (ATyCon (classTyCon cls)) } where tc_sig (IfaceClassOp occ dm rdr_ty) = do { op_name <- lookupIfaceTop occ @@ -811,24 +812,14 @@ tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } -tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') } tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t) tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- -tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a) -tcIfacePred tc (IfaceClassP cls ts) - = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') } -tcIfacePred tc (IfaceIParam ip t) - = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') } -tcIfacePred tc (IfaceEqPred t1 t2) - = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') } - ------------------------------------------ tcIfaceCtxt :: IfaceContext -> IfL ThetaType -tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts +tcIfaceCtxt sts = mapM tcIfaceType sts \end{code} %************************************************************************ @@ -846,17 +837,16 @@ tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIf tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> mkForAllCo tv' <$> tcIfaceCo t --- tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co -tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo" tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion -tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t -tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts -tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 -tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t -tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 -tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 -tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t +tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t +tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts +tcIfaceCoApp (IfaceIPCoAx ip) ts = AxiomInstCo <$> liftM ipCoAxiom (newIPName ip) <*> mapM tcIfaceCo ts +tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 +tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t +tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 +tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) tcIfaceCoVar :: FastString -> IfL CoVar @@ -890,6 +880,9 @@ tcIfaceExpr (IfaceTick modName tickNo) tcIfaceExpr (IfaceExt gbl) = Var <$> tcIfaceExtId gbl +tcIfaceExpr (IfaceTupId boxity arity) + = return $ Var (dataConWorkId (tupleCon boxity arity)) + tcIfaceExpr (IfaceLit lit) = return (Lit lit) @@ -987,9 +980,9 @@ tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) ; tcIfaceDataAlt con inst_tys arg_strs rhs } - + tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs) - = ASSERT2( isTupleTyCon tycon, ppr tycon ) + = ASSERT2( isTupleTyCon tycon && tupleTyConSort tycon == _boxity, ppr tycon ) do { let [data_con] = tyConDataCons tycon ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } @@ -1241,6 +1234,8 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) +tcIfaceTyCon (IfaceIPTc n) = do { n' <- newIPName n + ; tcWiredInTyCon (ipTyCon n') } tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind ; tcWiredInTyCon (anyTyConOfKind tc_kind) } tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name @@ -1257,6 +1252,7 @@ tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon +tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon -- Even though we are in an interface file, we want to make -- sure the instances and RULES of this tycon are loaded @@ -1265,10 +1261,6 @@ tcWiredInTyCon :: TyCon -> IfL TyCon tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc) ; return tc } -tcIfaceClass :: Name -> IfL Class -tcIfaceClass name = do { thing <- tcIfaceGlobal name - ; return (tyThingClass thing) } - tcIfaceCoAxiom :: Name -> IfL CoAxiom tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name ; return (tyThingCoAxiom thing) } diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3f34eb66e9..6d15352c75 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -383,7 +383,8 @@ data ExtensionFlag | Opt_NPlusKPatterns | Opt_DoAndIfThenElse | Opt_RebindableSyntax - + | Opt_ConstraintKind + | Opt_StandaloneDeriving | Opt_DeriveDataTypeable | Opt_DeriveFunctor @@ -1861,6 +1862,7 @@ xFlags = [ ( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ), ( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ), ( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ), + ( "ConstraintKind", AlwaysAllowed, Opt_ConstraintKind, nop ), ( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds, \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ), ( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ), diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index bd7baa10f0..7489ea3115 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -145,7 +145,7 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isFamilyTyCon, + isFamilyTyCon, tyConClass_maybe, synTyConDefn, synTyConType, synTyConResKind, -- ** Type variables @@ -173,7 +173,7 @@ module GHC ( pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy, + ThetaType, pprForAll, pprThetaArrowTy, -- ** Entities TyThing(..), @@ -254,7 +254,7 @@ import NameSet import RdrName import qualified HsSyn -- hack as we want to reexport the whole module import HsSyn hiding ((<.>)) -import Type +import Type hiding( typeKind ) import Coercion ( synTyConResKind ) import TcType hiding( typeKind ) import Id diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 5b170c6c81..7fab8d0ff7 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -56,13 +56,13 @@ module HscTypes ( -- * TyThings and type environments TyThing(..), - tyThingClass, tyThingTyCon, tyThingDataCon, + tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom, tyThingParent_maybe, implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing, TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, - typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, + typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvDataCons, typeEnvCoAxioms, -- * MonadThings @@ -158,8 +158,8 @@ import System.FilePath import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) +import Data.Map ( Map ) import Data.List -import Data.Map (Map) import Data.Word import Control.Monad ( mplus, guard, liftM, when ) import Exception @@ -1066,7 +1066,6 @@ implicitTyThings :: TyThing -> [TyThing] implicitTyThings (AnId _) = [] implicitTyThings (ACoAxiom _cc) = [] implicitTyThings (ATyCon tc) = implicitTyConThings tc -implicitTyThings (AClass cl) = implicitClassThings cl implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) -- For data cons add the worker and (possibly) wrapper @@ -1074,15 +1073,6 @@ implicitClassThings :: Class -> [TyThing] implicitClassThings cl = -- Does not include default methods, because those Ids may have -- their own pragmas, unfoldings etc, not derived from the Class object - -- Dictionary datatype: - -- [extras_plus:] - -- type constructor - -- [recursive call:] - -- (possibly) newtype coercion; definitely no family coercion here - -- data constructor - -- worker - -- (no wrapper by invariant) - extras_plus (ATyCon (classTyCon cl)) ++ -- associated types -- No extras_plus (recursive call) for the classATs, because they -- are only the family decls; they have no implicit things @@ -1092,14 +1082,18 @@ implicitClassThings cl implicitTyConThings :: TyCon -> [TyThing] implicitTyConThings tc - = -- fields (names of selectors) + = class_stuff ++ + -- fields (names of selectors) -- (possibly) implicit coercion and family coercion -- depending on whether it's a newtype or a family instance or both implicitCoTyCon tc ++ -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper concatMap (extras_plus . ADataCon) (tyConDataCons tc) - + where + class_stuff = case tyConClass_maybe tc of + Nothing -> [] + Just cl -> implicitClassThings cl -- add a thing and recursive call extras_plus :: TyThing -> [TyThing] @@ -1124,7 +1118,6 @@ implicitCoTyCon tc isImplicitTyThing :: TyThing -> Bool isImplicitTyThing (ADataCon {}) = True isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (AClass {}) = False isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc isImplicitTyThing (ACoAxiom {}) = True @@ -1141,11 +1134,11 @@ tyThingParent_maybe :: TyThing -> Maybe TyThing -- might have a parent. tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc)) tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of - Just cls -> Just (AClass cls) + Just cls -> Just (ATyCon (classTyCon cls)) Nothing -> Nothing tyThingParent_maybe (AnId id) = case idDetails id of RecSelId { sel_tycon = tc } -> Just (ATyCon tc) - ClassOpId cls -> Just (AClass cls) + ClassOpId cls -> Just (ATyCon (classTyCon cls)) _other -> Nothing tyThingParent_maybe _other = Nothing \end{code} @@ -1163,7 +1156,6 @@ type TypeEnv = NameEnv TyThing emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] -typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] typeEnvCoAxioms :: TypeEnv -> [CoAxiom] typeEnvIds :: TypeEnv -> [Id] @@ -1172,7 +1164,6 @@ lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing emptyTypeEnv = emptyNameEnv typeEnvElts env = nameEnvElts env -typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] @@ -1235,11 +1226,6 @@ tyThingCoAxiom :: TyThing -> CoAxiom tyThingCoAxiom (ACoAxiom ax) = ax tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other) --- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise -tyThingClass :: TyThing -> Class -tyThingClass (AClass cls) = cls -tyThingClass other = pprPanic "tyThingClass" (pprTyThing other) - -- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise tyThingDataCon :: TyThing -> DataCon tyThingDataCon (ADataCon dc) = dc @@ -1274,9 +1260,6 @@ class Monad m => MonadThings m where lookupTyCon :: Name -> m TyCon lookupTyCon = liftM tyThingTyCon . lookupThing - - lookupClass :: Name -> m Class - lookupClass = liftM tyThingClass . lookupThing \end{code} \begin{code} @@ -1640,15 +1623,15 @@ data NameCache -- ^ Supply of uniques nsNames :: OrigNameCache, -- ^ Ensures that one original name gets one unique - nsIPs :: OrigIParamCache - -- ^ Ensures that one implicit parameter name gets one unique + nsIPs :: OrigIParamCache + -- ^ Ensures that one implicit parameter name gets one unique } -- | Per-module cache of original 'OccName's given 'Name's type OrigNameCache = ModuleEnv (OccEnv Name) -- | Module-local cache of implicit parameter 'OccName's given 'Name's -type OrigIParamCache = Map (IPName OccName) (IPName Name) +type OrigIParamCache = Map FastString (IPName Name) \end{code} diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 24f340b33d..d94e514ab8 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -44,7 +44,7 @@ import HsSyn import HscTypes import RnNames (gresFromAvails) import InstEnv -import Type +import Type hiding( typeKind ) import TcType hiding( typeKind ) import Var import Id diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 7e2a98bdf8..635bdce389 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -89,7 +89,6 @@ pprTyThingHdr pefas (AnId id) = pprId pefas id pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon pprTyThingHdr _ (ACoAxiom ax) = pprCoAxiom ax -pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls ------------------------ ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc @@ -97,12 +96,12 @@ ppr_ty_thing pefas _ (AnId id) = pprId pefas id ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon ppr_ty_thing pefas ss (ATyCon tyCon) = pprTyCon pefas ss tyCon ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax -ppr_ty_thing pefas ss (AClass cls) = pprClass pefas ss cls - pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc -pprTyConHdr _ tyCon +pprTyConHdr pefas tyCon | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys + | Just cls <- tyConClass_maybe tyCon + = pprClassHdr pefas cls | otherwise = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) where @@ -166,6 +165,8 @@ pprTyCon pefas ss tyCon else let rhs_type = GHC.synTyConType tyCon in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) + | Just cls <- GHC.tyConClass_maybe tyCon + = pprClass pefas ss cls | otherwise = pprAlgTyCon pefas ss tyCon diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 01c9f7bb24..e1e4d87f63 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -580,8 +580,8 @@ getImplicitBinds :: TypeEnv -> [CoreBind] getImplicitBinds type_env = map get_defn (concatMap implicit_ids (typeEnvElts type_env)) where - implicit_ids (ATyCon tc) = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) - implicit_ids (AClass cls) = classAllSelIds cls + implicit_ids (ATyCon tc) = class_ids ++ mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) + where class_ids = maybe [] classAllSelIds (tyConClass_maybe tc) implicit_ids _ = [] get_defn :: Id -> CoreBind diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 1570af32bc..90e1e66dd2 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -495,6 +495,7 @@ data Token | ITrarrow | ITat | ITtilde + | ITtildehsh | ITdarrow | ITminus | ITbang @@ -661,6 +662,7 @@ reservedSymsFM = listToUFM $ ,("->", ITrarrow, always) ,("@", ITat, always) ,("~", ITtilde, always) + ,("~#", ITtildehsh, always) ,("=>", ITdarrow, always) ,("-", ITminus, always) ,("!", ITbang, always) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 1bf3810cfe..3864c6b93d 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -32,9 +32,10 @@ import RdrHsSyn import HscTypes ( IsBootInterface, WarningTxt(..) ) import Lexer import RdrName +import TysPrim ( eqPrimTyCon ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, - listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) + listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, CCallConv(..), CCallTarget(..), defaultCCallConv @@ -278,6 +279,7 @@ incorrect. '->' { L _ ITrarrow } '@' { L _ ITat } '~' { L _ ITtilde } + '~#' { L _ ITtildehsh } '=>' { L _ ITdarrow } '-' { L _ ITminus } '!' { L _ ITbang } @@ -961,7 +963,7 @@ ctype :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } | context '=>' ctype { LL $ mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy - | ipvar '::' type { LL (HsPredTy (HsIParam (unLoc $1) $3)) } + | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) } | type { $1 } ---------------------- @@ -979,7 +981,7 @@ ctypedoc :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy - | ipvar '::' type { LL (HsPredTy (HsIParam (unLoc $1) $3)) } + | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) } | typedoc { $1 } ---------------------- @@ -995,7 +997,7 @@ ctypedoc :: { LHsType RdrName } -- but not f :: ?x::Int => blah context :: { LHsContext RdrName } : btype '~' btype {% checkContext - (LL $ HsPredTy (HsEqualP $1 $3)) } + (LL $ HsEqTy $1 $3) } | btype {% checkContext $1 } type :: { LHsType RdrName } @@ -1003,7 +1005,7 @@ type :: { LHsType RdrName } | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } | btype '->' ctype { LL $ HsFunTy $1 $3 } - | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } + | btype '~' btype { LL $ HsEqTy $1 $3 } typedoc :: { LHsType RdrName } : btype { $1 } @@ -1014,7 +1016,7 @@ typedoc :: { LHsType RdrName } | btype tyvarop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 } | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 } - | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } + | btype '~' btype { LL $ HsEqTy $1 $3 } btype :: { LHsType RdrName } : btype atype { LL $ HsAppTy $1 $2 } @@ -1025,8 +1027,8 @@ atype :: { LHsType RdrName } | tyvar { L1 (HsTyVar (unLoc $1)) } | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only | '{' fielddecls '}' { LL $ HsRecTy $2 } -- Constructor sigs only - | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } - | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } + | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy (HsBoxyTuple placeHolderKind) ($2:$4) } + | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 } | '[' ctype ']' { LL $ HsListTy $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } @@ -1090,6 +1092,7 @@ kind :: { Located Kind } akind :: { Located Kind } : '*' { L1 liftedTypeKind } | '!' { L1 unliftedTypeKind } + | CONID {% checkKindName (L1 (getCONID $1)) } | '(' kind ')' { LL (unLoc $2) } @@ -1710,9 +1713,9 @@ con_list : con { L1 [$1] } sysdcon :: { Located DataCon } -- Wired in data constructors : '(' ')' { LL unitDataCon } - | '(' commas ')' { LL $ tupleCon Boxed ($2 + 1) } + | '(' commas ')' { LL $ tupleCon BoxedTuple ($2 + 1) } | '(#' '#)' { LL $ unboxedSingletonDataCon } - | '(#' commas '#)' { LL $ tupleCon Unboxed ($2 + 1) } + | '(#' commas '#)' { LL $ tupleCon UnboxedTuple ($2 + 1) } | '[' ']' { LL nilDataCon } conop :: { Located RdrName } @@ -1729,16 +1732,18 @@ qconop :: { Located RdrName } gtycon :: { Located RdrName } -- A "general" qualified tycon : oqtycon { $1 } | '(' ')' { LL $ getRdrName unitTyCon } - | '(' commas ')' { LL $ getRdrName (tupleTyCon Boxed ($2 + 1)) } + | '(' commas ')' { LL $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) } | '(#' '#)' { LL $ getRdrName unboxedSingletonTyCon } - | '(#' commas '#)' { LL $ getRdrName (tupleTyCon Unboxed ($2 + 1)) } + | '(#' commas '#)' { LL $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) } | '(' '->' ')' { LL $ getRdrName funTyCon } | '[' ']' { LL $ listTyCon_RDR } | '[:' ':]' { LL $ parrTyCon_RDR } + | '(' '~#' ')' { LL $ getRdrName eqPrimTyCon } oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon : qtycon { $1 } | '(' qtyconsym ')' { LL (unLoc $2) } + | '(' '~' ')' { LL $ eqTyCon_RDR } -- In here rather than gtycon because I want to write it in the GHC.Types export list qtyconop :: { Located RdrName } -- Qualified or unqualified : qtyconsym { $1 } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index c99fcb6695..cd76284df8 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -246,7 +246,6 @@ akind :: { IfaceKind } kind :: { IfaceKind } : akind { $1 } | akind '->' kind { ifaceArrow $1 $3 } - | ty ':=:' ty { ifaceEq $1 $3 } ----------------------------------------- -- Expressions @@ -378,8 +377,6 @@ ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 -ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2) - toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 6886732f7e..e6824e7111 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -33,17 +33,17 @@ module RdrHsSyn ( -- checking and constructing values checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext - checkPred, -- HsType -> P HsPred checkTyVars, -- [LHsType RdrName] -> P () checkKindSigs, -- [LTyClDecl RdrName] -> P () checkInstType, -- HsType -> P HsType checkPattern, -- HsExp -> P HsPat - bang_RDR, + bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, + checkKindName, parseError, parseErrorSDoc, ) where @@ -53,13 +53,15 @@ import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) -import Name ( Name ) +import OccName ( occNameFS ) +import Name ( Name, nameOccName ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import Lexer -import TysWiredIn ( unitTyCon ) +import TysWiredIn ( unitTyCon ) +import TysPrim ( constraintKindTyConName, constraintKind ) import ForeignCall -import OccName ( srcDataName, varName, isDataOcc, isTcOcc, +import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) import PrelNames ( forall_tv_RDR ) import DynFlags @@ -102,13 +104,8 @@ extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrNa extractHsRhoRdrTyVars ctxt ty = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) -extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName] -extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt) - -extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName] -extract_pred (HsClassP _ tys) acc = extract_ltys tys acc -extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) -extract_pred (HsIParam _ ty ) acc = extract_lty ty acc +extract_lctxt :: LHsContext RdrName -> [Located RdrName] -> [Located RdrName] +extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt) extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName] extract_ltys tys acc = foldr extract_lty acc tys @@ -124,7 +121,8 @@ extract_lty (L loc ty) acc HsPArrTy ty -> extract_lty ty acc HsTupleTy _ tys -> extract_ltys tys acc HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsPredTy p -> extract_pred p acc + HsIParamTy _ ty -> extract_lty ty acc + HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc HsCoreTy {} -> acc -- The type is closed @@ -473,15 +471,9 @@ checkInstType (L l t) return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) checkDictTy :: LHsType RdrName -> P (LHsType RdrName) -checkDictTy (L spn ty) = check ty [] - where - check (HsTyVar tc) args | isRdrTc tc = done tc args - check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2:args) - check (HsAppTy l r) args = check (unLoc l) (r:args) - check (HsParTy t) args = check (unLoc t) args - check _ _ = parseErrorSDoc spn (text "Malformed instance header:" <+> ppr ty) - - done tc args = return (L spn (HsPredTy (HsClassP tc args))) +checkDictTy lty@(L l ty) = case splitLHsClassTy_maybe lty of + Nothing -> parseErrorSDoc l (text "Malformed instance header:" <+> ppr ty) + Just _ -> return lty checkTParams :: Bool -- Type/data family -> LHsType RdrName @@ -570,12 +562,11 @@ checkKindSigs = mapM_ check parseErrorSDoc l (text "Type declaration in a class must be a kind signature:" $$ ppr tydecl) checkContext :: LHsType RdrName -> P (LHsContext RdrName) -checkContext (L l t) - = check t +checkContext (L l orig_t) + = check orig_t where check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type - = do ctx <- mapM checkPred ts - return (L l ctx) + = return (L l ts) check (HsParTy ty) -- to be sure HsParTy doesn't get into the way = check (unLoc ty) @@ -583,32 +574,8 @@ checkContext (L l t) check (HsTyVar t) -- Empty context shows up as a unit type () | t == getRdrName unitTyCon = return (L l []) - check t - = do p <- checkPred (L l t) - return (L l [p]) - - -checkPred :: LHsType RdrName -> P (LHsPred RdrName) --- Watch out.. in ...deriving( Show )... we use checkPred on --- the list of partially applied predicates in the deriving, --- so there can be zero args. -checkPred (L spn (HsPredTy (HsIParam n ty))) - = return (L spn (HsIParam n ty)) -checkPred (L spn ty) - = check spn ty [] - where - checkl (L l ty) args = check l ty args - - check _loc (HsPredTy pred@(HsEqualP _ _)) - args | null args - = return $ L spn pred - check _loc (HsTyVar t) args | not (isRdrTyVar t) - = return (L spn (HsClassP t args)) - check _loc (HsAppTy l r) args = checkl l (r:args) - check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args) - check _loc (HsParTy t) args = checkl t args - check loc _ _ = parseErrorSDoc loc - (text "malformed class assertion:" <+> ppr ty) + check _ + = return (L l [L l orig_t]) -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -816,6 +783,17 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> text "else" <+> ppr elseExpr + +checkKindName :: Located FastString -> P (Located Kind) +checkKindName (L l fs) = do + pState <- getPState + let ext_enabled = xopt Opt_ConstraintKind (dflags pState) + is_kosher = fs == occNameFS (nameOccName constraintKindTyConName) + if not ext_enabled || not is_kosher + then parseErrorSDoc l (text "Unexpected named kind:" + $$ nest 4 (ppr fs) + $$ if (not ext_enabled && is_kosher) then text "Perhaps you meant to use -XConstraintKind?" else empty) + else return (L l constraintKind) \end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index f5ba7debba..bd59a01936 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -57,7 +57,7 @@ import Unique ( Unique, Uniquable(..), hasKey, mkPreludeTyConUnique, mkPreludeClassUnique, mkTupleTyConUnique ) -import BasicTypes ( Boxity(..), Arity ) +import BasicTypes ( TupleSort(..), Arity ) import Name ( Name, mkInternalName, mkExternalName, mkSystemVarName ) import SrcLoc import FastString @@ -403,9 +403,10 @@ mkMainModule_ m = mkModule mainPackageId m %************************************************************************ \begin{code} -mkTupleModule :: Boxity -> Arity -> Module -mkTupleModule Boxed _ = gHC_TUPLE -mkTupleModule Unboxed _ = gHC_PRIM +mkTupleModule :: TupleSort -> Arity -> Module +mkTupleModule BoxedTuple _ = gHC_TUPLE +mkTupleModule FactTuple _ = gHC_TUPLE +mkTupleModule UnboxedTuple _ = gHC_PRIM \end{code} @@ -1137,7 +1138,7 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, - anyTyConKey :: Unique + anyTyConKey, eqTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 boolTyConKey = mkPreludeTyConUnique 4 @@ -1171,6 +1172,7 @@ realWorldTyConKey = mkPreludeTyConUnique 34 stablePtrPrimTyConKey = mkPreludeTyConUnique 35 stablePtrTyConKey = mkPreludeTyConUnique 36 anyTyConKey = mkPreludeTyConUnique 37 +eqTyConKey = mkPreludeTyConUnique 38 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, @@ -1178,11 +1180,11 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique + funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 -eqPredPrimTyConKey = mkPreludeTyConUnique 53 +eqPrimTyConKey = mkPreludeTyConUnique 53 mutVarPrimTyConKey = mkPreludeTyConUnique 55 ioTyConKey = mkPreludeTyConUnique 56 wordPrimTyConKey = mkPreludeTyConUnique 58 @@ -1222,12 +1224,13 @@ tySuperKindTyConKey = mkPreludeTyConUnique 85 -- Kind constructors liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey, - ubxTupleKindTyConKey, argTypeKindTyConKey :: Unique + ubxTupleKindTyConKey, argTypeKindTyConKey, constraintKindTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 openTypeKindTyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 ubxTupleKindTyConKey = mkPreludeTyConUnique 90 argTypeKindTyConKey = mkPreludeTyConUnique 91 +constraintKindTyConKey = mkPreludeTyConUnique 92 -- Coercion constructors symCoercionTyConKey, transCoercionTyConKey, leftCoercionTyConKey, @@ -1298,7 +1301,7 @@ rep1TyConKey = mkPreludeTyConUnique 156 ----------------------------------------------------- unitTyConKey :: Unique -unitTyConKey = mkTupleTyConUnique Boxed 0 +unitTyConKey = mkTupleTyConUnique BoxedTuple 0 \end{code} %************************************************************************ @@ -1311,7 +1314,7 @@ unitTyConKey = mkTupleTyConUnique Boxed 0 charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, floatDataConKey, intDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - ioDataConKey, integerDataConKey :: Unique + ioDataConKey, integerDataConKey, eqBoxDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 doubleDataConKey = mkPreludeDataConUnique 3 @@ -1325,6 +1328,7 @@ trueDataConKey = mkPreludeDataConUnique 15 wordDataConKey = mkPreludeDataConUnique 16 ioDataConKey = mkPreludeDataConUnique 17 integerDataConKey = mkPreludeDataConUnique 18 +eqBoxDataConKey = mkPreludeDataConUnique 19 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index f86e6a4a29..9dbc32f4fc 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -557,7 +557,7 @@ dataToTagRule _ _ = Nothing -- seq# :: forall a s . a -> State# s -> (# State# s, a #) seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a - = Just (mkConApp (tupleCon Unboxed 2) + = Just (mkConApp (tupleCon UnboxedTuple 2) [Type (mkStatePrimTy ty_s), ty_a, s, a]) seqRule _ _ = Nothing diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 29c5644346..ccf6ea0e7b 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -37,7 +37,7 @@ import OccName ( OccName, pprOccName, mkVarOccFS ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, typePrimRep ) -import BasicTypes ( Arity, Boxity(..) ) +import BasicTypes ( Arity, TupleSort(..) ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) import Outputable diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index b130c21ad3..43fd143e55 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -9,7 +9,9 @@ -- | This module defines TyCons that can't be expressed in Haskell. -- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( - alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + mkPrimTyConName, -- For implicit parameters in TysWiredIn only + + tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar, @@ -17,15 +19,16 @@ module TysPrim( -- Kind constructors... tySuperKindTyCon, tySuperKind, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, tySuperKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName, + constraintKindTyConName, -- Kinds liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, + argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, funTyCon, funTyConName, @@ -61,7 +64,7 @@ module TysPrim( int64PrimTyCon, int64PrimTy, word64PrimTyCon, word64PrimTy, - eqPredPrimTyCon, -- ty1 ~ ty2 + eqPrimTyCon, -- ty1 ~# ty2 -- * Any anyTyCon, anyTyConOfKind, anyTypeOfKind @@ -117,7 +120,7 @@ primTyCons , word32PrimTyCon , word64PrimTyCon , anyTyCon - , eqPredPrimTyCon + , eqPrimTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -127,7 +130,7 @@ mkPrimTc fs unique tycon (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -139,7 +142,7 @@ addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrim floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon -eqPredPrimTyConName = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon +eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon @@ -241,11 +244,13 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's tySuperKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - ubxTupleKindTyCon, argTypeKindTyCon + ubxTupleKindTyCon, argTypeKindTyCon, + constraintKindTyCon :: TyCon tySuperKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName + ubxTupleKindTyConName, argTypeKindTyConName, + constraintKindTyConName :: Name tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName @@ -254,6 +259,7 @@ openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind +constraintKindTyCon = mkKindTyCon constraintKindTyConName tySuperKind -------------------------- -- ... and now their names @@ -264,6 +270,7 @@ openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey ope unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon +constraintKindTyConName = mkPrimTyConName (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon mkPrimTyConName :: FastString -> Unique -> TyCon -> Name mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) @@ -280,13 +287,14 @@ kindTyConType :: TyCon -> Type kindTyConType kind = TyConApp kind [] -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind +liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind liftedTypeKind = kindTyConType liftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon argTypeKind = kindTyConType argTypeKindTyCon ubxTupleKind = kindTyConType ubxTupleKindTyCon +constraintKind = kindTyConType constraintKindTyCon -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ mkArrowKind :: Kind -> Kind -> Kind @@ -379,18 +387,18 @@ doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep %* * %************************************************************************ -Note [The (~) TyCon) +Note [The ~# TyCon) ~~~~~~~~~~~~~~~~~~~~ -There is a perfectly ordinary type constructor (~) that represents the type +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 Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic: - Refl Maybe :: Maybe ~ Maybe + Refl Maybe :: ~# Maybe Maybe -So the true kind of (~) :: forall k. k -> k -> #. But we don't have +So the true kind of ~# :: forall k. k -> k -> #. But we don't have polymorphic kinds (yet). However, (~) really only appears saturated in -which case there is no problem in finding the kind of (ty1 ~ ty2). So +which case there is no problem in finding the kind of (ty1 ~# ty2). So we check that in CoreLint (and, in an assertion, in Kind.typeKind). Note [The State# TyCon] @@ -411,9 +419,9 @@ mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] statePrimTyCon :: TyCon -- See Note [The State# TyCon] statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep -eqPredPrimTyCon :: TyCon -- The representation type for equality predicates - -- See Note [The (~) TyCon] -eqPredPrimTyCon = pcPrimTyCon eqPredPrimTyConName 2 VoidRep +eqPrimTyCon :: TyCon -- The representation type for equality predicates + -- See Note [The ~# TyCon] +eqPrimTyCon = pcPrimTyCon eqPrimTyConName 2 VoidRep \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@ -575,8 +583,6 @@ threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep \end{code} - - %************************************************************************ %* * Any diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 65a0c334d5..7b12fecb79 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -8,7 +8,7 @@ -- must be wired into the compiler nonetheless. C.f module TysPrim module TysWiredIn ( -- * All wired in things - wiredInTyCons, + wiredInTyCons, -- * Bool boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, @@ -55,7 +55,13 @@ module TysWiredIn ( -- * Parallel arrays mkPArrTy, parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, - parrTyCon_RDR, parrTyConName + parrTyCon_RDR, parrTyConName, + + -- * Equality predicates + eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon, + + -- * Implicit parameter predicates + mkIPName ) where #include "HsVersions.h" @@ -67,6 +73,7 @@ import PrelNames import TysPrim -- others: +import Coercion import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) @@ -75,7 +82,7 @@ import TyCon import TypeRep import RdrName import Name -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) +import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), Arity, RecFlag(..), Boxity(..), HsBang(..) ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array @@ -100,9 +107,16 @@ If you change which things are wired in, make sure you change their names in PrelNames, so they use wTcQual, wDataQual, etc \begin{code} -wiredInTyCons :: [TyCon] -- Excludes tuples --- This list is used only to define PrelInfo.wiredInThings - +-- This list is used only to define PrelInfo.wiredInThings. That in turn +-- is used to initialise the name environment carried around by the renamer. +-- This means that if we look up the name of a TyCon (or its implicit binders) +-- that occurs in this list that name will be assigned the wired-in key we +-- define here. +-- +-- Because of their infinite nature, this list excludes tuples, Any and implicit +-- parameter TyCons. Instead, we have a hack in lookupOrigNameCache to deal with +-- these names. +wiredInTyCons :: [TyCon] -- It does not need to include kind constructors, because -- all that wiredInThings does is to initialise the Name table, -- and kind constructors don't appear in source code. @@ -120,6 +134,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , intTyCon , listTyCon , parrTyCon + , eqTyCon ] \end{code} @@ -136,6 +151,10 @@ mkWiredInDataConName built_in modu fs unique datacon (ADataCon datacon) -- Relevant DataCon built_in +eqTyConName, eqBoxDataConName :: Name +eqTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon +eqBoxDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqBoxDataConKey eqBoxDataCon + charTyConName, charDataConName, intTyConName, intDataConName :: Name charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon @@ -165,7 +184,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:: RdrName + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName true_RDR = nameRdrName trueDataConName @@ -175,6 +194,7 @@ intDataCon_RDR = nameRdrName intDataConName listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName parrTyCon_RDR = nameRdrName parrTyConName +eqTyCon_RDR = nameRdrName eqTyConName \end{code} @@ -206,15 +226,23 @@ pcTyCon is_enum is_rec name tyvars cons pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon pcDataCon = pcDataConWithFixity False +pcDataCon' :: Name -> Unique -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon' = pcDataConWithFixity' False + pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon --- The Name should be in the DataName name space; it's the name --- of the DataCon itself. --- --- The unique is the first of two free uniques; +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, -- the second is used for the "worker name" +-- +-- To support this the mkPreludeDataConUnique function "allocates" +-- one DataCon unique per pair of Ints. + +pcDataConWithFixity' :: Bool -> Name -> Unique -> [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 tyvars arg_tys tycon +pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon = data_con where data_con = mkDataCon dc_name declared_infix @@ -233,7 +261,6 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon modu = ASSERT( isExternalName dc_name ) nameModule dc_name wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) - wrk_key = incrUnique (nameUnique dc_name) wrk_name = mkWiredInName modu wrk_occ wrk_key (AnId (dataConWorkId data_con)) UserSyntax bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name) @@ -248,62 +275,101 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon %************************************************************************ \begin{code} -tupleTyCon :: Boxity -> Arity -> TyCon -tupleTyCon boxity i | i > mAX_TUPLE_SIZE = fst (mk_tuple boxity i) -- Build one specially -tupleTyCon Boxed i = fst (boxedTupleArr ! i) -tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) - -tupleCon :: Boxity -> Arity -> DataCon -tupleCon boxity i | i > mAX_TUPLE_SIZE = snd (mk_tuple boxity i) -- Build one specially -tupleCon Boxed i = snd (boxedTupleArr ! i) -tupleCon Unboxed i = snd (unboxedTupleArr ! i) - -boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) -boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] -unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] - -mk_tuple :: Boxity -> Int -> (TyCon,DataCon) -mk_tuple boxity arity = (tycon, tuple_con) +tupleTyCon :: TupleSort -> Arity -> TyCon +tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially +tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) +tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) +tupleTyCon FactTuple i = fst (factTupleArr ! i) + +tupleCon :: TupleSort -> Arity -> DataCon +tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially +tupleCon BoxedTuple i = snd (boxedTupleArr ! i) +tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i) +tupleCon FactTuple i = snd (factTupleArr ! i) + +boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]] +factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple FactTuple i | i <- [0..mAX_TUPLE_SIZE]] + +mk_tuple :: TupleSort -> Int -> (TyCon,DataCon) +mk_tuple sort arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity - modu = mkTupleModule boxity arity - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort + modu = mkTupleModule sort arity + tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq (ATyCon tycon) BuiltInSyntax tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind - res_kind | isBoxed boxity = liftedTypeKind - | otherwise = ubxTupleKind + res_kind = case sort of + BoxedTuple -> liftedTypeKind + UnboxedTuple -> ubxTupleKind + FactTuple -> constraintKind - tyvars | isBoxed boxity = take arity alphaTyVars - | otherwise = take arity openAlphaTyVars + tyvars = take arity $ case sort of + BoxedTuple -> alphaTyVars + UnboxedTuple -> openAlphaTyVars + FactTuple -> tyVarList constraintKind tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + dc_name = mkWiredInName modu (mkTupleOcc dataName sort arity) dc_uniq (ADataCon tuple_con) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity + tc_uniq = mkTupleTyConUnique sort arity + dc_uniq = mkTupleDataConUnique sort arity unitTyCon :: TyCon -unitTyCon = tupleTyCon Boxed 0 +unitTyCon = tupleTyCon BoxedTuple 0 unitDataCon :: DataCon unitDataCon = head (tyConDataCons unitTyCon) unitDataConId :: Id unitDataConId = dataConWorkId unitDataCon pairTyCon :: TyCon -pairTyCon = tupleTyCon Boxed 2 +pairTyCon = tupleTyCon BoxedTuple 2 unboxedSingletonTyCon :: TyCon -unboxedSingletonTyCon = tupleTyCon Unboxed 1 +unboxedSingletonTyCon = tupleTyCon UnboxedTuple 1 unboxedSingletonDataCon :: DataCon -unboxedSingletonDataCon = tupleCon Unboxed 1 +unboxedSingletonDataCon = tupleCon UnboxedTuple 1 unboxedPairTyCon :: TyCon -unboxedPairTyCon = tupleTyCon Unboxed 2 +unboxedPairTyCon = tupleTyCon UnboxedTuple 2 unboxedPairDataCon :: DataCon -unboxedPairDataCon = tupleCon Unboxed 2 +unboxedPairDataCon = tupleCon UnboxedTuple 2 \end{code} +%************************************************************************ +%* * +\subsection[TysWiredIn-ImplicitParams]{Special type constructors for implicit parameters} +%* * +%************************************************************************ + +\begin{code} +mkIPName :: FastString + -> Unique -> Unique -> Unique -> Unique + -> IPName Name +mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip + where + name_ip = IPName tycon_name + + tycon_name = mkPrimTyConName ip tycon_u tycon + tycon = mkAlgTyCon tycon_name + (liftedTypeKind `mkArrowKind` constraintKind) + [alphaTyVar] + [] -- No stupid theta + (NewTyCon { data_con = datacon, + nt_rhs = mkTyVarTy alphaTyVar, + nt_etad_rhs = ([alphaTyVar], mkTyVarTy alphaTyVar), + nt_co = mkNewTypeCo co_ax_name tycon [alphaTyVar] (mkTyVarTy alphaTyVar) }) + (IPTyCon name_ip) + NonRecursive + False + + datacon_name = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "IPBox") datacon_u datacon + datacon = pcDataCon' datacon_name dc_wrk_u [alphaTyVar] [mkTyVarTy alphaTyVar] tycon + + co_ax_name = mkPrimTyConName ip co_ax_u tycon +\end{code} %************************************************************************ %* * @@ -312,6 +378,21 @@ unboxedPairDataCon = tupleCon Unboxed 2 %************************************************************************ \begin{code} +eqTyCon :: TyCon +eqTyCon = mkAlgTyCon eqTyConName + (mkArrowKinds [openTypeKind, openTypeKind] constraintKind) + [alphaTyVar, betaTyVar] + [] -- No stupid theta + (DataTyCon [eqBoxDataCon] False) + NoParentTyCon + NonRecursive + False + +eqBoxDataCon :: DataCon +eqBoxDataCon = pcDataCon eqBoxDataConName [alphaTyVar, betaTyVar] [TyConApp eqPrimTyCon [mkTyVarTy alphaTyVar, mkTyVarTy betaTyVar]] eqTyCon +\end{code} + +\begin{code} charTy :: Type charTy = mkTyConTy charTyCon @@ -526,17 +607,17 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} \begin{code} -mkTupleTy :: Boxity -> [Type] -> Type +mkTupleTy :: TupleSort -> [Type] -> Type -- Special case for *boxed* 1-tuples, which are represented by the type itself -mkTupleTy boxity [ty] | Boxed <- boxity = ty -mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys +mkTupleTy sort [ty] | Boxed <- tupleSortBoxity sort = ty +mkTupleTy sort tys = mkTyConApp (tupleTyCon sort (length tys)) tys -- | Build the type of a small tuple that holds the specified type of thing mkBoxedTupleTy :: [Type] -> Type -mkBoxedTupleTy tys = mkTupleTy Boxed tys +mkBoxedTupleTy tys = mkTupleTy BoxedTuple tys unitTy :: Type -unitTy = mkTupleTy Boxed [] +unitTy = mkTupleTy BoxedTuple [] \end{code} %************************************************************************ diff --git a/compiler/prelude/TysWiredIn.lhs-boot b/compiler/prelude/TysWiredIn.lhs-boot new file mode 100644 index 0000000000..9740c0ae38 --- /dev/null +++ b/compiler/prelude/TysWiredIn.lhs-boot @@ -0,0 +1,10 @@ +\begin{code} +module TysWiredIn where + +import {-# SOURCE #-} TyCon (TyCon) +import {-# SOURCE #-} TypeRep (Type) + + +eqTyCon :: TyCon +mkBoxedTupleTy :: [Type] -> Type +\end{code} diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 2737752081..5fd0f1cc0c 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -28,7 +28,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) +import RnTypes ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch ) import RnPat (rnPats, rnBindPat, NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker ) @@ -231,9 +231,9 @@ rnIPBinds (IPBinds ip_binds _no_dict_binds) = do rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) rnIPBind (IPBind n expr) = do - name <- newIPNameRn n + n' <- rnIPName n (expr',fvExpr) <- rnLExpr expr - return (IPBind name expr', fvExpr) + return (IPBind n' expr', fvExpr) \end{code} diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 8faf6e3eb0..cfdeab29c9 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -17,7 +17,7 @@ module RnEnv ( lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, - newLocalBndrRn, newLocalBndrsRn, newIPNameRn, + newLocalBndrRn, newLocalBndrsRn, bindLocalName, bindLocalNames, bindLocalNamesFV, MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, addLocalFixities, @@ -36,7 +36,7 @@ module RnEnv ( #include "HsVersions.h" import LoadIface ( loadInterfaceForName, loadSrcInterface ) -import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName, updNameCache, extendNameCache ) +import IfaceEnv ( lookupOrig, newGlobalBinder, updNameCache, extendNameCache ) import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName @@ -351,9 +351,6 @@ lookupSubBndrGREs env parent rdr_name parent_is p (GRE { gre_par = ParentIs p' }) = p == p' parent_is _ _ = False - -newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) -newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) \end{code} Note [Looking up Exact RdrNames] diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 88e0462e74..8478db0cf9 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -27,7 +27,7 @@ import HsSyn import TcRnMonad import TcEnv ( thRnBrack ) import RnEnv -import RnTypes ( rnHsTypeFVs, rnSplice, checkTH, +import RnTypes ( rnHsTypeFVs, rnSplice, rnIPName, checkTH, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) import RnPat import DynFlags @@ -105,8 +105,8 @@ rnExpr (HsVar v) finishHsVar name rnExpr (HsIPVar v) - = newIPNameRn v `thenM` \ name -> - return (HsIPVar name, emptyFVs) + = do v' <- rnIPName v + return (HsIPVar v', emptyFVs) rnExpr (HsLit lit@(HsString s)) = do { diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index bfbcdc515f..79aaf6aa7a 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -8,7 +8,7 @@ module RnHsSyn( -- Names charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, extractHsTyVars, extractHsTyNames, extractHsTyNames_s, - extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, + extractFunDepNames, extractHsCtxtTyNames, -- Free variables hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs @@ -21,7 +21,7 @@ import Class ( FunDep ) import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet -import BasicTypes ( Boxity ) +import BasicTypes ( TupleSort ) import SrcLoc \end{code} @@ -39,8 +39,8 @@ charTyCon_name = getName charTyCon listTyCon_name = getName listTyCon parrTyCon_name = getName parrTyCon -tupleTyCon_name :: Boxity -> Int -> Name -tupleTyCon_name boxity n = getName (tupleTyCon boxity n) +tupleTyCon_name :: TupleSort -> Int -> Name +tupleTyCon_name sort n = getName (tupleTyCon sort n) extractHsTyVars :: LHsType Name -> NameSet extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) @@ -59,7 +59,8 @@ extractHsTyNames ty get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty get (HsTupleTy _ tys) = extractHsTyNames_s tys get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsPredTy p) = extractHsPredTyNames p + get (HsIParamTy _ ty) = getl ty + get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) get (HsParTy ty) = getl ty get (HsBangTy _ ty) = getl ty @@ -82,17 +83,7 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t extractHsCtxtTyNames :: LHsContext Name -> NameSet extractHsCtxtTyNames (L _ ctxt) - = foldr (unionNameSets . extractHsPredTyNames . unLoc) emptyNameSet ctxt - --- You don't import or export implicit parameters, --- so don't mention the IP names -extractHsPredTyNames :: HsPred Name -> NameSet -extractHsPredTyNames (HsClassP cls tys) - = unitNameSet cls `unionNameSets` extractHsTyNames_s tys -extractHsPredTyNames (HsEqualP ty1 ty2) - = extractHsTyNames ty1 `unionNameSets` extractHsTyNames ty2 -extractHsPredTyNames (HsIParam _ ty) - = extractHsTyNames ty + = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 88113e409b..ef842f261e 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -544,7 +544,7 @@ getLocalNonValBinders fixity_env = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr ; mapM (new_ti (Just cls_nm)) ats } where - (_, _, L loc cls_rdr, _) = splitHsInstDeclTy inst_ty + Just (_, _, L loc cls_rdr, _) = splitLHsInstDeclTy_maybe inst_ty lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) -- Used for TyData and TySynonym only diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 975969d0b1..a6f619a447 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -155,15 +155,15 @@ matchNameMaker ctxt = LamMk report_unused StmtCtxt GhciStmt -> False _ -> True -newName :: NameMaker -> Located RdrName -> CpsRn Name -newName (LamMk report_unused) rdr_name +newPatName :: NameMaker -> Located RdrName -> CpsRn Name +newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside -> do { name <- newLocalBndrRn rdr_name ; (res, fvs) <- bindLocalName name (thing_inside name) ; when report_unused $ warnUnusedMatches [name] fvs ; return (res, name `delFV` fvs) }) -newName (LetMk is_top fix_env) rdr_name +newPatName (LetMk is_top fix_env) rdr_name = CpsRn (\ thing_inside -> do { name <- case is_top of NotTopLevel -> newLocalBndrRn rdr_name @@ -253,7 +253,7 @@ rnPat ctxt pat thing_inside = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') applyNameMaker :: NameMaker -> Located RdrName -> RnM Name -applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n } +applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName mk rdr); return n } -- ----------- Entry point 2: rnBindPat ------------------- -- Binds local names; in a recursive scope that involves other bound vars @@ -298,7 +298,7 @@ rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPa rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') } rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM - ; name <- newName mk (L loc rdr) + ; name <- newPatName mk (L loc rdr) ; return (VarPat name) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) @@ -334,7 +334,7 @@ rnPatAndThen _ (NPat lit mb_neg _eq) ; return (NPat lit' mb_neg' eq') } rnPatAndThen mk (NPlusKPat rdr lit _ _) - = do { new_name <- newName mk rdr + = do { new_name <- newPatName mk rdr ; lit' <- liftCpsFV $ rnOverLit lit ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName @@ -342,7 +342,7 @@ rnPatAndThen mk (NPlusKPat rdr lit _ _) -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat rdr pat) - = do { new_name <- newName mk rdr + = do { new_name <- newPatName mk rdr ; pat' <- rnLPatAndThen mk pat ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 2f01d7d418..76b81465f9 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -27,6 +27,7 @@ import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn, lookupTcdNa import HscTypes ( AvailInfo(..) ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad +import Kind ( liftedTypeKind ) import ForeignCall ( CCallTarget(..) ) import Module @@ -42,7 +43,6 @@ import Util ( filterOut ) import SrcLoc import DynFlags import HscTypes ( HscEnv, hsc_dflags ) -import BasicTypes ( Boxity(..) ) import ListSetOps ( findDupsEq ) import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) @@ -424,7 +424,7 @@ rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty - ; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty' + ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -991,7 +991,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} where doc = text "In the definition of data constructor" <+> quotes (ppr name) - get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) + get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy (HsBoxyTuple liftedTypeKind) tys)) rnConResult :: SDoc -> HsConDetails (LHsType Name) [ConDeclField Name] diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 392e411b37..770ef28959 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -7,7 +7,8 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred, + rnHsSigType, rnHsTypeFVs, rnConDeclFields, + rnIPName, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, @@ -29,6 +30,7 @@ import RnHsSyn ( extractHsTyNames ) import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad +import IfaceEnv ( newIPName ) import RdrName import PrelNames import TysPrim ( funTyConName ) @@ -37,7 +39,7 @@ import SrcLoc import NameSet import Util ( filterOut ) -import BasicTypes ( compareFixity, funTyFixity, negateFixity, +import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..) ) import Outputable import FastString @@ -172,9 +174,15 @@ rnHsType doc (HsAppTy ty1 ty2) = do ty2' <- rnLHsType doc ty2 return (HsAppTy ty1' ty2') -rnHsType doc (HsPredTy pred) = do - pred' <- rnPred doc pred - return (HsPredTy pred') +rnHsType doc (HsIParamTy n ty) = do + ty' <- rnLHsType doc ty + n' <- rnIPName n + return (HsIParamTy n' ty') + +rnHsType doc (HsEqTy ty1 ty2) = do + ty1' <- rnLHsType doc ty1 + ty2' <- rnLHsType doc ty2 + return (HsEqTy ty1' ty2') rnHsType _ (HsSpliceTy sp _ k) = do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs @@ -243,28 +251,10 @@ rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) rnContext doc = wrapLocM (rnContext' doc) rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) -rnContext' doc ctxt = mapM (rnLPred doc) ctxt - -rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) -rnLPred doc = wrapLocM (rnPred doc) - -rnPred :: SDoc -> HsPred RdrName - -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name) -rnPred doc (HsClassP clas tys) - = do { clas_name <- lookupOccRn clas - ; tys' <- rnLHsTypes doc tys - ; return (HsClassP clas_name tys') - } -rnPred doc (HsEqualP ty1 ty2) - = do { ty1' <- rnLHsType doc ty1 - ; ty2' <- rnLHsType doc ty2 - ; return (HsEqualP ty1' ty2') - } -rnPred doc (HsIParam n ty) - = do { name <- newIPNameRn n - ; ty' <- rnLHsType doc ty - ; return (HsIParam name ty') - } +rnContext' doc ctxt = mapM (rnLHsType doc) ctxt + +rnIPName :: IPName RdrName -> RnM (IPName Name) +rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n))) \end{code} diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 3debe8eabf..cca940f1c0 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -1618,7 +1618,7 @@ argToPat env in_scope val_env (Cast arg co) arg_occ { -- Make a wild-card pattern for the coercion uniq <- getUniqueUs ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoType ty1 ty2) + co_var = mkCoVar co_name (mkCoercionType ty1 ty2) ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } where Pair ty1 ty2 = coercionKind co diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index ff536f5e78..68d023b52c 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -1578,7 +1578,7 @@ mkCallUDs f args _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts , ppr (map interestingDict dicts)] (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = tyVarsOfTheta theta + constrained_tyvars = tyVarsOfTypes theta n_tyvars = length tyvars n_dicts = length theta diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 7627ac9b04..223cb81e8c 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -24,7 +24,7 @@ import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) import Type import Coercion ( mkSymCo, splitNewTypeRepCo_maybe ) -import BasicTypes ( Boxity(..) ) +import BasicTypes ( TupleSort(..) ) import Literal ( absentLiteralOf ) import UniqSupply import Unique @@ -450,7 +450,7 @@ mkWWcpr body_ty RetCPR let (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) arg_vars = varsToCoreExprs args - ubx_tup_con = tupleCon Unboxed n_con_args + ubx_tup_con = tupleCon UnboxedTuple n_con_args ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) con_app = mkProductBox args body_ty diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 028f339c88..1690079bba 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -43,13 +43,14 @@ import TcEnv import InstEnv import FunDeps import TcMType +import Type import TcType import Class import Unify import HscTypes import Id import Name -import Var ( Var, TyVar, EvVar, varType, setVarType ) +import Var ( Var, EvVar, varType, setVarType ) import VarEnv import VarSet import PrelNames @@ -209,13 +210,14 @@ instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper instCallConstraints _ [] = return idHsWrapper -instCallConstraints origin (EqPred ty1 ty2 : preds) -- Try short-cut - = do { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2) - ; co <- unifyType ty1 ty2 +instCallConstraints origin (pred : preds) + | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut + = do { traceTc "instCallConstraints" $ ppr (mkEqPred (ty1, ty2)) + ; co <- unifyType ty1 ty2 ; co_fn <- instCallConstraints origin preds - ; return (co_fn <.> WpEvApp (EvCoercion co)) } + ; return (co_fn <.> WpEvApp (EvCoercionBox co)) } -instCallConstraints origin (pred : preds) + | otherwise = do { ev_var <- emitWanted origin pred ; co_fn <- instCallConstraints origin preds ; return (co_fn <.> WpEvApp (EvId ev_var)) } @@ -485,9 +487,13 @@ hasEqualities :: [EvVar] -> Bool -- Has a bunch of canonical constraints (all givens) got any equalities in it? hasEqualities givens = any (has_eq . evVarPred) givens where - has_eq (EqPred {}) = True - has_eq (IParam {}) = False - has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls) + has_eq = has_eq' . predTypePredTree + + has_eq' (EqPred {}) = True + has_eq' (IPPred {}) = False + has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls) + has_eq' (TuplePred ts) = any has_eq' ts + has_eq' (IrredPred _) = True -- Might have equalities in it after reduction? ---------------- Getting free tyvars ------------------------- tyVarsOfWC :: WantedConstraints -> TyVarSet @@ -507,7 +513,7 @@ tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX tyVarsOfEvVar :: EvVar -> TyVarSet -tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev +tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev tyVarsOfEvVars :: [EvVar] -> TyVarSet tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 7ce5fc1a57..774cea5c51 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -43,17 +43,17 @@ import Control.Monad \begin{code} tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr -> TcRhoType -- Expected type of whole proc expression - -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion) + -> TcM (OutPat TcId, LHsCmdTop TcId, LCoercion) tcProc pat cmd exp_ty = newArrowScope $ - do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty - ; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 + do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ tcCmdTop cmd_env cmd [] res_ty - ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty)) - ; return (pat', cmd', res_coi) } + ; let res_co = mkTransCo co (mkAppCo co1 (mkReflCo res_ty)) + ; return (pat', cmd', res_co) } \end{code} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 3597ebf426..fa292a6d73 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -459,7 +459,7 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) = do { mono_ty <- zonkTcTypeCarefully (idType mono_id) ; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty my_tvs = filter (`elemVarSet` used_tvs) qtvs - used_tvs = tyVarsOfTheta theta `unionVarSet` tyVarsOfType mono_ty + used_tvs = tyVarsOfTypes theta `unionVarSet` tyVarsOfType mono_ty poly_id = case mb_sig of Nothing -> mkLocalId poly_name inferred_poly_ty @@ -919,7 +919,7 @@ unifyCtxts (sig1 : sigs) unify_ctxt sig@(TcSigInfo { sig_theta = theta }) = setSrcSpan (sig_loc sig) $ addErrCtxt (sigContextsCtxt sig1 sig) $ - do { cois <- unifyTheta theta1 theta + do { mk_cos <- unifyTheta theta1 theta ; -- Check whether all coercions are identity coercions -- That can happen if we have, say -- f :: C [a] => ... @@ -927,7 +927,7 @@ unifyCtxts (sig1 : sigs) -- where F is a type function and (F a ~ [a]) -- Then unification might succeed with a coercion. But it's much -- much simpler to require that such signatures have identical contexts - checkTc (all isReflCo cois) + checkTc (isReflMkCos mk_cos) (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) } diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index a18ddb3375..0bf1169c54 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -22,7 +22,7 @@ import Name import Var import VarEnv ( TidyEnv ) import Outputable -import Control.Monad ( unless, when, zipWithM, zipWithM_, foldM ) +import Control.Monad ( unless, when, zipWithM, zipWithM_, foldM, liftM, forM ) import MonadUtils import Control.Applicative ( (<|>) ) @@ -96,7 +96,7 @@ multiple times. \begin{code} -- Flatten a bunch of types all at once. -flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts) +flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [LCoercion], CanonicalCts) -- Coercions :: Xi ~ Type flattenMany ctxt tys = do { (xis, cos, cts_s) <- mapAndUnzip3M (flatten ctxt) tys @@ -105,15 +105,16 @@ flattenMany ctxt tys -- 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. -flatten :: CtFlavor -> TcType -> TcS (Xi, Coercion, CanonicalCts) --- Postcondition: Coercion :: Xi ~ TcType +flatten :: CtFlavor -> TcType -> TcS (Xi, LCoercion, CanonicalCts) +-- Postcondition: Coercion :: Xi ~ TcType +-- Postcondition: CanonicalCts are all CFunEqCan flatten ctxt ty | Just ty' <- tcView ty = do { (xi, co, ccs) <- flatten ctxt ty' -- Preserve type synonyms if possible -- We can tell if ty' is function-free by -- whether there are any floated constraints - ; if isReflCo co then + ; if isReflCo co then return (ty, mkReflCo ty, emptyCCan) else return (xi, co, ccs) } @@ -145,50 +146,44 @@ flatten fl (TyConApp tc tys) = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated do { (xis, cos, ccs) <- flattenMany fl tys ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis - (cos_args, cos_rest) = splitAt (tyConArity tc) cos -- The type function might be *over* saturated -- in which case the remaining arguments should -- be dealt with by AppTys fam_ty = mkTyConApp tc xi_args - ; (ret_co, rhs_var, ct) <- + ; (ret_eqv, rhs_var, ct) <- do { is_cached <- lookupFlatCacheMap tc xi_args fl ; case is_cached of - Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan) + Just (rhs_var,ret_eqv,_fl) -> return (ret_eqv, rhs_var, emptyCCan) Nothing | isGivenOrSolved fl -> do { rhs_var <- newFlattenSkolemTy fam_ty - ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty) - ; let ct = CFunEqCan { cc_id = cv + ; eqv <- newGivenEqVar fam_ty rhs_var (mkReflCo fam_ty) + ; let ct = CFunEqCan { cc_id = eqv , cc_flavor = fl -- Given , cc_fun = tc , cc_tyargs = xi_args , cc_rhs = rhs_var } - ; let ret_co = mkCoVarCo cv - ; updateFlatCacheMap tc xi_args rhs_var fl ret_co - ; return $ (ret_co, rhs_var, singleCCan ct) } + ; updateFlatCacheMap tc xi_args rhs_var fl eqv + ; return (eqv, rhs_var, singleCCan ct) } | otherwise -> -- Derived or Wanted: make a new *unification* flatten variable do { rhs_var <- newFlexiTcSTy (typeKind fam_ty) - ; cv <- newCoVar fam_ty rhs_var - ; let ct = CFunEqCan { cc_id = cv + ; eqv <- newEqVar fam_ty rhs_var + ; let ct = CFunEqCan { cc_id = eqv , cc_flavor = mkWantedFlavor fl -- Always Wanted, not Derived , cc_fun = tc , cc_tyargs = xi_args , cc_rhs = rhs_var } - ; let ret_co = mkCoVarCo cv - ; updateFlatCacheMap tc xi_args rhs_var fl ret_co - ; return $ (ret_co, rhs_var, singleCCan ct) } } + ; updateFlatCacheMap tc xi_args rhs_var fl eqv + ; return (eqv, rhs_var, singleCCan ct) } } + ; let ret_co = mkEqVarLCo ret_eqv + (cos_args, cos_rest) = splitAt (tyConArity tc) cos ; return ( foldl AppTy rhs_var xi_rest - , foldl AppCo (mkSymCo ret_co - `mkTransCo` mkTyConAppCo tc cos_args) + , foldl AppCo (mkSymCo ret_co `mkTransCo` mkTyConAppCo tc cos_args) cos_rest , ccs `andCCan` ct) } -flatten ctxt (PredTy pred) - = do { (pred', co, ccs) <- flattenPred ctxt pred - ; return (PredTy pred', co, ccs) } - flatten ctxt ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables @@ -202,19 +197,6 @@ flatten ctxt ty@(ForAllTy {}) ; unless (isEmptyBag bad_eqs) (flattenForAllErrorTcS ctxt ty bad_eqs) ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs) } - ---------------- -flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, Coercion, CanonicalCts) -flattenPred ctxt (ClassP cls tys) - = do { (tys', cos, ccs) <- flattenMany ctxt tys - ; return (ClassP cls tys', mkPredCo $ ClassP cls cos, ccs) } -flattenPred ctxt (IParam nm ty) - = do { (ty', co, ccs) <- flatten ctxt ty - ; return (IParam nm ty', mkPredCo $ IParam nm co, ccs) } -flattenPred ctxt (EqPred ty1 ty2) - = do { (ty1', co1, ccs1) <- flatten ctxt ty1 - ; (ty2', co2, ccs2) <- flatten ctxt ty2 - ; return (EqPred ty1' ty2', mkPredCo $ EqPred co1 co2, ccs1 `andCCan` ccs2) } \end{code} %************************************************************************ @@ -244,13 +226,29 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList canon_one fev wl = do { wl' <- mkCanonicalFEV fev ; return (unionWorkList wl' wl) } - mkCanonical :: CtFlavor -> EvVar -> TcS WorkList -mkCanonical fl ev = case evVarPred ev of - ClassP clas tys -> canClassToWorkList fl ev clas tys - IParam ip ty -> canIPToWorkList fl ev ip ty - EqPred ty1 ty2 -> canEqToWorkList fl ev ty1 ty2 - +mkCanonical fl ev = go ev (predTypePredTree (evVarPred ev)) + where + go ev (ClassPred clas tys) = canClassToWorkList fl ev clas tys + go ev (EqPred ty1 ty2) = canEqToWorkList fl ev ty1 ty2 + go ev (IPPred ip ty) = canIPToWorkList fl ev ip ty + go ev (TuplePred tys) = do + (mb_evs', wlists) <- liftM unzip $ forM (tys `zip` [0..]) $ \(ty, n) -> do + ev' <- newEvVar (predTreePredType ty) + mb_ev <- case fl of + Wanted {} -> return (Just ev') + Given {} -> setEvBind ev' (EvTupleSel ev n) >> return Nothing + Derived {} -> return Nothing -- Derived ips: we don't set any evidence + + liftM ((,) mb_ev) $ go ev' ty + + -- If we Wanted this TuplePred we have to bind it from the newly Wanted components + case sequence mb_evs' of + Just evs' -> setEvBind ev (EvTupleMk evs') + Nothing -> return () + + return (unionWorkLists wlists) + go ev (IrredPred ev_ty) = canIrredEvidence fl ev ev_ty canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList canClassToWorkList fl v cn tys @@ -262,8 +260,8 @@ canClassToWorkList fl v cn tys -- The cos are all identities if fl=Given, -- hence nothing to do else do { v' <- newDictVar cn xis -- D xis - ; when (isWanted fl) $ setDictBind v (EvCast v' dict_co) - ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co)) + ; when (isWanted fl) $ setEvBind v (EvCast v' dict_co) + ; when (isGivenOrSolved fl) $ setEvBind v' (EvCast v (mkSymCo dict_co)) -- NB: No more setting evidence for derived now ; return v' } @@ -348,15 +346,14 @@ happen. newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS WorkList -- Returns superclasses, see Note [Adding superclasses] -newSCWorkFromFlavored ev orig_flavor cls xis - | isDerived orig_flavor +newSCWorkFromFlavored ev flavor cls xis + | isDerived flavor = return emptyWorkList -- Deriveds don't yield more superclasses because we will -- add them transitively in the case of wanteds. - | Just gk <- isGiven_maybe orig_flavor + | Just gk <- isGiven_maybe flavor = case gk of GivenOrig -> do { let sc_theta = immSuperClasses cls xis - flavor = orig_flavor ; sc_vars <- mapM newEvVar sc_theta ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]] ; mkCanonicals flavor sc_vars } @@ -371,17 +368,21 @@ newSCWorkFromFlavored ev orig_flavor cls xis | otherwise -- Wanted case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis impr_theta = filter is_improvement_pty sc_rec_theta - Wanted wloc = orig_flavor + Wanted wloc = flavor ; der_ids <- mapM newDerivedId impr_theta ; mkCanonicals (Derived wloc) der_ids } is_improvement_pty :: PredType -> Bool -- Either it's an equality, or has some functional dependency -is_improvement_pty (EqPred {}) = True -is_improvement_pty (ClassP cls _ty) = not $ null fundeps - where (_,fundeps,_,_,_,_) = classExtraBigSig cls -is_improvement_pty _ = False +is_improvement_pty ty = go (predTypePredTree ty) + where + go (EqPred {}) = True + go (ClassPred cls _ty) = not $ null fundeps + where (_,fundeps,_,_,_,_) = classExtraBigSig cls + go (IPPred {}) = False + go (TuplePred ts) = any go ts + go (IrredPred {}) = True -- Might have equalities after reduction? @@ -395,103 +396,121 @@ canIPToWorkList fl v nm ty , cc_ip_nm = nm , cc_ip_ty = ty }) +canIrredEvidence :: CtFlavor -> EvVar -> TcType -> TcS WorkList +canIrredEvidence fl v ty = do + (xi, co, ccs) <- flatten fl ty -- co :: xi ~ ty + v' <- newEvVar xi + case fl of + Wanted {} -> setEvBind v (EvCast v' co) + Given {} -> setEvBind v' (EvCast v (mkSymCo co)) + Derived {} -> return () -- Derived ips: we don't set any evidence + + return (workListFromEqs ccs `unionWorkList` + workListFromNonEq (CIrredEvCan { cc_id = v' + , cc_flavor = fl + , cc_ty = xi })) + ----------------- canEqToWorkList :: CtFlavor -> EvVar -> Type -> Type -> TcS WorkList -canEqToWorkList fl cv ty1 ty2 = do { cts <- canEq fl cv ty1 ty2 - ; return $ workListFromEqs cts } +canEqToWorkList fl eqv ty1 ty2 = do { cts <- canEq fl eqv ty1 ty2 + ; return $ workListFromEqs cts } -canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts -canEq fl cv ty1 ty2 +canEq :: CtFlavor -> EqVar -> Type -> Type -> TcS CanonicalCts +canEq fl eqv ty1 ty2 | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a - = do { when (isWanted fl) (setCoBind cv (mkReflCo ty1)) + = do { when (isWanted fl) (setEqBind eqv (mkReflCo ty1)) ; return emptyCCan } -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ -canEq fl cv ty1@(TyVarTy {}) ty2 +canEq fl eqv ty1@(TyVarTy {}) ty2 = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (classify ty1) (classify ty2) } -canEq fl cv ty1 ty2@(TyVarTy {}) + ; canEqLeaf untch fl eqv (classify ty1) (classify ty2) } +canEq fl eqv ty1 ty2@(TyVarTy {}) = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (classify ty1) (classify ty2) } + ; canEqLeaf untch fl eqv (classify ty1) (classify ty2) } -- NB: don't use VarCls directly because tv1 or tv2 may be scolems! -- Split up an equality between function types into two equalities. -canEq fl cv (FunTy s1 t1) (FunTy s2 t2) - = do { (argv, resv) <- +canEq fl eqv (FunTy s1 t1) (FunTy s2 t2) + = do { (argeqv, reseqv) <- if isWanted fl then - do { argv <- newCoVar s1 s2 - ; resv <- newCoVar t1 t2 - ; setCoBind cv $ - mkFunCo (mkCoVarCo argv) (mkCoVarCo resv) - ; return (argv,resv) } + do { argeqv <- newEqVar s1 s2 + ; reseqv <- newEqVar t1 t2 + ; setEqBind eqv + (mkFunCo (mkEqVarLCo argeqv) (mkEqVarLCo reseqv)) + ; return (argeqv,reseqv) } else if isGivenOrSolved fl then - let [arg,res] = decomposeCo 2 (mkCoVarCo cv) - in do { argv <- newGivenCoVar s1 s2 arg - ; resv <- newGivenCoVar t1 t2 res - ; return (argv,resv) } + do { argeqv <- newEqVar s1 s2 + ; setEqBind argeqv (mkNthCo 0 (mkEqVarLCo eqv)) + ; reseqv <- newEqVar t1 t2 + ; setEqBind reseqv (mkNthCo 1 (mkEqVarLCo eqv)) + ; return (argeqv,reseqv) } else -- Derived - do { argv <- newDerivedId (EqPred s1 s2) - ; resv <- newDerivedId (EqPred t1 t2) - ; return (argv,resv) } + do { argeqv <- newDerivedId (mkEqPred (s1, s2)) + ; reseqv <- newDerivedId (mkEqPred (t1, t2)) + ; return (argeqv, reseqv) } - ; cc1 <- canEq fl argv s1 s2 -- inherit original kinds and locations - ; cc2 <- canEq fl resv t1 t2 + ; cc1 <- canEq fl argeqv s1 s2 -- inherit original kinds and locations + ; cc2 <- canEq fl reseqv t1 t2 ; return (cc1 `andCCan` cc2) } -canEq fl cv (TyConApp fn tys) ty2 +canEq fl eqv (TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) } -canEq fl cv ty1 (TyConApp fn tys) + ; canEqLeaf untch fl eqv (FunCls fn tys) (classify ty2) } +canEq fl eqv ty1 (TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) } + ; canEqLeaf untch fl eqv (classify ty1) (FunCls fn tys) } -canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) +canEq fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 , tc1 == tc2 , length tys1 == length tys2 = -- Generate equalities for each of the corresponding arguments - do { argsv + do { argeqvs <- if isWanted fl then - do { argsv <- zipWithM newCoVar tys1 tys2 - ; setCoBind cv $ - mkTyConAppCo tc1 (map mkCoVarCo argsv) - ; return argsv } + do { argeqvs <- zipWithM newEqVar tys1 tys2 + ; setEqBind eqv + (mkTyConAppCo tc1 (map mkEqVarLCo argeqvs)) + ; return argeqvs } else if isGivenOrSolved fl then - let cos = decomposeCo (length tys1) (mkCoVarCo cv) - in zipWith3M newGivenCoVar tys1 tys2 cos + let go_one ty1 ty2 n = do + argeqv <- newEqVar ty1 ty2 + setEqBind argeqv (mkNthCo n (mkEqVarLCo eqv)) + return argeqv + in zipWith3M go_one tys1 tys2 [0..] else -- Derived - zipWithM (\t1 t2 -> newDerivedId (EqPred t1 t2)) tys1 tys2 + zipWithM (\t1 t2 -> newDerivedId (mkEqPred (t1, t2))) tys1 tys2 - ; andCCans <$> zipWith3M (canEq fl) argsv tys1 tys2 } + ; andCCans <$> zipWith3M (canEq fl) argeqvs tys1 tys2 } -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify -canEq fl cv ty1 ty2 +canEq fl eqv ty1 ty2 | Nothing <- tcView ty1 -- Naked applications ONLY , Nothing <- tcView ty2 -- See Note [Naked given applications] , Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 = if isWanted fl - then do { cv1 <- newCoVar s1 s2 - ; cv2 <- newCoVar t1 t2 - ; setCoBind cv $ - mkAppCo (mkCoVarCo cv1) (mkCoVarCo cv2) - ; cc1 <- canEq fl cv1 s1 s2 - ; cc2 <- canEq fl cv2 t1 t2 + then do { eqv1 <- newEqVar s1 s2 + ; eqv2 <- newEqVar t1 t2 + ; setEqBind eqv + (mkAppCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2)) + ; cc1 <- canEq fl eqv1 s1 s2 + ; cc2 <- canEq fl eqv2 t1 t2 ; return (cc1 `andCCan` cc2) } else if isDerived fl - then do { cv1 <- newDerivedId (EqPred s1 s2) - ; cv2 <- newDerivedId (EqPred t1 t2) - ; cc1 <- canEq fl cv1 s1 s2 - ; cc2 <- canEq fl cv2 t1 t2 + then do { eqv1 <- newDerivedId (mkEqPred (s1, s2)) + ; eqv2 <- newDerivedId (mkEqPred (t1, t2)) + ; cc1 <- canEq fl eqv1 s1 s2 + ; cc2 <- canEq fl eqv2 t1 t2 ; return (cc1 `andCCan` cc2) } else do { traceTcS "canEq/(app case)" $ @@ -501,21 +520,21 @@ canEq fl cv ty1 ty2 -- because we no longer have 'left' and 'right' } -canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {}) +canEq fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2, Wanted {} <- fl - = canEqFailure fl cv + = canEqFailure fl eqv | otherwise = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) ; return emptyCCan } -- Finally expand any type synonym applications. -canEq fl cv ty1 ty2 | Just ty1' <- tcView ty1 = canEq fl cv ty1' ty2 -canEq fl cv ty1 ty2 | Just ty2' <- tcView ty2 = canEq fl cv ty1 ty2' -canEq fl cv _ _ = canEqFailure fl cv +canEq fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq fl eqv ty1' ty2 +canEq fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq fl eqv ty1 ty2' +canEq fl eqv _ _ = canEqFailure fl eqv canEqFailure :: CtFlavor -> EvVar -> TcS CanonicalCts -canEqFailure fl cv = return (singleCCan (mkFrozenError fl cv)) +canEqFailure fl eqv = return (singleCCan (mkFrozenError fl eqv)) \end{code} Note [Naked given applications] @@ -709,7 +728,7 @@ reOrient _fl (FskCls {}) (OtherCls {}) = False ------------------ canEqLeaf :: TcsUntouchables - -> CtFlavor -> CoVar + -> CtFlavor -> EqVar -> TypeClassifier -> TypeClassifier -> TcS CanonicalCts -- Canonicalizing "leaf" equality constraints which cannot be -- decomposed further (ie one of the types is a variable or @@ -718,35 +737,38 @@ canEqLeaf :: TcsUntouchables -- Preconditions: -- * one of the two arguments is not OtherCls -- * the two types are not equal (looking through synonyms) -canEqLeaf _untch fl cv cls1 cls2 +canEqLeaf _untch fl eqv cls1 cls2 | cls1 `re_orient` cls2 - = do { cv' <- if isWanted fl - then do { cv' <- newCoVar s2 s1 - ; setCoBind cv $ mkSymCo (mkCoVarCo cv') - ; return cv' } - else if isGivenOrSolved fl then - newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv)) - else -- Derived - newDerivedId (EqPred s2 s1) - ; canEqLeafOriented fl cv' cls2 s1 } + = do { eqv' <- if isWanted fl + then do { eqv' <- newEqVar s2 s1 + ; setEqBind eqv (mkSymCo (mkEqVarLCo eqv')) + ; return eqv' } + else if isGivenOrSolved fl then + do { eqv' <- newEqVar s2 s1 + ; setEqBind eqv' (mkSymCo (mkEqVarLCo eqv)) + ; return eqv' } + + else -- Derived + newDerivedId (mkEqPred (s2, s1)) + ; canEqLeafOriented fl eqv' cls2 s1 } | otherwise = do { traceTcS "canEqLeaf" (ppr (unClassify cls1) $$ ppr (unClassify cls2)) - ; canEqLeafOriented fl cv cls1 s2 } + ; canEqLeafOriented fl eqv cls1 s2 } where re_orient = reOrient fl s1 = unClassify cls1 s2 = unClassify cls2 ------------------ -canEqLeafOriented :: CtFlavor -> CoVar +canEqLeafOriented :: CtFlavor -> EqVar -> TypeClassifier -> TcType -> TcS CanonicalCts -- First argument is not OtherCls -canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1 +canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2 -- cv : F tys1 | let k1 = kindAppResult (tyConKind fn) tys1, let k2 = typeKind s2, not (k1 `compatKind` k2) -- Establish the kind invariant for CFunEqCan - = canEqFailure fl cv + = canEqFailure fl eqv -- Eagerly fails, see Note [Kind errors] in TcInteract | otherwise @@ -757,23 +779,25 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1 -- co2 :: xi2 ~ s2 ; let ccs = ccs1 `andCCan` ccs2 no_flattening_happened = all isReflCo (co2:cos1) - ; cv_new <- if no_flattening_happened then return cv - else if isGivenOrSolved fl then return cv - else if isWanted fl then - do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2 - -- cv' : F xis ~ xi2 - ; let -- fun_co :: F xis1 ~ F tys1 - fun_co = mkTyConAppCo fn cos1 - -- want_co :: F tys1 ~ s2 - want_co = mkSymCo fun_co - `mkTransCo` mkCoVarCo cv' - `mkTransCo` co2 - ; setCoBind cv want_co - ; return cv' } - else -- Derived - newDerivedId (EqPred (unClassify (FunCls fn xis1)) xi2) - - ; let final_cc = CFunEqCan { cc_id = cv_new + ; eqv_new <- if no_flattening_happened then return eqv + else if isGivenOrSolved fl then return eqv + else if isWanted fl then + do { eqv' <- newEqVar (unClassify (FunCls fn xis1)) xi2 + + ; let -- cv' : F xis ~ xi2 + cv' = mkEqVarLCo eqv' + -- fun_co :: F xis1 ~ F tys1 + fun_co = mkTyConAppCo fn cos1 + -- want_co :: F tys1 ~ s2 + want_co = mkSymCo fun_co + `mkTransCo` cv' + `mkTransCo` co2 + ; setEqBind eqv want_co + ; return eqv' } + else -- Derived + newDerivedId (mkEqPred (unClassify (FunCls fn xis1), xi2)) + + ; let final_cc = CFunEqCan { cc_id = eqv_new , cc_flavor = fl , cc_fun = fn , cc_tyargs = xis1 @@ -781,18 +805,18 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1 ; return $ ccs `extendCCans` final_cc } -- Otherwise, we have a variable on the left, so call canEqLeafTyVarLeft -canEqLeafOriented fl cv (FskCls tv) s2 - = canEqLeafTyVarLeft fl cv tv s2 -canEqLeafOriented fl cv (VarCls tv) s2 - = canEqLeafTyVarLeft fl cv tv s2 -canEqLeafOriented _ cv (OtherCls ty1) ty2 - = pprPanic "canEqLeaf" (ppr cv $$ ppr ty1 $$ ppr ty2) - -canEqLeafTyVarLeft :: CtFlavor -> CoVar -> TcTyVar -> TcType -> TcS CanonicalCts +canEqLeafOriented fl eqv (FskCls tv) s2 + = canEqLeafTyVarLeft fl eqv tv s2 +canEqLeafOriented fl eqv (VarCls tv) s2 + = canEqLeafTyVarLeft fl eqv tv s2 +canEqLeafOriented _ eqv (OtherCls ty1) ty2 + = pprPanic "canEqLeaf" (ppr eqv $$ ppr ty1 $$ ppr ty2) + +canEqLeafTyVarLeft :: CtFlavor -> EqVar -> TcTyVar -> TcType -> TcS CanonicalCts -- Establish invariants of CTyEqCans -canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2 +canEqLeafTyVarLeft fl eqv tv s2 -- cv : tv ~ s2 | not (k1 `compatKind` k2) -- Establish the kind invariant for CTyEqCan - = canEqFailure fl cv + = canEqFailure fl eqv -- Eagerly fails, see Note [Kind errors] in TcInteract | otherwise = do { (xi2, co, ccs2) <- flatten fl s2 -- Flatten RHS co : xi2 ~ s2 @@ -800,19 +824,19 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2 -- unfolded version of the RHS, if we had to -- unfold any type synonyms to get rid of tv. ; case mxi2' of { - Nothing -> canEqFailure fl cv ; + Nothing -> canEqFailure fl eqv ; Just xi2' -> do { let no_flattening_happened = isReflCo co - ; cv_new <- if no_flattening_happened then return cv - else if isGivenOrSolved fl then return cv - else if isWanted fl then - do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2 - ; setCoBind cv (mkCoVarCo cv' `mkTransCo` co) - ; return cv' } - else -- Derived - newDerivedId (EqPred (mkTyVarTy tv) xi2') - - ; return $ ccs2 `extendCCans` CTyEqCan { cc_id = cv_new + ; eqv_new <- if no_flattening_happened then return eqv + else if isGivenOrSolved fl then return eqv + else if isWanted fl then + do { eqv' <- newEqVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2 + ; setEqBind eqv $ mkTransCo (mkEqVarLCo eqv') co + ; return eqv' } + else -- Derived + newDerivedId (mkEqPred (mkTyVarTy tv, xi2')) + + ; return $ ccs2 `extendCCans` CTyEqCan { cc_id = eqv_new , cc_flavor = fl , cc_tyvar = tv , cc_rhs = xi2' } } } } @@ -877,9 +901,6 @@ expandAway tv ty@(ForAllTy {}) Nothing else do { rho' <- expandAway tv rho ; return (mkForAllTys tvs rho') } -expandAway tv (PredTy pred) - = do { pred' <- expandAwayPred tv pred - ; return (PredTy pred') } -- 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 @@ -887,19 +908,6 @@ expandAway tv (PredTy pred) expandAway tv ty@(TyConApp tc tys) = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv) -expandAwayPred :: TcTyVar -> TcPredType -> Maybe TcPredType -expandAwayPred tv (ClassP cls tys) - = do { tys' <- mapM (expandAway tv) tys; return (ClassP cls tys') } -expandAwayPred tv (EqPred ty1 ty2) - = do { ty1' <- expandAway tv ty1 - ; ty2' <- expandAway tv ty2 - ; return (EqPred ty1' ty2') } -expandAwayPred tv (IParam nm ty) - = do { ty' <- expandAway tv ty - ; return (IParam nm ty') } - - - \end{code} Note [Type synonyms and canonicalization] @@ -1007,7 +1015,7 @@ now!). rewriteWithFunDeps :: [Equation] -> [Xi] -> WantedLoc - -> TcS (Maybe ([Xi], [Coercion], [(EvVar,WantedLoc)])) + -> TcS (Maybe ([Xi], [LCoercion], [(EvVar,WantedLoc)])) -- Not quite a WantedEvVar unfortunately -- Because our intention could be to make -- it derived at the end of the day @@ -1015,7 +1023,7 @@ rewriteWithFunDeps :: [Equation] -- Post: returns no trivial equalities (identities) rewriteWithFunDeps eqn_pred_locs xis wloc = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs - ; let fd_ev_pos :: [(Int,(EvVar,WantedLoc))] + ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))] fd_ev_pos = concat fd_ev_poss (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) ; if null fd_ev_pos then return Nothing @@ -1034,9 +1042,9 @@ instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs = let sty1 = Type.substTy subst ty1 sty2 = Type.substTy subst ty2 in if eqType sty1 sty2 then return ievs -- Return no trivial equalities - else do { ev <- newCoVar sty1 sty2 + else do { eqv <- newEqVar sty1 sty2 ; let wl' = push_ctx wl - ; return $ (i,(ev,wl')):ievs } + ; return $ (i,(eqv,wl')):ievs } push_ctx :: WantedLoc -> WantedLoc push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc @@ -1046,27 +1054,27 @@ mkEqnMsg :: (TcPredType, SDoc) mkEqnMsg (pred1,from1) (pred2,from2) tidy_env = do { zpred1 <- TcM.zonkTcPredType pred1 ; zpred2 <- TcM.zonkTcPredType pred2 - ; let { tpred1 = tidyPred tidy_env zpred1 - ; tpred2 = tidyPred tidy_env zpred2 } + ; let { tpred1 = tidyType tidy_env zpred1 + ; tpred2 = tidyType tidy_env zpred2 } ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] ; return (tidy_env, msg) } -rewriteDictParams :: [(Int,(EvVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) +rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) -> [Type] -- A sequence of types: tys - -> [(Type,Coercion)] -- Returns: [(ty', co : ty' ~ ty)] + -> [(Type,LCoercion)] -- Returns: [(ty', co : ty' ~ ty)] rewriteDictParams param_eqs tys = zipWith do_one tys [0..] where - do_one :: Type -> Int -> (Type,Coercion) + do_one :: Type -> Int -> (Type,LCoercion) do_one ty n = case lookup n param_eqs of - Just wev -> (get_fst_ty wev, mkCoVarCo (fst wev)) + Just wev -> (get_fst_ty wev, mkEqVarLCo (fst wev)) Nothing -> (ty, mkReflCo ty) -- Identity get_fst_ty (wev,_wloc) - | EqPred ty1 _ <- evVarPred wev - = ty1 + | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev ) + = ty1 | otherwise = panic "rewriteDictParams: non equality fundep!?" diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 1d12c33c8a..9fdaf6f6a2 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -21,6 +21,7 @@ import TcBinds import TcUnify import TcHsType import TcMType +import Type ( getClassPredTys_maybe ) import TcType import TcRnMonad import BuildTyCl( TcMethInfo ) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 4a6c52490f..c5166c3b10 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -482,10 +482,9 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ] -- Select only those types that derive Generic ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata - , getClassName c == Just genClassName ] + , isGenClassName c ] ; let sel_deriv_decls = catMaybes [ getTypeName t - | L _ (DerivDecl (L _ t)) <- deriv_decls - , getClassName t == Just genClassName ] + | L _ (DerivDecl (L _ t)) <- deriv_decls ] ; derTyDecls <- mapM tcLookupTyCon $ filter (needsExtras xDerRep (sel_tydata ++ sel_deriv_decls)) allTyNames @@ -504,25 +503,21 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls -- deriving Generic needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata - -- Extracts the name of the class in the deriving - getClassName :: HsType Name -> Maybe Name - getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n - getClassName (HsPredTy (HsClassP n _)) = Just n - getClassName _ = Nothing + -- Extracts the name of the class in the deriving and makes sure it is ours + isGenClassName :: HsType Name -> Bool + isGenClassName ty = case splitHsInstDeclTy_maybe ty of + Just (_, _, cls_name, _) -> cls_name == genClassName + _ -> False -- Extracts the name of the type in the deriving -- This function (and also getClassName above) is not really nice, and I -- might not have covered all possible cases. I wonder if there is no easier -- way to extract class and type name from a LDerivDecl... getTypeName :: HsType Name -> Maybe Name - getTypeName (HsForAllTy _ _ _ (L _ n)) = getTypeName n - getTypeName (HsTyVar n) = Just n - getTypeName (HsOpTy _ (L _ n) _) = Just n - getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n - getTypeName (HsAppTy (L _ n) _) = getTypeName n - getTypeName (HsParTy (L _ n)) = getTypeName n - getTypeName (HsKindSig (L _ n) _) = getTypeName n - getTypeName _ = Nothing + getTypeName ty = do + (_, _, cls_name, [ty]) <- splitHsInstDeclTy_maybe ty + guard (cls_name == genClassName) + fmap fst $ splitHsClassTy_maybe (unLoc ty) extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] @@ -1042,7 +1037,7 @@ cond_functorOK allowFunctions (_, 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` tyVarsOfPred pred + is_bad pred = last_tv `elemVarSet` tyVarsOfType pred data_cons = tyConDataCons rep_tc check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con) @@ -1360,7 +1355,10 @@ inferInstanceContexts oflag infer_specs extendLocalInstEnv inst_specs $ mapM gen_soln infer_specs - ; if (current_solns == new_solns) then + ; let eqList :: (a -> b -> Bool) -> [a] -> [b] -> Bool + eqList f xs ys = length xs == length ys && and (zipWith f xs ys) + + ; if (eqList (eqList eqType) current_solns new_solns) then return [ spec { ds_theta = soln } | (spec, soln) <- zip infer_specs current_solns ] else @@ -1381,7 +1379,7 @@ inferInstanceContexts oflag infer_specs -- Claim: the result instance declaration is guaranteed valid -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys - ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution + ; return (sortLe (\p1 p2 -> cmpType p1 p2 /= GT) theta) } -- Canonicalise before returning the solution where the_pred = mkClassPred clas inst_tys diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 9550232805..aab1a5fd32 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -155,8 +155,8 @@ tcLookupClass :: Name -> TcM Class tcLookupClass name = do thing <- tcLookupGlobal name case thing of - AClass cls -> return cls - _ -> wrongThingErr "class" (AGlobal thing) name + ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls + _ -> wrongThingErr "class" (AGlobal thing) name tcLookupTyCon :: Name -> TcM TyCon tcLookupTyCon name = do diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 254f132d54..0892783d7e 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -15,7 +15,8 @@ import TcMType import TcSMonad import TcType import TypeRep -import Type( isTyVarTy ) +import Type +import Class import Unify ( tcMatchTys ) import Inst import InstEnv @@ -28,6 +29,7 @@ import VarSet import VarEnv import SrcLoc import Bag +import BasicTypes ( IPName ) import ListSetOps( equivClasses ) import Maybes( mapCatMaybes ) import Util @@ -35,7 +37,7 @@ import FastString import Outputable import DynFlags import Data.List( partition ) -import Control.Monad( when, unless ) +import Control.Monad( when, unless, filterM ) \end{code} %************************************************************************ @@ -114,8 +116,8 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli | otherwise -- No insoluble ones = ASSERT( isEmptyBag insols ) - do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats) - (tv_eqs, others) = partition is_tv_eq non_ambigs + do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats) + (tv_eqs, others) = partitionWith is_tv_eq non_ambigs ; groupErrs (reportEqErrs ctxt) tv_eqs ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others @@ -128,9 +130,11 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli -- Report equalities of form (a~ty) first. They are usually -- skolem-equalities, and they cause confusing knock-on -- effects in other errors; see test T4093b. - is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c - = tcIsTyVarTy ty1 || tcIsTyVarTy ty2 - | otherwise = False + is_tv_eq c | Just (ty1, ty2) <- getEqPredTys_maybe (evVarOfPred c) + , tcIsTyVarTy ty1 || tcIsTyVarTy ty2 + = Left (c, (ty1, ty2)) + | otherwise + = Right (c, evVarOfPred c) -- Treat it as "ambiguous" if -- (a) it is a class constraint @@ -138,13 +142,13 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli -- (else we'd prefer to report it as "no instance for...") -- (c) it mentions a (presumably un-filled-in) meta type variable is_ambiguous d = isTyVarClassPred pred - && any isAmbiguousTyVar (varSetElems (tyVarsOfPred pred)) + && any isAmbiguousTyVar (varSetElems (tyVarsOfType pred)) where pred = evVarOfPred d reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM () reportInsoluble ctxt (EvVarX ev flav) - | EqPred ty1 ty2 <- evVarPred ev + | Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev) = setCtFlavorLoc flav $ do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg } ; reportEqErr ctxt2 ty1 ty2 } @@ -160,36 +164,47 @@ reportInsoluble ctxt (EvVarX ev flav) reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () -- The [PredType] are already tidied reportFlat ctxt flats origin - = do { unless (null dicts) $ reportDictErrs ctxt dicts origin - ; unless (null eqs) $ reportEqErrs ctxt eqs origin - ; unless (null ips) $ reportIPErrs ctxt ips origin - ; ASSERT( null others ) return () } + = do { unless (null dicts) $ reportDictErrs ctxt dicts origin + ; unless (null eqs) $ reportEqErrs ctxt eqs origin + ; unless (null ips) $ reportIPErrs ctxt ips origin + ; unless (null irreds) $ reportIrredsErrs ctxt irreds origin } where - (dicts, non_dicts) = partition isClassPred flats - (eqs, non_eqs) = partition isEqPred non_dicts - (ips, others) = partition isIPPred non_eqs + (dicts, eqs, ips, irreds) = go_many (map predTypePredTree flats) + + go_many [] = ([], [], [], []) + go_many (t:ts) = (as ++ as', bs ++ bs', cs ++ cs', ds ++ ds') + where (as, bs, cs, ds) = go t + (as', bs', cs', ds') = go_many ts + + go (ClassPred cls tys) = ([(cls, tys)], [], [], []) + go (EqPred ty1 ty2) = ([], [(ty1, ty2)], [], []) + go (IPPred ip ty) = ([], [], [(ip, ty)], []) + go (IrredPred ty) = ([], [], [], [ty]) + go (TuplePred {}) = panic "reportFlat" + -- TuplePreds should have been expanded away by the constraint + -- simplifier, so they shouldn't show up at this point -------------------------------------------- -- Support code -------------------------------------------- -groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group - -> [WantedEvVar] -- Unsolved wanteds +groupErrs :: ([a] -> CtOrigin -> TcM ()) -- Deal with one group + -> [(WantedEvVar, a)] -- Unsolved wanteds -> TcM () -- Group together insts with the same origin -- We want to report them together in error messages groupErrs _ [] = return () -groupErrs report_err (wanted : wanteds) +groupErrs report_err ((wanted, x) : wanteds) = do { setCtLoc the_loc $ - report_err the_vars (ctLocOrigin the_loc) + report_err the_xs (ctLocOrigin the_loc) ; groupErrs report_err others } where the_loc = evVarX wanted the_key = mk_key the_loc - the_vars = map evVarOfPred (wanted:friends) - (friends, others) = partition is_friend wanteds + the_xs = x:map snd friends + (friends, others) = partition (is_friend . fst) wanteds is_friend friend = mk_key (evVarX friend) `same_key` the_key mk_key :: WantedLoc -> (SrcSpan, CtOrigin) @@ -221,7 +236,7 @@ pprWithArising ev_vars where first_loc = evVarX (head ev_vars) ppr_one (EvVarX v loc) - = hang (parens (pprPredTy (evVarPred v))) 2 (pprArisingAt loc) + = hang (parens (pprType (evVarPred v))) 2 (pprArisingAt loc) addErrorReport :: ReportErrCtxt -> SDoc -> TcM () addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) @@ -234,6 +249,21 @@ getUserGivens (CEC {cec_encl = ctxt}) , not (null givens) ] \end{code} +%************************************************************************ +%* * + Irreducible predicate errors +%* * +%************************************************************************ + +\begin{code} +reportIrredsErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportIrredsErrs ctxt irreds orig + = addErrorReport ctxt msg + where + givens = getUserGivens ctxt + msg = couldNotDeduce givens (irreds, orig) +\end{code} + %************************************************************************ %* * @@ -242,7 +272,7 @@ getUserGivens (CEC {cec_encl = ctxt}) %************************************************************************ \begin{code} -reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportIPErrs :: ReportErrCtxt -> [(IPName Name, Type)] -> CtOrigin -> TcM () reportIPErrs ctxt ips orig = addErrorReport ctxt msg where @@ -250,9 +280,9 @@ reportIPErrs ctxt ips orig msg | null givens = addArising orig $ sep [ ptext (sLit "Unbound implicit parameter") <> plural ips - , nest 2 (pprTheta ips) ] + , nest 2 (pprTheta (map (uncurry mkIPPred) ips)) ] | otherwise - = couldNotDeduce givens (ips, orig) + = couldNotDeduce givens (map (uncurry mkIPPred) ips, orig) \end{code} @@ -263,18 +293,16 @@ reportIPErrs ctxt ips orig %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportEqErrs :: ReportErrCtxt -> [(Type, Type)] -> CtOrigin -> TcM () -- The [PredType] are already tidied reportEqErrs ctxt eqs orig = do { orig' <- zonkTidyOrigin ctxt orig ; mapM_ (report_one orig') eqs } where - report_one orig (EqPred ty1 ty2) + report_one orig (ty1, ty2) = do { let extra = getWantedEqExtra orig ty1 ty2 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt } ; reportEqErr ctxt' ty1 ty2 } - report_one _ pred - = pprPanic "reportEqErrs" (ppr pred) getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) @@ -392,7 +420,7 @@ misMatchOrCND ctxt ty1 ty2 | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally -- insoluble, don't report the context | null givens = misMatchMsg ty1 ty2 - | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig) + | otherwise = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin (UnifyOrigin ty1 ty2) @@ -487,14 +515,14 @@ Warn of loopy local equalities that were dropped. %************************************************************************ \begin{code} -reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportDictErrs :: ReportErrCtxt -> [(Class, [Type])] -> CtOrigin -> TcM () reportDictErrs ctxt wanteds orig = do { inst_envs <- tcGetInstEnvs - ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds + ; non_overlaps <- filterM (reportOverlap ctxt inst_envs orig) wanteds ; unless (null non_overlaps) $ addErrorReport ctxt (mk_no_inst_err non_overlaps) } where - mk_no_inst_err :: [PredType] -> SDoc + mk_no_inst_err :: [(Class, [Type])] -> SDoc mk_no_inst_err wanteds | null givens -- Top level = vcat [ addArising orig $ @@ -507,7 +535,7 @@ reportDictErrs ctxt wanteds orig , show_fixes (fixes1 ++ fixes2 ++ fixes3) ] where givens = getUserGivens ctxt - min_wanteds = mkMinimalBySCs wanteds + min_wanteds = mkMinimalBySCs (map (uncurry mkClassPred) wanteds) fixes2 = case instance_dicts of [] -> [] @@ -549,23 +577,23 @@ reportDictErrs ctxt wanteds orig origin -> Just origin reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin - -> PredType -> TcM (Maybe PredType) + -> (Class, [Type]) -> TcM Bool -- Report an overlap error if this class constraint results -- from an overlap (returning Nothing), otherwise return (Just pred) -reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) +reportOverlap ctxt inst_envs orig (clas, tys) = do { tys_flat <- mapM quickFlattenTy tys -- Note [Flattening in error message generation] ; case lookupInstEnv inst_envs clas tys_flat of - ([], _, _) -> return (Just pred) -- No match + ([], _, _) -> return True -- No match res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return Nothing } } + ; return False } } where -- Normal overlap error mk_overlap_msg (matches, unifiers, False) = ASSERT( not (null matches) ) vcat [ addArising orig (ptext (sLit "Overlapping instances for") - <+> pprPredTy pred) + <+> pprType (mkClassPred clas tys)) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] @@ -590,7 +618,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) empty else -- One match parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), + quotes (pprWithCommas ppr (varSetElems (tyVarsOfTypes tys))), if null (matching_givens) then vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), ptext (sLit "when compiling the other instance declarations")] @@ -608,20 +636,21 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc) , ptext (sLit "at") <+> ppr (ctLocSpan gloc)]) where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) - ev_var_matches (ClassP clas' tys') - | clas' == clas - , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' - = True - ev_var_matches (ClassP clas' tys') = - any ev_var_matches (immSuperClasses clas' tys') - ev_var_matches _ = False + ev_var_matches ty = case getClassPredTys_maybe ty of + Just (clas', tys') + | clas' == clas + , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' + -> True + | otherwise + -> any ev_var_matches (immSuperClasses clas' tys') + Nothing -> False -- Overlap error because of Safe Haskell (first match should be the most -- specific match) mk_overlap_msg (matches, _unifiers, True) = ASSERT( length matches > 1 ) vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") - <+> pprPredTy pred) + <+> pprType (mkClassPred clas tys)) , sep [ptext (sLit "The matching instance is") <> colon, nest 2 (pprInstance $ head ispecs)] , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" @@ -633,16 +662,12 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) where ispecs = [ispec | (ispec, _) <- matches] - -reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP - ---------------------- quickFlattenTy :: TcType -> TcM TcType -- See Note [Flattening in error message generation] quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty' quickFlattenTy ty@(TyVarTy {}) = return ty quickFlattenTy ty@(ForAllTy {}) = return ty -- See -quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes] -- Don't flatten because of the danger or removing a bound variable quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 ; fy2 <- quickFlattenTy ty2 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 29a4756171..fcc8e303d2 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -294,7 +294,7 @@ tcExpr (OpApp arg1 op fix arg2) res_ty | otherwise = do { traceTc "Non Application rule" (ppr op) ; (op', op_ty) <- tcInferFun op - ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty + ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTysWrap op 2 op_ty ; co_res <- unifyType op_res_ty res_ty ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys ; return $ mkHsWrapCo co_res $ @@ -305,7 +305,7 @@ tcExpr (OpApp arg1 op fix arg2) res_ty tcExpr (SectionR op arg2) res_ty = do { (op', op_ty) <- tcInferFun op - ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty + ; (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 ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; return $ mkHsWrapCo co_res $ @@ -317,7 +317,7 @@ tcExpr (SectionL arg1 op) res_ty ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1 | otherwise = 2 - ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty + ; (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 ; arg1' <- tcArg op (arg1, arg1_ty, 1) ; return $ mkHsWrapCo co_res $ @@ -325,7 +325,7 @@ tcExpr (SectionL arg1 op) res_ty tcExpr (ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args - = do { let tup_tc = tupleTyCon boxity (length tup_args) + = do { let tup_tc = tupleTyCon (boxityNormalTupleSort boxity) (length tup_args) ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } @@ -335,7 +335,7 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty do { let kind = case boxity of { Boxed -> liftedTypeKind ; Unboxed -> argTypeKind } arity = length tup_args - tup_tc = tupleTyCon boxity arity + tup_tc = tupleTyCon (boxityNormalTupleSort boxity) arity ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind ; let actual_res_ty @@ -661,7 +661,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- Step 7: make a cast for the scrutinee, in the case that it's from a type family ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon - = WpCast $ mkAxInstCo co_con scrut_inst_tys + = WpCast (mkAxInstCo co_con scrut_inst_tys) | otherwise = idHsWrapper -- Phew! @@ -679,7 +679,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty flds = dataConFieldLabels con fixed_tvs = exactTyVarsOfTypes fixed_tys -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyVarsOfTheta theta + `unionVarSet` tyVarsOfTypes theta -- Universally-quantified tyvars that -- appear in any of the *implicit* -- arguments to the constructor are fixed @@ -900,10 +900,10 @@ tcTupArgs args tys ; return (Present expr') } ---------------- -unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType - -> TcM (Coercion, [TcSigmaType], TcRhoType) +unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType + -> TcM (LCoercion, [TcSigmaType], TcRhoType) -- A wrapper for matchExpectedFunTys -unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty +unifyOpFunTysWrap op arity ty = matchExpectedFunTys herald arity ty where herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes") @@ -1128,7 +1128,7 @@ tcTagToEnum loc fun_name arg res_ty doc3 = ptext (sLit "No family instance for this type") get_rep_ty :: TcType -> TyCon -> [TcType] - -> TcM (Coercion, TyCon, [TcType]) + -> TcM (LCoercion, TyCon, [TcType]) -- Converts a family type (eg F [a]) to its rep type (eg FList a) -- and returns a coercion between the two get_rep_ty ty tc tc_args diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index b7a3a50649..12df4b5f92 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1460,7 +1460,7 @@ data FFoldType a -- Describes how to fold over a Type in a functor like way , ft_var :: a -- The variable itself , ft_co_var :: a -- The variable itself, contravariantly , ft_fun :: a -> a -> a -- Function type - , ft_tup :: Boxity -> [a] -> a -- Tuple type + , ft_tup :: TupleSort -> [a] -> a -- Tuple type , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument , ft_bad_app :: a -- Type app, variable other than in last argument , ft_forall :: TcTyVar -> a -> a -- Forall type @@ -1479,8 +1479,8 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar where -- go returns (result of type a, does type contain var) 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 (PredTy _) b) = go co b - go co (FunTy x y) | xc || yc = (caseFun xr yr,True) + go co (FunTy 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) @@ -1491,7 +1491,7 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar | not (or xcs) = (caseTrivial, False) -- Variable does not occur -- At this point we know that xrs, xcs is not empty, -- and at least one xr is True - | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True) + | isTupleTyCon con = (caseTuple (tupleTyConSort con) xrs, True) | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty | otherwise = -- T (..no var..) ty (caseTyApp (fst (splitAppTy ty)) (last xrs), True) @@ -1551,9 +1551,9 @@ mkSimpleConMatch fold extra_pats con insides = do -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)) - -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName) -mkSimpleTupleCase match_for_con boxity insides x = do - let con = tupleCon boxity (length insides) + -> TupleSort -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName) +mkSimpleTupleCase match_for_con sort insides x = do + let con = tupleCon sort (length insides) match <- match_for_con [] con insides return $ nlHsCase x [match] \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 65bd79c204..e35dafb1b2 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -681,8 +681,8 @@ zonkCoFn env WpHole = return (env, WpHole) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co - ; return (env, WpCast co') } +zonkCoFn env (WpCast co) = do { co' <- zonkTcLCoToLCo env co + ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev ; return (env', WpEvLam ev') } zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg @@ -1048,11 +1048,13 @@ zonkVect _ (HsVectTypeIn _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn" 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 - ; return (EvCoercion co') } +zonkEvTerm env (EvCoercionBox co) = do { co' <- zonkTcLCoToLCo env co + ; return (EvCoercionBox co') } zonkEvTerm env (EvCast v co) = ASSERT( isId v) - do { co' <- zonkTcCoToCo env co + do { co' <- zonkTcLCoToLCo env co ; return (EvCast (zonkIdOcc env v) co') } +zonkEvTerm env (EvTupleSel v n) = return (EvTupleSel (zonkIdOcc env v) n) +zonkEvTerm env (EvTupleMk vs) = return (EvTupleMk (map (zonkIdOcc env) vs)) zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys @@ -1127,8 +1129,8 @@ zonkTypeZapping ty ; writeMetaTyVar tv ty ; return ty } -zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -zonkTcCoToCo env co +zonkTcLCoToLCo :: ZonkEnv -> LCoercion -> TcM LCoercion +zonkTcLCoToLCo env co = go co where go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv)) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 4e589c0563..86b3a983bd 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -16,8 +16,10 @@ module TcHsType ( -- Typechecking kinded types tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, dsHsType, kcHsLPred, dsHsLPred, - tcDataKindSig, ExpKind(..), EkCtxt(..), + tcTyVarBndrs, dsHsType, + tcDataKindSig, + + ExpKind(..), EkCtxt(..), ekConstraint, -- Pattern type signatures tcHsPatSigType, tcPatSig @@ -38,6 +40,7 @@ import TcUnify import TcIface import TcType import {- Kind parts of -} Type +import Kind ( isConstraintKind ) import Var import VarSet import TyCon @@ -47,6 +50,7 @@ import NameSet import TysWiredIn import BasicTypes import SrcLoc +import DynFlags ( ExtensionFlag(Opt_ConstraintKind) ) import Util import UniqSupply import Outputable @@ -160,30 +164,25 @@ tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) tcHsInstHead (L loc hs_ty) = setSrcSpan loc $ -- No need for an "In the type..." context -- because that comes from the caller - do { kinded_ty <- kc_inst_head hs_ty - ; ds_inst_head kinded_ty } + kc_ds_inst_head hs_ty where - kc_inst_head ty@(HsPredTy pred@(HsClassP {})) - = do { (pred', kind) <- kc_pred pred - ; checkExpectedKind ty kind ekLifted - ; return (HsPredTy pred') } - kc_inst_head (HsForAllTy exp tv_names context (L loc ty)) - = kcHsTyVars tv_names $ \ tv_names' -> - do { ctxt' <- kcHsContext context - ; ty' <- kc_inst_head ty - ; return (HsForAllTy exp tv_names' ctxt' (L loc ty')) } - kc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type")) - - ds_inst_head (HsPredTy (HsClassP cls_name tys)) - = do { clas <- tcLookupClass cls_name - ; arg_tys <- dsHsTypes tys - ; return ([], [], clas, arg_tys) } - ds_inst_head (HsForAllTy _ tvs ctxt (L _ tau)) - = tcTyVarBndrs tvs $ \ tvs' -> - do { ctxt' <- mapM dsHsLPred (unLoc ctxt) - ; (tvs_r, ctxt_r, cls, tys) <- ds_inst_head tau - ; return (tvs' ++ tvs_r, ctxt' ++ ctxt_r , cls, tys) } - ds_inst_head _ = panic "ds_inst_head" + kc_ds_inst_head ty = case splitHsClassTy_maybe cls_ty of + Just _ -> do -- Kind-checking first + (tvs, ctxt, cls_ty) <- kcHsTyVars tv_names $ \ tv_names' -> do + ctxt' <- mapM kcHsLPredType ctxt + cls_ty' <- kc_check_hs_type cls_ty ekConstraint + -- The body of a forall is usually lifted, but in an instance + -- head we only allow something of kind Constraint. + return (tv_names', ctxt', cls_ty') + -- Now desugar the kind-checked type + let Just (cls_name, tys) = splitHsClassTy_maybe cls_ty + tcTyVarBndrs tvs $ \ tvs' -> do + ctxt' <- dsHsTypes ctxt + clas <- tcLookupClass cls_name + tys' <- dsHsTypes tys + return (tvs', ctxt', clas, tys') + _ -> failWithTc (ptext (sLit "Malformed instance type")) + where (tv_names, ctxt, cls_ty) = splitHsForAllTy ty tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), @@ -201,23 +200,24 @@ tcHsDeriv = tc_hs_deriv [] tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name -> TcM ([TyVar], Class, [Type]) -tc_hs_deriv tv_names (HsPredTy (HsClassP cls_name hs_tys)) - = kcHsTyVars tv_names $ \ tv_names' -> - do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys - ; tcTyVarBndrs tv_names' $ \ tyvars -> - do { arg_tys <- dsHsTypes tys - ; cls <- tcLookupClass cls_name - ; return (tyvars, cls, arg_tys) }} - tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty)) = -- Funny newtype deriving form -- forall a. C [a] -- where C has arity 2. Hence can't use regular functions tc_hs_deriv (tv_names1 ++ tv_names2) ty -tc_hs_deriv _ other - = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr other) +tc_hs_deriv tv_names ty + | Just (cls_name, hs_tys) <- splitHsClassTy_maybe ty + = kcHsTyVars tv_names $ \ tv_names' -> + do { cls_kind <- kcClass cls_name + ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys + ; tcTyVarBndrs tv_names' $ \ tyvars -> + do { arg_tys <- dsHsTypes tys + ; cls <- tcLookupClass cls_name + ; return (tyvars, cls, arg_tys) }} + + | otherwise + = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr ty) \end{code} These functions are used during knot-tying in @@ -245,7 +245,7 @@ tcHsBangType ty = tcHsKindedType ty tcHsKindedContext :: LHsContext Name -> TcM ThetaType -- Used when we are expecting a ClassContext (i.e. no implicit params) -- Does not do validity checking, like tcHsKindedType -tcHsKindedContext hs_theta = addLocM (mapM dsHsLPred) hs_theta +tcHsKindedContext hs_theta = addLocM (mapM dsHsType) hs_theta \end{code} @@ -352,7 +352,11 @@ kc_hs_type (HsParTy ty) = do (ty', kind) <- kc_lhs_type ty return (HsParTy ty', kind) -kc_hs_type (HsTyVar name) = do +kc_hs_type (HsTyVar name) + -- Special case for the unit tycon so it benefits from kind overloading + | name == tyConName unitTyCon + = kc_hs_type (HsTupleTy (HsBoxyTuple placeHolderKind) []) + | otherwise = do kind <- kcTyVar name return (HsTyVar name, kind) @@ -368,13 +372,23 @@ kc_hs_type (HsKindSig ty k) = do ty' <- kc_check_lhs_type ty (EK k EkKindSig) return (HsKindSig ty' k, k) -kc_hs_type (HsTupleTy Boxed tys) = do - tys' <- mapM kcLiftedType tys - return (HsTupleTy Boxed tys', liftedTypeKind) - -kc_hs_type (HsTupleTy Unboxed tys) = do +kc_hs_type (HsTupleTy (HsBoxyTuple _) tys) = do + fact_tup_ok <- xoptM Opt_ConstraintKind + if not fact_tup_ok + then do tys' <- mapM kcLiftedType tys + return (HsTupleTy (HsBoxyTuple liftedTypeKind) tys', liftedTypeKind) + else do -- In some contexts users really "mean" to write + -- tuples with Constraint components, rather than * components. + -- + -- This special case of kind-checking does this rewriting when we can detect + -- that we need it. + k <- newKindVar + tys' <- mapM (\ty -> kc_check_lhs_type ty (EK k EkUnk)) tys + return (HsTupleTy (HsBoxyTuple k) tys', k) + +kc_hs_type (HsTupleTy HsUnboxedTuple tys) = do tys' <- mapM kcTypeType tys - return (HsTupleTy Unboxed tys', ubxTupleKind) + return (HsTupleTy HsUnboxedTuple tys', ubxTupleKind) kc_hs_type (HsFunTy ty1 ty2) = do ty1' <- kc_check_lhs_type ty1 (EK argTypeKind EkUnk) @@ -392,8 +406,15 @@ kc_hs_type (HsAppTy ty1 ty2) = do (arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys return (mkHsAppTys fun_ty' arg_tys', res_kind) -kc_hs_type (HsPredTy pred) - = wrongPredErr pred +kc_hs_type (HsIParamTy n ty) = do + ty' <- kc_check_lhs_type ty (EK liftedTypeKind EkIParam) + return (HsIParamTy n ty', constraintKind) + +kc_hs_type (HsEqTy ty1 ty2) = do + (ty1', kind1) <- kc_lhs_type ty1 + (ty2', kind2) <- kc_lhs_type ty2 + checkExpectedKind ty2 kind2 (EK kind1 EkEqPred) + return (HsEqTy ty1' ty2', constraintKind) kc_hs_type (HsCoreTy ty) = return (HsCoreTy ty, typeKind ty) @@ -473,33 +494,10 @@ splitFunKind the_fun arg_no fk (arg:args) --------------------------- kcHsContext :: LHsContext Name -> TcM (LHsContext Name) -kcHsContext ctxt = wrapLocM (mapM kcHsLPred) ctxt +kcHsContext ctxt = wrapLocM (mapM kcHsLPredType) ctxt -kcHsLPred :: LHsPred Name -> TcM (LHsPred Name) -kcHsLPred = wrapLocM kcHsPred - -kcHsPred :: HsPred Name -> TcM (HsPred Name) -kcHsPred pred = do -- Checks that the result is a type kind - (pred', kind) <- kc_pred pred - checkExpectedKind pred kind ekOpen - return pred' - ---------------------------- -kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) - -- Does *not* check for a saturated - -- application (reason: used from TcDeriv) -kc_pred (HsIParam name ty) - = do { (ty', kind) <- kc_lhs_type ty - ; return (HsIParam name ty', kind) } -kc_pred (HsClassP cls tys) - = do { kind <- kcClass cls - ; (tys', res_kind) <- kcApps cls kind tys - ; return (HsClassP cls tys', res_kind) } -kc_pred (HsEqualP ty1 ty2) - = do { (ty1', kind1) <- kc_lhs_type ty1 - ; (ty2', kind2) <- kc_lhs_type ty2 - ; checkExpectedKind ty2 kind2 (EK kind1 EkEqPred) - ; return (HsEqualP ty1' ty2', unliftedTypeKind) } +kcHsLPredType :: LHsType Name -> TcM (LHsType Name) +kcHsLPredType pred = kc_check_lhs_type pred ekConstraint --------------------------- kcTyVar :: Name -> TcM TcKind @@ -517,9 +515,10 @@ kcClass :: Name -> TcM TcKind kcClass cls = do -- Must be a class thing <- tcLookup cls case thing of - AThing kind -> return kind - AGlobal (AClass cls) -> return (tyConKind (classTyCon cls)) - _ -> wrongThingErr "class" thing cls + AThing kind -> return kind + AGlobal (ATyCon tc) + | Just cls <- tyConClass_maybe tc -> return (tyConKind (classTyCon cls)) + _ -> wrongThingErr "class" thing cls \end{code} @@ -570,12 +569,20 @@ ds_type (HsPArrTy ty) = do checkWiredInTyCon parrTyCon return (mkPArrTy tau_ty) -ds_type (HsTupleTy boxity tys) = do +ds_type (HsTupleTy hs_con tys) = do + con <- case hs_con of + HsUnboxedTuple -> return UnboxedTuple + HsBoxyTuple kind -> do + kind' <- zonkTcKindToKind kind + case () of + _ | kind' `eqKind` constraintKind -> return FactTuple + _ | kind' `eqKind` liftedTypeKind -> return BoxedTuple + _ | otherwise + -> failWithTc (ptext (sLit "Unexpected tuple component kind:") <+> ppr kind') + let tycon = tupleTyCon con (length tys) tau_tys <- dsHsTypes tys checkWiredInTyCon tycon return (mkTyConApp tycon tau_tys) - where - tycon = tupleTyCon boxity (length tys) ds_type (HsFunTy ty1 ty2) = do tau_ty1 <- dsHsType ty1 @@ -590,13 +597,18 @@ ds_type (HsOpTy ty1 (L span op) ty2) = do ds_type ty@(HsAppTy _ _) = ds_app ty [] -ds_type (HsPredTy pred) = do - pred' <- dsHsPred pred - return (mkPredTy pred') +ds_type (HsIParamTy n ty) = do + tau_ty <- dsHsType ty + return (mkIPPred n tau_ty) + +ds_type (HsEqTy ty1 ty2) = do + tau_ty1 <- dsHsType ty1 + tau_ty2 <- dsHsType ty2 + return (mkEqPred (tau_ty1, tau_ty2)) ds_type (HsForAllTy _ tv_names ctxt ty) = tcTyVarBndrs tv_names $ \ tyvars -> do - theta <- mapM dsHsLPred (unLoc ctxt) + theta <- mapM dsHsType (unLoc ctxt) tau <- dsHsType ty return (mkSigmaTy tyvars theta tau) @@ -638,36 +650,10 @@ ds_var_app name arg_tys = do _ -> wrongThingErr "type" thing name \end{code} - -Contexts -~~~~~~~~ - -\begin{code} -dsHsLPred :: LHsPred Name -> TcM PredType -dsHsLPred pred = dsHsPred (unLoc pred) - -dsHsPred :: HsPred Name -> TcM PredType -dsHsPred (HsClassP class_name tys) - = do { arg_tys <- dsHsTypes tys - ; clas <- tcLookupClass class_name - ; return (ClassP clas arg_tys) - } -dsHsPred (HsEqualP ty1 ty2) - = do { arg_ty1 <- dsHsType ty1 - ; arg_ty2 <- dsHsType ty2 - ; return (EqPred arg_ty1 arg_ty2) - } -dsHsPred (HsIParam name ty) - = do { arg_ty <- dsHsType ty - ; return (IParam name arg_ty) - } -\end{code} - \begin{code} addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -addKcTypeCtxt (L _ (HsPredTy _)) thing = thing - -- Omit invisble ones and ones user's won't grok (HsPred p). + -- Omit invisble ones and ones user's won't grok addKcTypeCtxt (L _ other_ty) thing = addErrCtxt (typeCtxt other_ty) thing typeCtxt :: HsType Name -> SDoc @@ -917,11 +903,13 @@ data EkCtxt = EkUnk -- Unknown context | EkEqPred -- Second argument of an equality predicate | EkKindSig -- Kind signature | EkArg SDoc Int -- Function, arg posn, expected kind + | EkIParam -- Implicit parameter type -ekLifted, ekOpen :: ExpKind -ekLifted = EK liftedTypeKind EkUnk -ekOpen = EK openTypeKind EkUnk +ekLifted, ekOpen, ekConstraint :: ExpKind +ekLifted = EK liftedTypeKind EkUnk +ekOpen = EK openTypeKind EkUnk +ekConstraint = EK constraintKind EkUnk checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () -- A fancy wrapper for 'unifyKind', which tries @@ -930,10 +918,7 @@ checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () -- 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) - | act_kind `isSubKind` exp_kind -- Short cut for a very common case - = return () - | otherwise = do +checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind) case mb_r of Just _ -> return () -- Unification succeeded @@ -958,6 +943,12 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) -- Now n_exp_as >= n_act_as. In the next two cases, -- n_exp_as == 0, and hence so is n_act_as + | isConstraintKind tidy_act_kind + = text "Predicate" <+> quotes (ppr ty) <+> text "used as a type" + + | isConstraintKind tidy_exp_kind + = text "Type of kind " <+> ppr tidy_act_kind <+> text "used as a constraint" + | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) <+> ptext (sLit "is unlifted") @@ -977,6 +968,7 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) expected_herald EkUnk = ptext (sLit "Expected") expected_herald EkKindSig = ptext (sLit "An enclosing kind signature specified") expected_herald EkEqPred = ptext (sLit "The left argument of the equality predicate had") + expected_herald EkIParam = ptext (sLit "The type argument of the implicit parameter had") expected_herald (EkArg fun arg_no) = ptext (sLit "The") <+> speakNth arg_no <+> ptext (sLit "argument of") <+> quotes fun <+> ptext (sLit ("should have")) @@ -1016,8 +1008,5 @@ dupInScope n n' _ = hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n')) 2 (vcat [ptext (sLit "are bound to the same type (variable)"), ptext (sLit "Distinct scoped type variables must be distinct")]) - -wrongPredErr :: HsPred Name -> TcM (HsType Name, TcKind) -wrongPredErr pred = failWithTc (text "Predicate used as a type:" <+> ppr pred) \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 5049cba8fb..7f932acab6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -792,7 +792,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) op_items ibinds -- Create the result bindings - ; self_dict <- newEvVar (ClassP clas inst_tys) + ; self_dict <- newDict clas inst_tys ; let class_tc = classTyCon clas [dict_constr] = tyConDataCons class_tc dict_bind = mkVarBind self_dict (L loc con_app_args) @@ -818,7 +818,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) mk_sc_ev_term :: EvVar -> EvTerm mk_sc_ev_term sc | null inst_tv_tys - , null dfun_ev_vars = evVarTerm sc + , null dfun_ev_vars = EvId sc | otherwise = EvDFunApp sc inst_tv_tys dfun_ev_vars inst_tv_tys = mkTyVarTys inst_tyvars @@ -1058,9 +1058,9 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- The 'let' is necessary only because HsSyn doesn't allow -- you to apply a function to a dictionary *expression*. - ; self_dict <- newEvVar (ClassP clas inst_tys) - ; let self_ev_bind = EvBind self_dict $ - EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars + ; self_dict <- newDict clas inst_tys + ; let self_ev_bind = EvBind self_dict + (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars) ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id @@ -1186,7 +1186,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys mk_op_wrapper :: Id -> EvVar -> HsWrapper mk_op_wrapper sel_id rep_d = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co]) - local_meth_ty) + local_meth_ty) <.> WpEvApp (EvId rep_d) <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) where @@ -1347,9 +1347,8 @@ Note carefullly: instDeclCtxt1 :: LHsType Name -> SDoc instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (case unLoc hs_inst_ty of - HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred - HsPredTy pred -> ppr pred - _ -> ppr hs_inst_ty) -- Don't expect this + HsForAllTy _ _ _ (L _ ty') -> ppr ty' + _ -> ppr hs_inst_ty) -- Don't expect this instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 1d1aab175d..29a51ee809 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -52,7 +52,7 @@ An InertSet is a bag of canonical constraints, with the following invariants: A tricky case is when there exists a given (solved) dictionary constraint and a wanted identical constraint in the inert set, but do not react because reaction would create loopy dictionary evidence for - the wanted. See note [Recursive dictionaries] + the wanted. See note [Recursive instances and superclases] 2 Given equalities form an idempotent substitution [none of the given LHS's occur in any of the given RHS's or reactant parts] @@ -140,7 +140,8 @@ extractUnsolvedCMap cmap = data InertSet = IS { inert_eqs :: CanonicalCts -- Equalities only (CTyEqCan) , inert_dicts :: CCanMap Class -- Dictionaries only - , inert_ips :: CCanMap (IPName Name) -- Implicit parameters + , inert_ips :: CCanMap (IPName Name) -- Implicit parameters + , inert_irreds :: CanonicalCts -- Irreducible predicates , inert_frozen :: CanonicalCts , inert_funeqs :: CCanMap TyCon -- Type family equalities only -- This representation allows us to quickly get to the relevant @@ -151,14 +152,16 @@ tyVarsOfInert :: InertSet -> TcTyVarSet tyVarsOfInert (IS { inert_eqs = eqs , inert_dicts = dictmap , inert_ips = ipmap + , inert_irreds = irreds , inert_frozen = frozen , inert_funeqs = funeqmap }) = tyVarsOfCanonicals cts where - cts = eqs `andCCan` frozen `andCCan` cCanMapToBag dictmap + cts = eqs `andCCan` frozen `andCCan` irreds `andCCan` cCanMapToBag dictmap `andCCan` cCanMapToBag ipmap `andCCan` cCanMapToBag funeqmap instance Outputable InertSet where ppr is = vcat [ vcat (map ppr (Bag.bagToList $ inert_eqs is)) + , vcat (map ppr (Bag.bagToList $ inert_irreds is)) , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is))) , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is))) , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_funeqs is))) @@ -169,6 +172,7 @@ instance Outputable InertSet where emptyInert :: InertSet emptyInert = IS { inert_eqs = Bag.emptyBag , inert_frozen = Bag.emptyBag + , inert_irreds = Bag.emptyBag , inert_dicts = emptyCCanMap , inert_ips = emptyCCanMap , inert_funeqs = emptyCCanMap } @@ -176,12 +180,14 @@ emptyInert = IS { inert_eqs = Bag.emptyBag updInertSet :: InertSet -> AtomicInert -> InertSet updInertSet is item | isCTyEqCan item -- Other equality - = let eqs' = inert_eqs is `Bag.snocBag` item + = let eqs' = inert_eqs is `Bag.snocBag` item in is { inert_eqs = eqs' } | Just cls <- isCDictCan_Maybe item -- Dictionary = is { inert_dicts = updCCanMap (cls,item) (inert_dicts is) } | Just x <- isCIPCan_Maybe item -- IP = is { inert_ips = updCCanMap (x,item) (inert_ips is) } + | isCIrredEvCan item -- Presently-irreducible evidence + = is { inert_irreds = inert_irreds is `Bag.snocBag` item } | Just tc <- isCFunEqCan_Maybe item -- Function equality = is { inert_funeqs = updCCanMap (tc,item) (inert_funeqs is) } | otherwise @@ -189,20 +195,22 @@ updInertSet is item extractUnsolved :: InertSet -> (InertSet, CanonicalCts) -- Postcondition: the returned canonical cts are either Derived, or Wanted. -extractUnsolved is@(IS {inert_eqs = eqs}) +extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds}) = let is_solved = is { inert_eqs = solved_eqs , inert_dicts = solved_dicts , inert_ips = solved_ips + , inert_irreds = solved_irreds , inert_frozen = emptyCCan , inert_funeqs = solved_funeqs } in (is_solved, unsolved) where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenOrSolvedCt) eqs + (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenOrSolvedCt) irreds (unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is) (unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is) (unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is) - unsolved = unsolved_eqs `unionBags` inert_frozen is `unionBags` + unsolved = unsolved_eqs `unionBags` inert_frozen is `unionBags` unsolved_irreds `unionBags` unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs \end{code} @@ -224,7 +232,7 @@ Note [Basic plan] 3. Try to solve spontaneously for equalities involving touchables 4. Top-level interaction (binary wrt top-level) - Superclass decomposition belongs in (4), see note [Superclasses] + Superclass decomposition belongs in (1), see note [Adding superclasses] \begin{code} type AtomicInert = CanonicalCt -- constraint pulled from InertSet @@ -372,7 +380,7 @@ tryPreSolveAndInteract :: SimplContext -> TcS (Bool, InertSet) -- Returns: True if it was able to discharge this constraint AND all previous ones tryPreSolveAndInteract sctx dyn_flags ct (all_previous_discharged, inert) - = do { let inert_cts = get_inert_cts (evVarPred ev_var) + = do { let inert_cts = get_inert_cts (predTypePredTree (evVarPred ev_var)) ; this_one_discharged <- if isCFrozenErr ct then @@ -391,15 +399,19 @@ tryPreSolveAndInteract sctx dyn_flags ct (all_previous_discharged, inert) ev_var = cc_id ct fl = cc_flavor ct - get_inert_cts (ClassP clas _) + get_inert_cts (ClassPred clas _) | simplEqsOnly sctx = emptyCCan | otherwise = fst (getRelevantCts clas (inert_dicts inert)) - get_inert_cts (IParam {}) + get_inert_cts (IPPred {}) = emptyCCan -- We must not do the same thing for IParams, because (contrary -- to dictionaries), work items /must/ override inert items. -- See Note [Overriding implicit parameters] in TcInteract. get_inert_cts (EqPred {}) = inert_eqs inert `unionBags` cCanMapToBag (inert_funeqs inert) + get_inert_cts (TuplePred ts) + = andCCans $ map get_inert_cts ts + get_inert_cts (IrredPred {}) + = inert_irreds inert dischargeFromCCans :: CanonicalCts -> EvVar -> CtFlavor -> TcS Bool -- See if this (pre-canonicalised) work-item is identical to a @@ -415,7 +427,7 @@ dischargeFromCCans cans ev fl discharge_ct ct _rest | evVarPred (cc_id ct) `eqPred` the_pred , cc_flavor ct `canSolve` fl - = do { when (isWanted fl) $ setEvBind ev (evVarTerm (cc_id ct)) + = do { when (isWanted fl) $ setEvBind ev (EvId (cc_id ct)) -- Deriveds need no evidence -- For Givens, we already have evidence, and we don't need it twice ; return True } @@ -572,20 +584,20 @@ data SPSolveResult = SPCantSolve | SPSolved WorkItem | SPError -- touchable unification variable. -- See Note [Touchables and givens] trySpontaneousSolve :: WorkItem -> TcS SPSolveResult -trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi }) +trySpontaneousSolve workItem@(CTyEqCan { cc_id = eqv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi }) | isGivenOrSolved gw = return SPCantSolve | Just tv2 <- tcGetTyVar_maybe xi = do { tch1 <- isTouchableMetaTyVar tv1 ; tch2 <- isTouchableMetaTyVar tv2 ; case (tch1, tch2) of - (True, True) -> trySpontaneousEqTwoWay cv gw tv1 tv2 - (True, False) -> trySpontaneousEqOneWay cv gw tv1 xi - (False, True) -> trySpontaneousEqOneWay cv gw tv2 (mkTyVarTy tv1) + (True, True) -> trySpontaneousEqTwoWay eqv gw tv1 tv2 + (True, False) -> trySpontaneousEqOneWay eqv gw tv1 xi + (False, True) -> trySpontaneousEqOneWay eqv gw tv2 (mkTyVarTy tv1) _ -> return SPCantSolve } | otherwise = do { tch1 <- isTouchableMetaTyVar tv1 - ; if tch1 then trySpontaneousEqOneWay cv gw tv1 xi + ; if tch1 then trySpontaneousEqOneWay eqv gw tv1 xi else do { traceTcS "Untouchable LHS, can't spontaneously solve workitem:" (ppr workItem) ; return SPCantSolve } @@ -597,14 +609,14 @@ trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = trySpontaneousSolve _ = return SPCantSolve ---------------- -trySpontaneousEqOneWay :: CoVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult +trySpontaneousEqOneWay :: EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult -- tv is a MetaTyVar, not untouchable -trySpontaneousEqOneWay cv gw tv xi +trySpontaneousEqOneWay eqv gw tv xi | not (isSigTyVar tv) || isTyVarTy xi = do { let kxi = typeKind xi -- NB: 'xi' is fully rewritten according to the inerts -- so we have its more specific kind in our hands ; if kxi `isSubKind` tyVarKind tv then - solveWithIdentity cv gw tv xi + solveWithIdentity eqv gw tv xi else return SPCantSolve {- else if tyVarKind tv `isSubKind` kxi then @@ -620,13 +632,13 @@ trySpontaneousEqOneWay cv gw tv xi = return SPCantSolve ---------------- -trySpontaneousEqTwoWay :: CoVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult +trySpontaneousEqTwoWay :: EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here -trySpontaneousEqTwoWay cv gw tv1 tv2 +trySpontaneousEqTwoWay eqv gw tv1 tv2 | k1 `isSubKind` k2 - , nicer_to_update_tv2 = solveWithIdentity cv gw tv2 (mkTyVarTy tv1) + , nicer_to_update_tv2 = solveWithIdentity eqv gw tv2 (mkTyVarTy tv1) | k2 `isSubKind` k1 - = solveWithIdentity cv gw tv1 (mkTyVarTy tv2) + = solveWithIdentity eqv gw tv1 (mkTyVarTy tv2) | otherwise -- None is a subkind of the other, but they are both touchable! = return SPCantSolve -- do { addErrorTcS KindError gw (mkTyVarTy tv1) (mkTyVarTy tv2) @@ -709,7 +721,7 @@ unification variables as RHS of type family equations: F xis ~ alpha. \begin{code} ---------------- -solveWithIdentity :: CoVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult +solveWithIdentity :: EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult -- Solve with the identity coercion -- Precondition: kind(xi) is a sub-kind of kind(tv) -- Precondition: CtFlavor is Wanted or Derived @@ -717,7 +729,7 @@ solveWithIdentity :: CoVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult -- must work for Derived as well as Wanted -- Returns: workItem where -- workItem = the new Given constraint -solveWithIdentity cv wd tv xi +solveWithIdentity eqv wd tv xi = do { traceTcS "Sneaky unification:" $ vcat [text "Coercion variable: " <+> ppr wd, text "Coercion: " <+> pprEq (mkTyVarTy tv) xi, @@ -727,11 +739,11 @@ solveWithIdentity cv wd tv xi ; setWantedTyBind tv xi ; let refl_xi = mkReflCo xi - ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi refl_xi + ; eqv_given <- newGivenEqVar (mkTyVarTy tv) xi refl_xi - ; when (isWanted wd) (setCoBind cv refl_xi) + ; when (isWanted wd) (setEqBind eqv refl_xi) -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)' - ; return $ SPSolved (CTyEqCan { cc_id = cv_given + ; return $ SPSolved (CTyEqCan { cc_id = eqv_given , cc_flavor = mkSolvedFlavor wd UnkSkol , cc_tyvar = tv, cc_rhs = xi }) } \end{code} @@ -859,16 +871,21 @@ interactWithInertsStage depth workItem inert getISRelevant (CIPCan { cc_ip_nm = nm }) is = let (relevant, residual_map) = getRelevantCts nm (inert_ips is) in (relevant, is { inert_ips = residual_map }) + getISRelevant (CIrredEvCan {}) is -- Irreducible, nothing is relevant! Only interacts with equalities. + = (emptyCCan, is) -- An equality, finally, may kick everything except equalities out -- because we have already interacted the equalities in interactWithInertEqsStage getISRelevant _eq_ct is -- Equality, everything is relevant for this one -- TODO: if we were caching variables, we'd know that only -- some are relevant. Experiment with this for now. - = let cts = cCanMapToBag (inert_ips is) `unionBags` - cCanMapToBag (inert_dicts is) `unionBags` cCanMapToBag (inert_funeqs is) + = let cts = cCanMapToBag (inert_ips is) `unionBags` + cCanMapToBag (inert_dicts is) `unionBags` + cCanMapToBag (inert_funeqs is) `unionBags` + inert_irreds is in (cts, is { inert_dicts = emptyCCanMap , inert_ips = emptyCCanMap - , inert_funeqs = emptyCCanMap }) + , inert_funeqs = emptyCCanMap + , inert_irreds = emptyBag }) interactNext :: SubGoalDepth -> AtomicInert -> StageResult -> TcS StageResult interactNext depth inert it @@ -918,8 +935,9 @@ interactWithInert inert workItem allowedInteraction :: Bool -> AtomicInert -> WorkItem -> Bool -- Allowed interactions -allowedInteraction eqs_only (CDictCan {}) (CDictCan {}) = not eqs_only -allowedInteraction eqs_only (CIPCan {}) (CIPCan {}) = not eqs_only +allowedInteraction eqs_only (CDictCan {}) (CDictCan {}) = not eqs_only +allowedInteraction eqs_only (CIPCan {}) (CIPCan {}) = not eqs_only +allowedInteraction eqs_only (CIrredEvCan {}) (CIrredEvCan {}) = not eqs_only allowedInteraction _ _ _ = True -------------------------------------------- @@ -931,8 +949,8 @@ doInteractWithInert workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) | cls1 == cls2 - = do { let pty1 = ClassP cls1 tys1 - pty2 = ClassP cls2 tys2 + = do { let pty1 = mkClassPred cls1 tys1 + pty2 = mkClassPred cls2 tys2 inert_pred_loc = (pty1, pprFlavorArising fl1) work_item_pred_loc = (pty2, pprFlavorArising fl2) @@ -977,7 +995,7 @@ doInteractWithInert ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans } Wanted {} | isDerived fl1 - -> do { setDictBind d2 (EvCast d1 dict_co) + -> do { setEvBind d2 (EvCast d1 dict_co) ; let inert_w = inertItem { cc_flavor = fl2 } -- A bit naughty: we take the inert Derived, -- turn it into a Wanted, use it to solve the work-item @@ -991,7 +1009,7 @@ doInteractWithInert ; mkIRStopD "Cls/Cls fundep (solved)" $ workListFromNonEq inert_w `unionWorkList` fd_cans } | otherwise - -> do { setDictBind d2 (EvCast d1 dict_co) + -> do { setEvBind d2 (EvCast d1 dict_co) -- Rewriting is happening, so we have to create wanted fds ; fd_cans <- mkCanonicalFDAsWanted fd_work ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans } @@ -1003,36 +1021,50 @@ doInteractWithInert -- Class constraint and given equality: use the equality to rewrite -- the class constraint. -doInteractWithInert (CTyEqCan { cc_id = cv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) +doInteractWithInert (CTyEqCan { cc_id = eqv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) (CDictCan { cc_id = dv, cc_flavor = wfl, cc_class = cl, cc_tyargs = xis }) | ifl `canRewrite` wfl , tv `elemVarSet` tyVarsOfTypes xis - = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,wfl,cl,xis) + = do { rewritten_dict <- rewriteDict (eqv,tv,xi) (dv,wfl,cl,xis) -- Continue with rewritten Dictionary because we can only be in the -- interactWithEqsStage, so the dictionary is inert. ; mkIRContinue "Eq/Cls" rewritten_dict KeepInert emptyWorkList } doInteractWithInert (CDictCan { cc_id = dv, cc_flavor = ifl, cc_class = cl, cc_tyargs = xis }) - workItem@(CTyEqCan { cc_id = cv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi }) + workItem@(CTyEqCan { cc_id = eqv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi }) | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfTypes xis - = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,ifl,cl,xis) + = do { rewritten_dict <- rewriteDict (eqv,tv,xi) (dv,ifl,cl,xis) ; mkIRContinue "Cls/Eq" workItem DropInert (workListFromNonEq rewritten_dict) } -- Class constraint and given equality: use the equality to rewrite -- the class constraint. -doInteractWithInert (CTyEqCan { cc_id = cv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) +doInteractWithInert (CTyEqCan { cc_id = eqv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) + (CIrredEvCan { cc_id = id, cc_flavor = wfl, cc_ty = ty }) + | ifl `canRewrite` wfl + , tv `elemVarSet` tyVarsOfType ty + = do { rewritten_irred <- rewriteIrred (eqv,tv,xi) (id,wfl,ty) + ; mkIRStopK "Eq/Irred" rewritten_irred } + +doInteractWithInert (CIrredEvCan { cc_id = id, cc_flavor = ifl, cc_ty = ty }) + workItem@(CTyEqCan { cc_id = eqv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi }) + | wfl `canRewrite` ifl + , tv `elemVarSet` tyVarsOfType ty + = do { rewritten_irred <- rewriteIrred (eqv,tv,xi) (id,ifl,ty) + ; mkIRContinue "Irred/Eq" workItem DropInert rewritten_irred } + +doInteractWithInert (CTyEqCan { cc_id = eqv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) (CIPCan { cc_id = ipid, cc_flavor = wfl, cc_ip_nm = nm, cc_ip_ty = ty }) | ifl `canRewrite` wfl , tv `elemVarSet` tyVarsOfType ty - = do { rewritten_ip <- rewriteIP (cv,tv,xi) (ipid,wfl,nm,ty) + = do { rewritten_ip <- rewriteIP (eqv,tv,xi) (ipid,wfl,nm,ty) ; mkIRContinue "Eq/IP" rewritten_ip KeepInert emptyWorkList } doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_ip_ty = ty }) - workItem@(CTyEqCan { cc_id = cv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi }) + workItem@(CTyEqCan { cc_id = eqv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi }) | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfType ty - = do { rewritten_ip <- rewriteIP (cv,tv,xi) (ipid,ifl,nm,ty) + = do { rewritten_ip <- rewriteIP (eqv,tv,xi) (ipid,ifl,nm,ty) ; mkIRContinue "IP/Eq" workItem DropInert (workListFromNonEq rewritten_ip) } -- Two implicit parameter constraints. If the names are the same, @@ -1055,15 +1087,15 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i | nm1 == nm2 = -- See Note [When improvement happens] - do { co_var <- newCoVar ty2 ty1 -- See Note [Efficient Orientation] + do { eqv <- newEqVar ty2 ty1 -- See Note [Efficient Orientation] ; let flav = Wanted (combineCtLoc ifl wfl) - ; cans <- mkCanonical flav co_var + ; cans <- mkCanonical flav eqv ; case wfl of Given {} -> pprPanic "Unexpected given IP" (ppr workItem) Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem) Wanted {} -> - do { setIPBind (cc_id workItem) $ - EvCast id1 (mkSymCo (mkCoVarCo co_var)) + do { setEvBind (cc_id workItem) + (EvCast id1 (mkSymCo (mkEqVarLCo eqv))) ; mkIRStopK "IP/IP interaction (solved)" cans } } @@ -1073,22 +1105,22 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i -- we know about equalities. -- Inert: equality, work item: function equality -doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi1 }) - (CFunEqCan { cc_id = cv2, cc_flavor = wfl, cc_fun = tc +doInteractWithInert (CTyEqCan { cc_id = eqv1, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi1 }) + (CFunEqCan { cc_id = eqv2, cc_flavor = wfl, cc_fun = tc , cc_tyargs = args, cc_rhs = xi2 }) | ifl `canRewrite` wfl , tv `elemVarSet` tyVarsOfTypes (xi2:args) -- Rewrite RHS as well - = do { rewritten_funeq <- rewriteFunEq (cv1,tv,xi1) (cv2,wfl,tc,args,xi2) + = do { rewritten_funeq <- rewriteFunEq (eqv1,tv,xi1) (eqv2,wfl,tc,args,xi2) ; mkIRStopK "Eq/FunEq" (workListFromEq rewritten_funeq) } -- Must Stop here, because we may no longer be inert after the rewritting. -- Inert: function equality, work item: equality -doInteractWithInert (CFunEqCan {cc_id = cv1, cc_flavor = ifl, cc_fun = tc +doInteractWithInert (CFunEqCan {cc_id = eqv1, cc_flavor = ifl, cc_fun = tc , cc_tyargs = args, cc_rhs = xi1 }) - workItem@(CTyEqCan { cc_id = cv2, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi2 }) + workItem@(CTyEqCan { cc_id = eqv2, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi2 }) | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfTypes (xi1:args) -- Rewrite RHS as well - = do { rewritten_funeq <- rewriteFunEq (cv2,tv,xi2) (cv1,ifl,tc,args,xi1) + = do { rewritten_funeq <- rewriteFunEq (eqv2,tv,xi2) (eqv1,ifl,tc,args,xi1) ; mkIRContinue "FunEq/Eq" workItem DropInert (workListFromEq rewritten_funeq) } -- One may think that we could (KeepTransformedInert rewritten_funeq) -- but that is wrong, because it may end up not being inert with respect @@ -1099,9 +1131,9 @@ doInteractWithInert (CFunEqCan {cc_id = cv1, cc_flavor = ifl, cc_fun = tc -- { F xis ~ [b], b ~ Maybe Int, a ~ [Maybe Int] } -- At the end, which is *not* inert. So we should unfortunately DropInert here. -doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1 +doInteractWithInert (CFunEqCan { cc_id = eqv1, cc_flavor = fl1, cc_fun = tc1 , cc_tyargs = args1, cc_rhs = xi1 }) - workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2 + workItem@(CFunEqCan { cc_id = eqv2, cc_flavor = fl2, cc_fun = tc2 , cc_tyargs = args2, cc_rhs = xi2 }) | tc1 == tc2 && and (zipWith eqType args1 args2) , Just GivenSolved <- isGiven_maybe fl1 @@ -1111,44 +1143,44 @@ doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1 = mkIRStopK "Funeq/Funeq" emptyWorkList | fl1 `canSolve` fl2 && lhss_match - = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) + = do { cans <- rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,fl2,xi2) ; mkIRStopK "FunEq/FunEq" cans } | fl2 `canSolve` fl1 && lhss_match - = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) + = do { cans <- rewriteEqLHS RightComesFromInert (eqv2,xi2) (eqv1,fl1,xi1) ; mkIRContinue "FunEq/FunEq" workItem DropInert cans } where lhss_match = tc1 == tc2 && eqTypes args1 args2 -doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) - workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 }) +doInteractWithInert (CTyEqCan { cc_id = eqv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) + workItem@(CTyEqCan { cc_id = eqv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 }) -- Check for matching LHS | fl1 `canSolve` fl2 && tv1 == tv2 - = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) + = do { cans <- rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,fl2,xi2) ; mkIRStopK "Eq/Eq lhs" cans } | fl2 `canSolve` fl1 && tv1 == tv2 - = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) + = do { cans <- rewriteEqLHS RightComesFromInert (eqv2,xi2) (eqv1,fl1,xi1) ; mkIRContinue "Eq/Eq lhs" workItem DropInert cans } -- Check for rewriting RHS | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfType xi2 - = do { rewritten_eq <- rewriteEqRHS (cv1,tv1,xi1) (cv2,fl2,tv2,xi2) + = do { rewritten_eq <- rewriteEqRHS (eqv1,tv1,xi1) (eqv2,fl2,tv2,xi2) ; mkIRStopK "Eq/Eq rhs" rewritten_eq } | fl2 `canRewrite` fl1 && tv2 `elemVarSet` tyVarsOfType xi1 - = do { rewritten_eq <- rewriteEqRHS (cv2,tv2,xi2) (cv1,fl1,tv1,xi1) + = do { rewritten_eq <- rewriteEqRHS (eqv2,tv2,xi2) (eqv1,fl1,tv1,xi1) ; mkIRContinue "Eq/Eq rhs" workItem DropInert rewritten_eq } -doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) - (CFrozenErr { cc_id = cv2, cc_flavor = fl2 }) - | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfEvVar cv2 - = do { rewritten_frozen <- rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) +doInteractWithInert (CTyEqCan { cc_id = eqv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) + (CFrozenErr { cc_id = eqv2, cc_flavor = fl2 }) + | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfEvVar eqv2 + = do { rewritten_frozen <- rewriteFrozen (eqv1, tv1, xi1) (eqv2, fl2) ; mkIRStopK "Frozen/Eq" rewritten_frozen } -doInteractWithInert (CFrozenErr { cc_id = cv2, cc_flavor = fl2 }) - workItem@(CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) - | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfEvVar cv2 - = do { rewritten_frozen <- rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) +doInteractWithInert (CFrozenErr { cc_id = eqv2, cc_flavor = fl2 }) + workItem@(CTyEqCan { cc_id = eqv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) + | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfEvVar eqv2 + = do { rewritten_frozen <- rewriteFrozen (eqv1, tv1, xi1) (eqv2, fl2) ; mkIRContinue "Frozen/Eq" workItem DropInert rewritten_frozen } -- Fall-through case for all other situations @@ -1156,16 +1188,17 @@ doInteractWithInert _ workItem = noInteraction workItem ------------------------- -- Equational Rewriting -rewriteDict :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt -rewriteDict (cv,tv,xi) (dv,gw,cl,xis) - = do { let cos = map (liftCoSubstWith [tv] [mkCoVarCo cv]) xis -- xis[tv] ~ xis[xi] - args = substTysWith [tv] [xi] xis - con = classTyCon cl +rewriteDict :: (EqVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt +rewriteDict (eqv,tv,xi) (dv,gw,cl,xis) + = do { let args = substTysWith [tv] [xi] xis dict_co = mkTyConAppCo con cos + where cos = map (liftCoSubstWith [tv] [cv]) xis -- xis[tv] ~ xis[xi] + con = classTyCon cl + cv = mkEqVarLCo eqv ; dv' <- newDictVar cl args ; case gw of - Wanted {} -> setDictBind dv (EvCast dv' (mkSymCo dict_co)) - Given {} -> setDictBind dv' (EvCast dv dict_co) + Wanted {} -> setEvBind dv (EvCast dv' (mkSymCo dict_co)) + Given {} -> setEvBind dv' (EvCast dv dict_co) Derived {} -> return () -- Derived dicts we don't set any evidence ; return (CDictCan { cc_id = dv' @@ -1173,14 +1206,28 @@ rewriteDict (cv,tv,xi) (dv,gw,cl,xis) , cc_class = cl , cc_tyargs = args }) } -rewriteIP :: (CoVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt -rewriteIP (cv,tv,xi) (ipid,gw,nm,ty) - = do { let ip_co = liftCoSubstWith [tv] [mkCoVarCo cv] ty -- ty[tv] ~ t[xi] - ty' = substTyWith [tv] [xi] ty +rewriteIrred :: (EqVar,TcTyVar,Xi) -> (EvVar,CtFlavor,TcType) -> TcS WorkList +rewriteIrred (eqv,tv,xi) (id,gw,ty) + = do { let ty' = substTyWith [tv] [xi] ty + co = liftCoSubstWith [tv] [cv] ty -- ty[tv] ~ ty[xi] + where cv = mkEqVarLCo eqv + ; id' <- newEvVar ty' + ; case gw of + Wanted {} -> setEvBind id (EvCast id' (mkSymCo co)) + Given {} -> setEvBind id' (EvCast id co) + Derived {} -> return () -- Derived ips: we don't set any evidence + + ; mkCanonical gw id' } + +rewriteIP :: (EqVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt +rewriteIP (eqv,tv,xi) (ipid,gw,nm,ty) + = do { let ty' = substTyWith [tv] [xi] ty + ip_co = liftCoSubstWith [tv] [cv] ty -- ty[tv] ~ ty[xi] + where cv = mkEqVarLCo eqv ; ipid' <- newIPVar nm ty' ; case gw of - Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCo ip_co)) - Given {} -> setIPBind ipid' (EvCast ipid ip_co) + Wanted {} -> setEvBind ipid (EvCast ipid' (mkSymCo ip_co)) + Given {} -> setEvBind ipid' (EvCast ipid ip_co) Derived {} -> return () -- Derived ips: we don't set any evidence ; return (CIPCan { cc_id = ipid' @@ -1188,107 +1235,114 @@ rewriteIP (cv,tv,xi) (ipid,gw,nm,ty) , cc_ip_nm = nm , cc_ip_ty = ty' }) } -rewriteFunEq :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt -rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2) -- cv2 :: F args ~ xi2 - = do { let co_subst = liftCoSubstWith [tv] [mkCoVarCo cv1] - arg_cos = map co_subst args - args' = substTysWith [tv] [xi1] args - fun_co = mkTyConAppCo tc arg_cos -- fun_co :: F args ~ F args' - +rewriteFunEq :: (EqVar,TcTyVar,Xi) -> (EqVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt +rewriteFunEq (eqv1,tv,xi1) (eqv2,gw, tc,args,xi2) -- cv2 :: F args ~ xi2 + = do { let args' = substTysWith [tv] [xi1] args xi2' = substTyWith [tv] [xi1] xi2 - xi2_co = co_subst xi2 -- xi2_co :: xi2 ~ xi2' - - ; cv2' <- newCoVar (mkTyConApp tc args') xi2' + + (fun_co, xi2_co) = (fun_co, xi2_co) + where cv1 = mkEqVarLCo eqv1 + co_subst = liftCoSubstWith [tv] [cv1] + arg_cos = map co_subst args + fun_co = mkTyConAppCo tc arg_cos -- fun_co :: F args ~ F args' + + xi2_co = co_subst xi2 -- xi2_co :: xi2 ~ xi2' + + ; eqv2' <- newEqVar (mkTyConApp tc args') xi2' ; case gw of - Wanted {} -> setCoBind cv2 (fun_co `mkTransCo` - mkCoVarCo cv2' `mkTransCo` - mkSymCo xi2_co) - Given {} -> setCoBind cv2' (mkSymCo fun_co `mkTransCo` - mkCoVarCo cv2 `mkTransCo` - xi2_co) + Wanted {} -> setEqBind eqv2 + (fun_co `mkTransCo` + mkEqVarLCo eqv2' `mkTransCo` + mkSymCo xi2_co) + Given {} -> setEqBind eqv2' + (mkSymCo fun_co `mkTransCo` + mkEqVarLCo eqv2 `mkTransCo` + xi2_co) Derived {} -> return () - ; return (CFunEqCan { cc_id = cv2' + ; return (CFunEqCan { cc_id = eqv2' , cc_flavor = gw , cc_tyargs = args' , cc_fun = tc , cc_rhs = xi2' }) } -rewriteEqRHS :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TcTyVar,Xi) -> TcS WorkList +rewriteEqRHS :: (EqVar,TcTyVar,Xi) -> (EqVar,CtFlavor,TcTyVar,Xi) -> TcS WorkList -- Use the first equality to rewrite the second, flavors already checked. -- E.g. c1 : tv1 ~ xi1 c2 : tv2 ~ xi2 -- rewrites c2 to give -- c2' : tv2 ~ xi2[xi1/tv1] -- We must do an occurs check to sure the new constraint is canonical -- So we might return an empty bag -rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) +rewriteEqRHS (eqv1,tv1,xi1) (eqv2,gw,tv2,xi2) | Just tv2' <- tcGetTyVar_maybe xi2' , tv2 == tv2' -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2 - = do { when (isWanted gw) (setCoBind cv2 (mkSymCo co2')) + = do { when (isWanted gw) $ setEqBind eqv2 (mkSymCo co2') ; return emptyWorkList } | otherwise - = do { cv2' <- newCoVar (mkTyVarTy tv2) xi2' + = do { eqv2' <- newEqVar (mkTyVarTy tv2) xi2' ; case gw of - Wanted {} -> setCoBind cv2 $ mkCoVarCo cv2' `mkTransCo` - mkSymCo co2' - Given {} -> setCoBind cv2' $ mkCoVarCo cv2 `mkTransCo` - co2' + Wanted {} -> setEqBind eqv2 (mkEqVarLCo eqv2' `mkTransCo` mkSymCo co2') + Given {} -> setEqBind eqv2' (mkEqVarLCo eqv2 `mkTransCo` co2') Derived {} -> return () - ; canEqToWorkList gw cv2' (mkTyVarTy tv2) xi2' } + ; canEqToWorkList gw eqv2' (mkTyVarTy tv2) xi2' } where xi2' = substTyWith [tv1] [xi1] xi2 - co2' = liftCoSubstWith [tv1] [mkCoVarCo cv1] xi2 -- xi2 ~ xi2[xi1/tv1] + co2' = liftCoSubstWith [tv1] [cv1] xi2 -- xi2 ~ xi2[xi1/tv1] + where cv1 = mkEqVarLCo eqv1 -rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS WorkList +rewriteEqLHS :: WhichComesFromInert -> (EqVar,Xi) -> (EqVar,CtFlavor,Xi) -> TcS WorkList -- Used to ineract two equalities of the following form: -- First Equality: co1: (XXX ~ xi1) -- Second Equality: cv2: (XXX ~ xi2) -- Where the cv1 `canRewrite` cv2 equality -- We have an option of creating new work (xi1 ~ xi2) OR (xi2 ~ xi1), -- See Note [Efficient Orientation] for that -rewriteEqLHS LeftComesFromInert (co1,xi1) (cv2,gw,xi2) - = do { cv2' <- newCoVar xi2 xi1 +rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,gw,xi2) + = do { eqv2' <- newEqVar xi2 xi1 ; case gw of - Wanted {} -> setCoBind cv2 $ - co1 `mkTransCo` mkSymCo (mkCoVarCo cv2') - Given {} -> setCoBind cv2' $ - mkSymCo (mkCoVarCo cv2) `mkTransCo` co1 + Wanted {} -> setEqBind eqv2 + (mkEqVarLCo eqv1 `mkTransCo` mkSymCo (mkEqVarLCo eqv2')) + Given {} -> setEqBind eqv2' + (mkSymCo (mkEqVarLCo eqv2) `mkTransCo` mkEqVarLCo eqv1) Derived {} -> return () - ; mkCanonical gw cv2' } + ; mkCanonical gw eqv2' } -rewriteEqLHS RightComesFromInert (co1,xi1) (cv2,gw,xi2) - = do { cv2' <- newCoVar xi1 xi2 +rewriteEqLHS RightComesFromInert (eqv1,xi1) (eqv2,gw,xi2) + = do { eqv2' <- newEqVar xi1 xi2 ; case gw of - Wanted {} -> setCoBind cv2 $ - co1 `mkTransCo` mkCoVarCo cv2' - Given {} -> setCoBind cv2' $ - mkSymCo co1 `mkTransCo` mkCoVarCo cv2 + Wanted {} -> setEqBind eqv2 + (mkTransCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2')) + Given {} -> setEqBind eqv2' + (mkSymCo (mkEqVarLCo eqv1) `mkTransCo` mkEqVarLCo eqv2) Derived {} -> return () - ; mkCanonical gw cv2' } + ; mkCanonical gw eqv2' } -rewriteFrozen :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor) -> TcS WorkList -rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) - = do { cv2' <- newCoVar ty2a' ty2b' -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1] +rewriteFrozen :: (EqVar,TcTyVar,Xi) -> (EqVar,CtFlavor) -> TcS WorkList +rewriteFrozen (eqv1, tv1, xi1) (eqv2, fl2) + = do { eqv2' <- newEqVar ty2a' ty2b' -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1] ; case fl2 of - Wanted {} -> setCoBind cv2 $ co2a' `mkTransCo` - mkCoVarCo cv2' `mkTransCo` - mkSymCo co2b' + Wanted {} -> setEqBind eqv2 + (co2a' `mkTransCo` + mkEqVarLCo eqv2' `mkTransCo` + mkSymCo co2b') - Given {} -> setCoBind cv2' $ mkSymCo co2a' `mkTransCo` - mkCoVarCo cv2 `mkTransCo` - co2b' + Given {} -> setEqBind eqv2' + (mkSymCo co2a' `mkTransCo` + mkEqVarLCo eqv2 `mkTransCo` + co2b') Derived {} -> return () - ; return (workListFromNonEq $ CFrozenErr { cc_id = cv2', cc_flavor = fl2 }) } + ; return (workListFromNonEq $ CFrozenErr { cc_id = eqv2', cc_flavor = fl2 }) } where - (ty2a, ty2b) = coVarKind cv2 -- cv2 : ty2a ~ ty2b + (ty2a, ty2b) = getEqPredTys (evVarPred eqv2) -- cv2 : ty2a ~ ty2b ty2a' = substTyWith [tv1] [xi1] ty2a ty2b' = substTyWith [tv1] [xi1] ty2b - co2a' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2a -- ty2a ~ ty2a[xi1/tv1] - co2b' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2b -- ty2b ~ ty2b[xi1/tv1] + cv1 = mkEqVarLCo eqv1 + co2a' = liftCoSubstWith [tv1] [cv1] ty2a -- ty2a ~ ty2a[xi1/tv1] + co2b' = liftCoSubstWith [tv1] [cv1] ty2b -- ty2b ~ ty2b[xi1/tv1] solveOneFromTheOther_ExtraWork :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> WorkList -> TcS InteractResult @@ -1742,7 +1796,7 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc , cc_class = cls, cc_tyargs = xis }) = do { instEnvs <- getInstEnvs ; let fd_eqns = improveFromInstEnv instEnvs - (ClassP cls xis, pprArisingAt loc) + (mkClassPred cls xis, pprArisingAt loc) ; m <- rewriteWithFunDeps fd_eqns xis loc ; case m of Nothing -> return NoTopInt @@ -1762,7 +1816,7 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) -- See Note [MATCHING-SYNONYMS] = do { traceTcS "doTopReact" (ppr workItem) ; instEnvs <- getInstEnvs - ; let fd_eqns = improveFromInstEnv instEnvs $ (ClassP cls xis, pprArisingAt loc) + ; let fd_eqns = improveFromInstEnv instEnvs $ (mkClassPred cls xis, pprArisingAt loc) ; any_fundeps <- rewriteWithFunDeps fd_eqns xis loc ; case any_fundeps of @@ -1801,12 +1855,12 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) doSolveFromInstance wtvs ev_term workItem extra_work | null wtvs = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem)) - ; setDictBind (cc_id workItem) ev_term + ; setEvBind (cc_id workItem) ev_term ; return $ SomeTopInt { tir_new_work = extra_work , tir_new_inert = Stop } } | otherwise = do { traceTcS "doTopReact/found non-nullary instance for" (ppr (cc_id workItem)) - ; setDictBind (cc_id workItem) ev_term + ; setEvBind (cc_id workItem) ev_term -- Solved and new wanted work produced, you may cache the -- (tentatively solved) dictionary as Solved given. ; let solved = workItem { cc_flavor = solved_fl } @@ -1822,7 +1876,7 @@ doTopReact _inerts (CFunEqCan { cc_flavor = fl }) = return NoTopInt -- If Solved, no more interactions should happen -- Otherwise, it's a Given, Derived, or Wanted -doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl +doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl , cc_fun = tc, cc_tyargs = args, cc_rhs = xi }) = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS] @@ -1837,9 +1891,9 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl -- See Note [Type synonym families] in TyCon coe = mkAxInstCo coe_tc rep_tys ; case fl of - Wanted {} -> do { cv' <- newCoVar rhs_ty xi - ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv' - ; can_cts <- mkCanonical fl cv' + Wanted {} -> do { eqv' <- newEqVar rhs_ty xi + ; setEqBind eqv (coe `mkTransCo` mkEqVarLCo eqv') + ; can_cts <- mkCanonical fl eqv' ; let solved = workItem { cc_flavor = solved_fl } solved_fl = mkSolvedFlavor fl UnkSkol ; if isEmptyWorkList can_cts then @@ -1848,15 +1902,15 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl SomeTopInt { tir_new_work = can_cts , tir_new_inert = ContinueWith solved } } - Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $ - mkSymCo (mkCoVarCo cv) `mkTransCo` coe - ; can_cts <- mkCanonical fl cv' + Given {} -> do { eqv' <- newEqVar xi rhs_ty + ; setEqBind eqv' (mkSymCo (mkEqVarLCo eqv) `mkTransCo` coe) + ; can_cts <- mkCanonical fl eqv' ; return $ SomeTopInt { tir_new_work = can_cts , tir_new_inert = Stop } } - Derived {} -> do { cv' <- newDerivedId (EqPred xi rhs_ty) - ; can_cts <- mkCanonical fl cv' + Derived {} -> do { eqv' <- newDerivedId (mkEqPred (xi, rhs_ty)) + ; can_cts <- mkCanonical fl eqv' ; return $ SomeTopInt { tir_new_work = can_cts , tir_new_inert = Stop } @@ -1983,7 +2037,7 @@ two possibilities: now solvable by the given Q [a]. However, this option is restrictive, for instance [Example 3] from - Note [Recursive dictionaries] will fail to work. + Note [Recursive instances and superclases] will fail to work. 2. Ignore the problem, hoping that the situations where there exist indeed such multiple strategies are rare: Indeed the cause of the previous @@ -2082,7 +2136,7 @@ matchClassInst inerts clas tys loc MatchInstSingle (_,_) | given_overlap untch -> do { traceTcS "Delaying instance application" $ - vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys) + vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys) , text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ] ; return NoInstance -- see Note [Instance and Given overlap] } diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 063eff79e1..ae822b334f 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -25,8 +25,8 @@ module TcMType ( -------------------------------- -- Creating new evidence variables - newEvVar, newCoVar, newEvVars, - newIP, newDict, + newEvVar, newEvVars, + newEq, newIP, newDict, newWantedEvVar, newWantedEvVars, newTcEvBinds, addTcEvBind, @@ -77,6 +77,7 @@ import Var -- others: import HsSyn -- HsType import TcRnMonad -- TcType, amongst others +import IParam import Id import FunDeps import Name @@ -126,40 +127,40 @@ newEvVars :: TcThetaType -> TcM [EvVar] newEvVars theta = mapM newEvVar theta newWantedEvVar :: TcPredType -> TcM EvVar -newWantedEvVar (EqPred ty1 ty2) = newCoVar ty1 ty2 -newWantedEvVar (ClassP cls tys) = newDict cls tys -newWantedEvVar (IParam ip ty) = newIP ip ty +newWantedEvVar = newEvVar newWantedEvVars :: TcThetaType -> TcM [EvVar] newWantedEvVars theta = mapM newWantedEvVar theta -------------- + newEvVar :: TcPredType -> TcM EvVar -- Creates new *rigid* variables for predicates -newEvVar (EqPred ty1 ty2) = newCoVar ty1 ty2 -newEvVar (ClassP cls tys) = newDict cls tys -newEvVar (IParam ip ty) = newIP ip ty +newEvVar ty = do { name <- newName (predTypeOccName ty) + ; return (mkLocalId name ty) } -newCoVar :: TcType -> TcType -> TcM CoVar -newCoVar ty1 ty2 - = do { name <- newName (mkVarOccFS (fsLit "co")) - ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) } +newEq :: TcType -> TcType -> TcM EvVar +newEq ty1 ty2 + = do { name <- newName (mkVarOccFS (fsLit "cobox")) + ; return (mkLocalId name (mkEqPred (ty1, ty2))) } newIP :: IPName Name -> TcType -> TcM IpId newIP ip ty - = do { name <- newName (getOccName (ipNameName ip)) - ; return (mkLocalId name (mkPredTy (IParam ip ty))) } + = do { name <- newName (mkVarOccFS (ipFastString ip)) + ; return (mkLocalId name (mkIPPred ip ty)) } newDict :: Class -> [TcType] -> TcM DictId newDict cls tys = do { name <- newName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name (mkPredTy (ClassP cls tys))) } - -newName :: OccName -> TcM Name -newName occ - = do { uniq <- newUnique - ; loc <- getSrcSpanM - ; return (mkInternalName uniq occ loc) } + ; return (mkLocalId name (mkClassPred cls tys)) } + +predTypeOccName :: PredType -> OccName +predTypeOccName ty = case predTypePredTree ty of + ClassPred cls _ -> mkDictOcc (getOccName cls) + IPPred ip _ -> mkVarOccFS (ipFastString ip) + EqPred _ _ -> mkVarOccFS (fsLit "cobox") + TuplePred _ -> mkVarOccFS (fsLit "tup") + IrredPred _ -> mkVarOccFS (fsLit "irred") \end{code} @@ -501,9 +502,7 @@ zonkTcThetaType :: TcThetaType -> TcM TcThetaType zonkTcThetaType theta = mapM zonkTcPredType theta zonkTcPredType :: TcPredType -> TcM TcPredType -zonkTcPredType (ClassP c ts) = ClassP c <$> zonkTcTypes ts -zonkTcPredType (IParam n t) = IParam n <$> zonkTcType t -zonkTcPredType (EqPred t1 t2) = EqPred <$> zonkTcType t1 <*> zonkTcType t2 +zonkTcPredType = zonkTcType \end{code} ------------------- These ...ToType, ...ToKind versions @@ -707,9 +706,6 @@ zonkType zonk_tc_tyvar ty go (TyConApp tc tys) = do tys' <- mapM go tys return (TyConApp tc tys') - go (PredTy p) = do p' <- go_pred p - return (PredTy p') - go (FunTy arg res) = do arg' <- go arg res' <- go res return (FunTy arg' res') @@ -731,14 +727,6 @@ zonkType zonk_tc_tyvar ty tyvar' <- return tyvar return (ForAllTy tyvar' ty') - go_pred (ClassP c tys) = do tys' <- mapM go tys - return (ClassP c tys') - go_pred (IParam n ty) = do ty' <- go ty - return (IParam n ty') - go_pred (EqPred ty1 ty2) = do ty1' <- go ty1 - ty2' <- go ty2 - return (EqPred ty1' ty2') - mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an *mutable Flexi* var -> TcTyVar -> TcM TcType mkZonkTcTyVar unbound_var_fn tyvar @@ -929,10 +917,6 @@ check_type rank ubx_tup ty where (tvs, theta, tau) = tcSplitSigmaTy ty --- Naked PredTys should, I think, have been rejected before now -check_type _ _ ty@(PredTy {}) - = failWithTc (text "Predicate" <+> ppr ty <+> text "used as a type") - check_type _ _ (TyVarTy _) = return () check_type rank _ (FunTy arg_ty res_ty) @@ -1126,14 +1110,17 @@ check_valid_theta ctxt theta = do ------------------------- check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM () -check_pred_ty dflags ctxt pred@(ClassP cls tys) +check_pred_ty dflags ctxt pred = check_pred_ty' dflags ctxt (shallowPredTypePredTree pred) + +check_pred_ty' :: DynFlags -> SourceTyCtxt -> PredTree -> TcM () +check_pred_ty' dflags ctxt (ClassPred cls tys) = do { -- Class predicates are valid in all contexts ; checkTc (arity == n_tys) arity_err -- Check the form of the argument types ; mapM_ checkValidMonoType tys ; checkTc (check_class_pred_tys dflags ctxt tys) - (predTyVarErr pred $$ how_to_allow) + (predTyVarErr (mkClassPred cls tys) $$ how_to_allow) } where class_name = className cls @@ -1143,30 +1130,66 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys) how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this")) -check_pred_ty dflags _ctxt pred@(EqPred ty1 ty2) +check_pred_ty' dflags _ctxt (EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) - (eqPredTyErr pred) + (eqPredTyErr (mkEqPred (ty1, ty2))) -- Check the form of the argument types ; checkValidMonoType ty1 ; checkValidMonoType ty2 } -check_pred_ty _ SigmaCtxt (IParam _ ty) = checkValidMonoType ty - -- Implicit parameters only allowed in type - -- signatures; not in instance decls, superclasses etc - -- The reason for not allowing implicit params in instances is a bit - -- subtle. +check_pred_ty' _ _ctxt (IPPred _ ty) = checkValidMonoType ty + -- Contrary to GHC 7.2 and below, we allow implicit parameters not only + -- in type signatures but also in instance decls, superclasses etc + -- The reason we didn't allow implicit params in instances is a bit + -- subtle: -- If we allowed instance (?x::Int, Eq a) => Foo [a] where ... -- then when we saw (e :: (?x::Int) => t) it would be unclear how to -- discharge all the potential usas of the ?x in e. For example, a -- constraint Foo [Int] might come out of e,and applying the -- instance decl would show up two uses of ?x. - --- Catch-all -check_pred_ty _ _ sty = failWithTc (badPredTyErr sty) + -- + -- Happily this is not an issue in the new constraint solver. + +check_pred_ty' dflags ctxt t@(TuplePred ts) + = do { checkTc (xopt Opt_ConstraintKind dflags) + (predTupleErr (predTreePredType t)) + ; mapM_ (check_pred_ty' dflags ctxt) ts } + -- This case will not normally be executed because without ConstraintKind + -- tuple types are only kind-checked as * + +check_pred_ty' dflags ctxt (IrredPred pred) + -- Allowing irreducible predicates in class superclasses is somewhat dangerous + -- because we can write: + -- + -- type family Fooish x :: * -> Constraint + -- type instance Fooish () = Foo + -- class Fooish () a => Foo a where + -- + -- This will cause the constraint simplifier to loop because every time we canonicalise a + -- (Foo a) class constraint we add a (Fooish () a) constraint which will be immediately + -- solved to add+canonicalise another (Foo a) constraint. + -- + -- It is equally dangerous to allow them in instance heads because in that case the + -- Paterson conditions may not detect duplication of a type variable or size change. + -- + -- In both cases it's OK if the predicate is actually a synonym, though. + -- We'll also allow it if + = do checkTc (xopt Opt_ConstraintKind dflags) + (predIrredErr pred) + case tcView pred of + Just pred' -> + -- Synonym: just look through + check_pred_ty dflags ctxt pred' + Nothing + | xopt Opt_UndecidableInstances dflags -> return () + | otherwise -> do + -- Make sure it is OK to have an irred pred in this context + checkTc (case ctxt of ClassSCCtxt _ -> False; InstThetaCtxt -> False; _ -> True) + (predIrredBadCtxtErr pred) ------------------------- check_class_pred_tys :: DynFlags -> SourceTyCtxt -> [Type] -> Bool @@ -1236,14 +1259,14 @@ checkAmbiguity forall_tyvars theta tau_tyvars -- See Note [Implicit parameters and ambiguity] in TcSimplify is_ambig pred = isClassPred pred && - any ambig_var (varSetElems (tyVarsOfPred pred)) + any ambig_var (varSetElems (tyVarsOfType pred)) ambig_var ct_var = (ct_var `elem` forall_tyvars) && not (ct_var `elemVarSet` extended_tau_vars) ambigErr :: PredType -> SDoc ambigErr pred - = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred), + = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprType pred), nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$ ptext (sLit "must be reachable from the type after the '=>'"))] \end{code} @@ -1270,12 +1293,16 @@ growPredTyVars :: TcPredType -> TyVarSet -- The set to extend -> TyVarSet -- TyVars of the predicate if it intersects -- the set, or is implicit parameter -growPredTyVars pred tvs - | IParam {} <- pred = pred_tvs -- See Note [Implicit parameters and ambiguity] - | pred_tvs `intersectsVarSet` tvs = pred_tvs - | otherwise = emptyVarSet +growPredTyVars pred tvs = go (predTypePredTree pred) where - pred_tvs = tyVarsOfPred pred + grow pred_tvs | pred_tvs `intersectsVarSet` tvs = pred_tvs + | otherwise = emptyVarSet + + go (IPPred _ ty) = tyVarsOfType ty -- See Note [Implicit parameters and ambiguity] + go (ClassPred _ tys) = grow (tyVarsOfTypes tys) + go (EqPred ty1 ty2) = grow (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2) + go (TuplePred ts) = unionVarSets (map go ts) + go (IrredPred ty) = grow (tyVarsOfType ty) \end{code} Note [Implicit parameters and ambiguity] @@ -1304,15 +1331,21 @@ checkThetaCtxt ctxt theta = vcat [ptext (sLit "In the context:") <+> pprTheta theta, ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ] -badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc -badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred -eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred +eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predIrredBadCtxtErr :: PredType -> SDoc +eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprType pred $$ parens (ptext (sLit "Use -XGADTs or -XTypeFamilies to permit this")) predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"), - nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprType pred)] +predTupleErr pred = ptext (sLit "Illegal tuple constraint") <+> pprType pred $$ + parens (ptext (sLit "Use -XConstraintKind to permit this")) +predIrredErr pred = ptext (sLit "Illegal irreducible constraint") <+> pprType pred $$ + parens (ptext (sLit "Use -XConstraintKind to permit this")) +predIrredBadCtxtErr pred = ptext (sLit "Illegal irreducible constraint") <+> pprType pred $$ + ptext (sLit "in superclass/instance head context") <+> + parens (ptext (sLit "Use -XUndecidableInstances to permit this")) dupPredWarn :: [[PredType]] -> SDoc -dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups) +dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprType (map head dups) arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m @@ -1403,13 +1436,12 @@ not converge. See Trac #5287. \begin{code} validDerivPred :: TyVarSet -> PredType -> Bool -validDerivPred tv_set (ClassP _ tys) - = hasNoDups fvs - && sizeTypes tys == length fvs - && all (`elemVarSet` tv_set) fvs - where - fvs = fvTypes tys -validDerivPred _ _ = False +validDerivPred tv_set ty = case getClassPredTys_maybe ty of + Just (_, tys) | let fvs = fvTypes tys + -> hasNoDups fvs + && sizeTypes tys == length fvs + && all (`elemVarSet` tv_set) fvs + _ -> False \end{code} @@ -1474,7 +1506,7 @@ checkInstTermination tys theta fvs = fvTypes tys size = sizeTypes tys check pred - | not (null (fvPred pred \\ fvs)) + | not (null (fvType pred \\ fvs)) = Just (predUndecErr pred nomoreMsg $$ parens undecidableMsg) | sizePred pred >= size = Just (predUndecErr pred smallerMsg $$ parens undecidableMsg) @@ -1483,7 +1515,7 @@ checkInstTermination tys theta predUndecErr :: PredType -> SDoc -> SDoc predUndecErr pred msg = sep [msg, - nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprType pred)] nomoreMsg, smallerMsg, undecidableMsg :: SDoc nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head") @@ -1587,7 +1619,6 @@ fvType :: Type -> [TyVar] fvType ty | Just exp_ty <- tcView ty = fvType exp_ty fvType (TyVarTy tv) = [tv] fvType (TyConApp _ tys) = fvTypes tys -fvType (PredTy pred) = fvPred pred fvType (FunTy arg res) = fvType arg ++ fvType res fvType (AppTy fun arg) = fvType fun ++ fvType arg fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty) @@ -1595,17 +1626,12 @@ fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty) fvTypes :: [Type] -> [TyVar] fvTypes tys = concat (map fvType tys) -fvPred :: PredType -> [TyVar] -fvPred (ClassP _ tys') = fvTypes tys' -fvPred (IParam _ ty) = fvType ty -fvPred (EqPred ty1 ty2) = fvType ty1 ++ fvType ty2 - -- Size of a type: the number of variables and constructors sizeType :: Type -> Int sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty +sizeType ty | isPredTy ty = sizePred ty sizeType (TyVarTy _) = 1 sizeType (TyConApp _ tys) = sizeTypes tys + 1 -sizeType (PredTy pred) = sizePred pred sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 sizeType (AppTy fun arg) = sizeType fun + sizeType arg sizeType (ForAllTy _ ty) = sizeType ty @@ -1620,7 +1646,11 @@ sizeTypes xs = sum (map sizeType xs) -- can't get back to a class constraint, so it's safe -- to say "size 0". See Trac #4200. sizePred :: PredType -> Int -sizePred (ClassP _ tys') = sizeTypes tys' -sizePred (IParam {}) = 0 -sizePred (EqPred {}) = 0 +sizePred ty = go (predTypePredTree ty) + where + go (ClassPred _ tys') = sizeTypes tys' + go (IPPred {}) = 0 + go (EqPred {}) = 0 + go (TuplePred ts) = sum (map go ts) + go (IrredPred ty) = sizeType ty \end{code} diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 29890a21b5..9fca9fc52f 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -145,9 +145,9 @@ matchFunTys -- could probably be un-CPSd, like matchExpectedTyConApp matchFunTys herald arity res_ty thing_inside - = do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty + = do { (co, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty ; res <- thing_inside pat_tys res_ty - ; return (coToHsWrapper (mkSymCo coi), res) } + ; return (coToHsWrapper (mkSymCo co), res) } \end{code} %************************************************************************ @@ -245,16 +245,16 @@ tcDoStmts :: HsStmtContext Name -> TcRhoType -> TcM (HsExpr TcId) -- Returns a HsDo tcDoStmts ListComp stmts res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty + = do { (co, elt_ty) <- matchExpectedListTy res_ty ; let list_ty = mkListTy elt_ty ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty - ; return $ mkHsWrapCo coi (HsDo ListComp stmts' list_ty) } + ; return $ mkHsWrapCo co (HsDo ListComp stmts' list_ty) } tcDoStmts PArrComp stmts res_ty - = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + = do { (co, elt_ty) <- matchExpectedPArrTy res_ty ; let parr_ty = mkPArrTy elt_ty ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty - ; return $ mkHsWrapCo coi (HsDo PArrComp stmts' parr_ty) } + ; return $ mkHsWrapCo co (HsDo PArrComp stmts' parr_ty) } tcDoStmts DoExpr stmts res_ty = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty @@ -729,8 +729,8 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi -- but we don't have any good way to incorporate the coercion -- so for now we just check that it's the identity check_same actual expected - = do { coi <- unifyType actual expected - ; unless (isReflCo coi) $ + = do { co <- unifyType actual expected + ; unless (isReflCo co) $ failWithMisMatch [UnifyOrigin { uo_expected = expected , uo_actual = actual }] } diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 8304a22ddb..e16c97d000 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -192,15 +192,15 @@ res_ty free vars. %************************************************************************ \begin{code} -tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (Coercion, TcId) +tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (LCoercion, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty | Just sig <- lookup_sig bndr_name = do { bndr_id <- newSigLetBndr no_gen bndr_name sig - ; coi <- unifyPatType (idType bndr_id) pat_ty - ; return (coi, bndr_id) } + ; co <- unifyPatType (idType bndr_id) pat_ty + ; return (co, bndr_id) } | otherwise = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty @@ -370,9 +370,9 @@ tc_pat :: PatEnv a) -- Result of thing inside tc_pat penv (VarPat name) pat_ty thing_inside - = do { (coi, id) <- tcPatBndr penv name pat_ty - ; res <- tcExtendIdEnv1 name id thing_inside - ; return (mkHsWrapPatCo coi (VarPat id) pat_ty, res) } + = do { (co, id) <- tcPatBndr penv name pat_ty + ; res <- tcExtendIdEnv1 name id thing_inside + ; return (mkHsWrapPatCo co (VarPat id) pat_ty, res) } tc_pat penv (ParPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -412,8 +412,8 @@ tc_pat _ (WildPat _) pat_ty thing_inside ; return (WildPat pat_ty, res) } tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside - = do { (coi, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ + = do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (idType bndr_id) penv thing_inside -- NB: if we do inference on: -- \ (y@(x::forall a. a->a)) = e @@ -422,7 +422,7 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- perhaps be fixed, but only with a bit more work. -- -- If you fix it, don't forget the bindInstsOfPatIds! - ; return (mkHsWrapPatCo coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPatCo co (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside = do { checkUnboxedTuple overall_pat_ty $ @@ -441,13 +441,13 @@ tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside -- (view -> f) where view :: _ -> forall b. b -- we will only be able to use view at one instantation in the -- rest of the view - ; (expr_coi, pat_ty) <- tcInfer $ \ pat_ty -> + ; (expr_co, pat_ty) <- tcInfer $ \ pat_ty -> unifyPatType expr'_inferred (mkFunTy overall_pat_ty pat_ty) - + -- pattern must have pat_ty ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ViewPat (mkLHsWrapCo expr_coi expr') pat' overall_pat_ty, res) } + ; return (ViewPat (mkLHsWrapCo expr_co expr') pat' overall_pat_ty, res) } -- Type signatures in patterns -- See Note [Pattern coercions] below @@ -475,7 +475,7 @@ 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 tc = tupleTyCon (boxityNormalTupleSort boxity) (length pats) ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) pat_ty ; (pats', res) <- tc_lpats penv pats arg_tys thing_inside @@ -504,10 +504,10 @@ 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 - ; coi <- unifyPatType lit_ty pat_ty + ; co <- unifyPatType lit_ty pat_ty -- coi is of kind: pat_ty ~ lit_ty ; res <- thing_inside - ; return ( mkHsWrapPatCo coi (LitPat simple_lit) pat_ty + ; return ( mkHsWrapPatCo co (LitPat simple_lit) pat_ty , res) } ------------------------ @@ -526,8 +526,8 @@ tc_pat _ (NPat over_lit mb_neg eq) pat_ty thing_inside ; return (NPat lit' mb_neg' eq', res) } tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside - = do { (coi, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; let pat_ty' = idType bndr_id + = do { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; let pat_ty' = idType bndr_id orig = LiteralOrigin lit ; lit' <- newOverloadedLit orig lit pat_ty' @@ -542,12 +542,12 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside ; instStupidTheta orig [mkClassPred icls [pat_ty']] ; res <- tcExtendIdEnv1 name bndr_id thing_inside - ; return (mkHsWrapPatCo coi pat' pat_ty, res) } + ; return (mkHsWrapPatCo co pat' pat_ty, res) } tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut ---------------- -unifyPatType :: TcType -> TcType -> TcM Coercion +unifyPatType :: TcType -> TcType -> TcM LCoercion -- 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 @@ -720,14 +720,14 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside } } ---------------------------- -matchExpectedPatTy :: (TcRhoType -> TcM (Coercion, a)) +matchExpectedPatTy :: (TcRhoType -> TcM (LCoercion, a)) -> TcRhoType -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~ inner_ty matchExpectedPatTy inner_match pat_ty | null tvs && null theta - = do { (coi, res) <- inner_match pat_ty - ; return (coToHsWrapper (mkSymCo coi), res) } + = do { (co, res) <- inner_match pat_ty + ; return (coToHsWrapper (mkSymCo co), res) } -- The Sym is because the inner_match returns a coercion -- that is the other way round to matchExpectedPatTy @@ -743,7 +743,7 @@ matchExpectedPatTy inner_match pat_ty matchExpectedConTy :: TyCon -- The TyCon that this data -- constructor actually returns -> TcRhoType -- The type of the pattern - -> TcM (Coercion, [TcSigmaType]) + -> TcM (LCoercion, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a coercion : T ty1 ... tyn ~ pat_ty -- This is the same way round as matchExpectedListTy etc @@ -755,13 +755,13 @@ matchExpectedConTy data_tc pat_ty = do { (_, tys, subst) <- tcInstTyVars (tyConTyVars data_tc) -- tys = [ty1,ty2] - ; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty - -- coi1 : T (ty1,ty2) ~ pat_ty + ; co1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty + -- co1 : T (ty1,ty2) ~ pat_ty - ; let coi2 = mkAxInstCo co_tc tys - -- coi2 : T (ty1,ty2) ~ T7 ty1 ty2 + ; let co2 = mkAxInstCo co_tc tys + -- co2 : T (ty1,ty2) ~ T7 ty1 ty2 - ; return (mkTransCo (mkSymCo coi2) coi1, tys) } + ; return (mkSymCo co2 `mkTransCo` co1, tys) } | otherwise = matchExpectedTyConApp data_tc pat_ty diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index f5d99b4f1d..f344d0c2dd 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -697,7 +697,19 @@ checkBootDecl (AnId id1) (AnId id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) = checkBootTyCon tc1 tc2 -checkBootDecl (AClass c1) (AClass c2) +checkBootDecl (ADataCon dc1) (ADataCon _) + = pprPanic "checkBootDecl" (ppr dc1) + +checkBootDecl _ _ = False -- probably shouldn't happen + +---------------- +checkBootTyCon :: TyCon -> TyCon -> Bool +checkBootTyCon tc1 tc2 + | not (eqKind (tyConKind tc1) (tyConKind tc2)) + = False -- First off, check the kind + + | Just c1 <- tyConClass_maybe tc1 + , Just c2 <- tyConClass_maybe tc2 = let (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) = classExtraBigSig c1 @@ -712,9 +724,9 @@ checkBootDecl (AClass c1) (AClass c2) eqTypeX env op_ty1 op_ty2 && def_meth1 == def_meth2 where - (_, rho_ty1) = splitForAllTys (idType id1) - op_ty1 = funResultTy rho_ty1 - (_, rho_ty2) = splitForAllTys (idType id2) + (_, rho_ty1) = splitForAllTys (idType id1) + op_ty1 = funResultTy rho_ty1 + (_, rho_ty2) = splitForAllTys (idType id2) op_ty2 = funResultTy rho_ty2 eqFD (as1,bs1) (as2,bs2) = @@ -724,7 +736,7 @@ checkBootDecl (AClass c1) (AClass c2) same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2) in eqListBy same_kind clas_tyvars1 clas_tyvars2 && - -- Checks kind of class + -- Checks kind of class eqListBy eqFD clas_fds1 clas_fds2 && (null sc_theta1 && null op_stuff1 && null ats1 || -- Above tests for an "abstract" class @@ -732,17 +744,6 @@ checkBootDecl (AClass c1) (AClass c2) eqListBy eqSig op_stuff1 op_stuff2 && eqListBy checkBootTyCon ats1 ats2) -checkBootDecl (ADataCon dc1) (ADataCon _) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ = False -- probably shouldn't happen - ----------------- -checkBootTyCon :: TyCon -> TyCon -> Bool -checkBootTyCon tc1 tc2 - | not (eqKind (tyConKind tc1) (tyConKind tc2)) - = False -- First off, check the kind - | isSynTyCon tc1 && isSynTyCon tc2 = ASSERT(tc1 == tc2) let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 @@ -1488,12 +1489,13 @@ tcRnGetInfo' hsc_env name return (thing, fixity, ispecs) lookupInsts :: TyThing -> TcM [Instance] -lookupInsts (AClass cls) - = do { inst_envs <- tcGetInstEnvs - ; return (classInstances inst_envs cls) } - lookupInsts (ATyCon tc) - = do { (pkg_ie, home_ie) <- tcGetInstEnvs + | Just cls <- tyConClass_maybe tc + = do { inst_envs <- tcGetInstEnvs + ; return (classInstances inst_envs cls) } + + | otherwise + = do { (pkg_ie, home_ie) <- tcGetInstEnvs -- Load all instances for all classes that are -- in the type environment (which are all the ones -- we've seen in any interface file so far) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 01389a92db..6a45bb8e1f 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -19,10 +19,12 @@ import HscTypes import Module import RdrName import Name +import Type import TcType import InstEnv import FamInstEnv import PrelNames ( iNTERACTIVE ) +import Coercion import Var import Id @@ -371,6 +373,17 @@ newSysLocalIds fs tys = do { us <- newUniqueSupply ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } +newCoVar :: TcType -> TcType -> TcRnIf gbl lcl EvVar +newCoVar ty1 ty2 + = do { uniq <- newUnique + ; return (mkLocalId (mkInternalName uniq (mkVarOccFS (fsLit "co")) noSrcSpan) (mkCoercionType ty1 ty2)) } + +newName :: OccName -> TcM Name +newName occ + = do { uniq <- newUnique + ; loc <- getSrcSpanM + ; return (mkInternalName uniq occ loc) } + instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique getUniqueSupplyM = newUniqueSupply @@ -940,18 +953,11 @@ newTcEvBinds = do { ref <- newTcRef emptyEvBindMap ; uniq <- newUnique ; return (EvBindsVar ref uniq) } -extendTcEvBinds :: TcEvBinds -> EvVar -> EvTerm -> TcM TcEvBinds -extendTcEvBinds binds@(TcEvBinds binds_var) var rhs - = do { addTcEvBind binds_var var rhs - ; return binds } -extendTcEvBinds (EvBinds bnds) var rhs - = return (EvBinds (bnds `snocBag` EvBind var rhs)) - addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM () -- Add a binding to the TcEvBinds by side effect -addTcEvBind (EvBindsVar ev_ref _) var rhs +addTcEvBind (EvBindsVar ev_ref _) var t = do { bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds var rhs) } + ; writeTcRef ev_ref (extendEvBinds bnds var t) } chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName chooseUniqueOccTc fn = diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 5b944aabe5..ba022cf8b0 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -976,7 +976,7 @@ pprEvVarTheta :: [EvVar] -> SDoc pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) pprEvVarWithType :: EvVar -> SDoc -pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v) +pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) pprWantedsWithLocs :: WantedConstraints -> SDoc pprWantedsWithLocs wcs diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index f444adc924..40fbb71983 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -6,7 +6,7 @@ module TcSMonad ( CanonicalCts, emptyCCan, andCCan, andCCans, singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, - isCFrozenErr, + isCIrredEvCan, isCFrozenErr, WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList, workListFromEq, workListFromNonEq, @@ -32,12 +32,15 @@ module TcSMonad ( SimplContext(..), isInteractive, simplEqsOnly, performDefaulting, -- Creation of evidence variables - newEvVar, newCoVar, newGivenCoVar, - newDerivedId, - newIPVar, newDictVar, newKindConstraint, + newEvVar, + newDerivedId, newGivenEqVar, + newEqVar, newIPVar, newDictVar, newKindConstraint, -- Setting evidence variables - setCoBind, setIPBind, setDictBind, setEvBind, + setEqBind, + setIPBind, + setDictBind, + setEvBind, setWantedTyBind, @@ -153,6 +156,12 @@ data CanonicalCt cc_ip_ty :: TcTauType } + | CIrredEvCan { + cc_id :: EvVar, + cc_flavor :: CtFlavor, + cc_ty :: Xi + } + | CTyEqCan { -- tv ~ xi (recall xi means function free) -- Invariant: -- * tv not in tvs(xi) (occurs check) @@ -197,6 +206,7 @@ tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (t tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys) tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys tyVarsOfCanonical (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty +tyVarsOfCanonical (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty tyVarsOfCanonical (CFrozenErr { cc_id = ev }) = tyVarsOfEvVar ev tyVarsOfCDict :: CanonicalCt -> TcTyVarSet @@ -214,6 +224,8 @@ instance Outputable CanonicalCt where = ppr fl <+> ppr d <+> dcolon <+> pprClassPred cls tys ppr (CIPCan ip fl ip_nm ty) = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty) + ppr (CIrredEvCan v fl ty) + = ppr fl <+> ppr v <+> dcolon <+> ppr ty ppr (CTyEqCan co fl tv ty) = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty) ppr (CFunEqCan co fl tc tys ty) @@ -265,6 +277,10 @@ isCIPCan_Maybe :: CanonicalCt -> Maybe (IPName Name) isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm isCIPCan_Maybe _ = Nothing +isCIrredEvCan :: CanonicalCt -> Bool +isCIrredEvCan (CIrredEvCan {}) = True +isCIrredEvCan _ = False + isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc isCFunEqCan_Maybe _ = Nothing @@ -437,9 +453,9 @@ data TcSEnv } data FlatCache - = FlatCache { givenFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) + = FlatCache { givenFlatCache :: Map.Map FunEqHead (TcType,EqVar,CtFlavor) -- Invariant: all CtFlavors here satisfy isGiven - , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) } + , wantedFlatCache :: Map.Map FunEqHead (TcType,EqVar,CtFlavor) } -- Invariant: all CtFlavors here satisfy isWanted emptyFlatCache :: FlatCache @@ -662,7 +678,7 @@ getFlatCacheMapVar = TcS (return . tcs_flat_map) lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor - -> TcS (Maybe (TcType,Coercion,CtFlavor)) + -> TcS (Maybe (TcType,EqVar,CtFlavor)) -- For givens, we lookup in given flat cache lookupFlatCacheMap tc xis (Given {}) = do { cache_ref <- getFlatCacheMapVar @@ -679,18 +695,18 @@ lookupFlatCacheMap tc xis (Wanted {}) lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing updateFlatCacheMap :: TyCon -> [Xi] - -> TcType -> CtFlavor -> Coercion -> TcS () -updateFlatCacheMap _tc _xis _tv (Derived {}) _co + -> TcType -> CtFlavor -> EqVar -> TcS () +updateFlatCacheMap _tc _xis _tv (Derived {}) _eqv = return () -- Not caching deriveds -updateFlatCacheMap tc xis ty fl co +updateFlatCacheMap tc xis ty fl eqv = do { cache_ref <- getFlatCacheMapVar ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref ; let new_cache_map | isGivenOrSolved fl - = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $ + = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,eqv,fl) $ givenFlatCache cache_map } | isWanted fl - = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $ + = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,eqv,fl) $ wantedFlatCache cache_map } | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map } @@ -701,9 +717,8 @@ getTcEvBindsBag = do { EvBindsVar ev_ref _ <- getTcEvBinds ; wrapTcS $ TcM.readTcRef ev_ref } - -setCoBind :: CoVar -> Coercion -> TcS () -setCoBind cv co = setEvBind cv (EvCoercion co) +setEqBind :: EqVar -> LCoercion -> TcS () +setEqBind eqv co = setEvBind eqv (EvCoercionBox co) setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding @@ -728,9 +743,9 @@ setDictBind = setEvBind setEvBind :: EvVar -> EvTerm -> TcS () -- Internal -setEvBind ev rhs +setEvBind ev t = do { tc_evbinds <- getTcEvBinds - ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) } + ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t } warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS () warnTcS loc warn_if doc @@ -771,7 +786,7 @@ checkWellStagedDFun pred dfun_id loc bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2) +pprEq ty1 ty2 = pprType $ mkEqPred (ty1,ty2) isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv @@ -858,8 +873,8 @@ newKindConstraint :: TcTyVar -> Kind -> TcS CoVar newKindConstraint tv knd = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd ; let ty_k = mkTyVarTy tv_k - ; co_var <- newCoVar (mkTyVarTy tv) ty_k - ; return co_var } + ; eqv <- newEqVar (mkTyVarTy tv) ty_k + ; return eqv } instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar instFlexiTcSHelper tvname tvkind @@ -879,18 +894,18 @@ newEvVar pty = wrapTcS $ TcM.newEvVar pty newDerivedId :: TcPredType -> TcS EvVar newDerivedId pty = wrapTcS $ TcM.newEvVar pty -newGivenCoVar :: TcType -> TcType -> Coercion -> TcS EvVar +newGivenEqVar :: TcType -> TcType -> Coercion -> TcS EvVar -- Note we create immutable variables for given or derived, since we -- must bind them to TcEvBinds (because their evidence may involve -- superclasses). However we should be able to override existing -- 'derived' evidence, even in TcEvBinds -newGivenCoVar ty1 ty2 co - = do { cv <- newCoVar ty1 ty2 - ; setEvBind cv (EvCoercion co) +newGivenEqVar ty1 ty2 co + = do { cv <- newEqVar ty1 ty2 + ; setEvBind cv (EvCoercionBox co) ; return cv } -newCoVar :: TcType -> TcType -> TcS EvVar -newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2 +newEqVar :: TcType -> TcType -> TcS EvVar +newEqVar ty1 ty2 = wrapTcS $ TcM.newEq ty1 ty2 newIPVar :: IPName Name -> TcType -> TcS EvVar newIPVar nm ty = wrapTcS $ TcM.newIP nm ty diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 636e7481fb..064545dc68 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -444,7 +444,7 @@ quantifyMe :: TyVarSet -- Quantifying over these -> Bool -- True <=> quantify over this wanted quantifyMe qtvs wev | isIPPred pred = True -- Note [Inheriting implicit parameters] - | otherwise = tyVarsOfPred pred `intersectsVarSet` qtvs + | otherwise = tyVarsOfType pred `intersectsVarSet` qtvs where pred = evVarOfPred wev \end{code} @@ -885,8 +885,8 @@ floatEqualities skols can_given wantders where is_floatable :: FlavoredEvVar -> Bool - is_floatable (EvVarX cv _fl) - | isCoVar cv = skols `disjointVarSet` predTvs_under_fsks (coVarPred cv) + is_floatable (EvVarX eqv _fl) + | isEqPred (evVarPred eqv) = skols `disjointVarSet` tvs_under_fsks (evVarPred eqv) is_floatable _flev = False tvs_under_fsks :: Type -> TyVarSet @@ -896,7 +896,6 @@ floatEqualities skols can_given wantders | FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty | otherwise = unitVarSet tv tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys) - tvs_under_fsks (PredTy sty) = predTvs_under_fsks sty tvs_under_fsks (FunTy arg res) = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res tvs_under_fsks (AppTy fun arg) = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder @@ -906,11 +905,6 @@ floatEqualities skols can_given wantders inner_tvs `unionVarSet` tvs_under_fsks (tyVarKind tv) where inner_tvs = tvs_under_fsks ty - - predTvs_under_fsks :: PredType -> TyVarSet - predTvs_under_fsks (IParam _ ty) = tvs_under_fsks ty - predTvs_under_fsks (ClassP _ tys) = unionVarSets (map tvs_under_fsks tys) - predTvs_under_fsks (EqPred ty1 ty2) = tvs_under_fsks ty1 `unionVarSet` tvs_under_fsks ty2 \end{code} Note [Preparing inert set for implications] @@ -1051,7 +1045,7 @@ solveCTyFunEqs cts ; return (niFixTvSubst ni_subst, unsolved_can_cts) } where solve_one (cv,tv,ty) = do { setWantedTyBind tv ty - ; setCoBind cv (mkReflCo ty) } + ; setEqBind cv (mkReflCo ty) } ------------ type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)]) @@ -1201,9 +1195,9 @@ defaultTyVar :: TcsUntouchables -> TcTyVar -> TcS (Bag FlavoredEvVar) defaultTyVar untch the_tv | isTouchableMetaTyVar_InRange untch the_tv , not (k `eqKind` default_k) - = do { ev <- TcSMonad.newKindConstraint the_tv default_k + = do { eqv <- TcSMonad.newKindConstraint the_tv default_k ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk - ; return (unitBag (mkEvVarX ev (Wanted loc))) } + ; return (unitBag (mkEvVarX eqv (Wanted loc))) } | otherwise = return emptyBag -- The common case where @@ -1274,9 +1268,9 @@ disambigGroup [] _inert _grp = return emptyBag disambigGroup (default_ty:default_tys) inert group = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty) - ; ev <- TcSMonad.newCoVar (mkTyVarTy the_tv) default_ty + ; eqv <- TcSMonad.newEqVar (mkTyVarTy the_tv) default_ty ; let der_flav = mk_derived_flavor (cc_flavor the_ct) - derived_eq = mkEvVarX ev der_flav + derived_eq = mkEvVarX eqv der_flav ; success <- tryTcS $ do { (_,final_inert) <- solveInteract inert $ listToBag $ diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index d9562881f9..e924303169 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -38,6 +38,7 @@ import TcExpr import TcHsSyn import TcSimplify import TcUnify +import Type import TcType import TcEnv import TcMType @@ -980,12 +981,13 @@ reifyInstances th_nm th_tys <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { thing <- getThing th_nm ; case thing of - AGlobal (AClass cls) + AGlobal (ATyCon tc) + | Just cls <- tyConClass_maybe tc -> do { tys <- tc_types (classTyCon cls) th_tys ; inst_envs <- tcGetInstEnvs ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys ; mapM reifyClassInstance (map fst matches ++ unifies) } - AGlobal (ATyCon tc) + | otherwise -> do { tys <- tc_types tc th_tys ; inst_envs <- tcGetFamInstEnvs ; let matches = lookupFamInstEnv inst_envs tc tys @@ -1141,7 +1143,6 @@ reifyThing (AGlobal (AnId id)) reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax -reifyThing (AGlobal (AClass cls)) = reifyClass cls reifyThing (AGlobal (ADataCon dc)) = do { let name = dataConName dc ; ty <- reifyType (idType (dataConWrapId dc)) @@ -1177,6 +1178,9 @@ reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs }) reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc + | Just cls <- tyConClass_maybe tc + = reifyClass cls + | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) @@ -1295,12 +1299,12 @@ reifyFamilyInstance fi reifyType :: TypeRep.Type -> TcM TH.Type -- Monadic only because of failure reifyType ty@(ForAllTy _ _) = reify_for_all ty -reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) 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 (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } -reifyType ty@(PredTy {}) = pprPanic "reifyType PredTy" (ppr ty) +reifyType ty@(FunTy 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) } reify_for_all :: TypeRep.Type -> TcM TH.Type reify_for_all ty @@ -1356,16 +1360,16 @@ reify_tc_app tc tys | otherwise = TH.ConT (reifyName tc) reifyPred :: TypeRep.PredType -> TcM TH.Pred -reifyPred (ClassP cls tys) - = do { tys' <- reifyTypes tys - ; return $ TH.ClassP (reifyName cls) tys' } - -reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p) -reifyPred (EqPred ty1 ty2) - = do { ty1' <- reifyType ty1 - ; ty2' <- reifyType ty2 - ; return $ TH.EqualP ty1' ty2' - } +reifyPred ty = case predTypePredTree ty of + ClassPred cls tys -> do { tys' <- reifyTypes tys + ; return $ TH.ClassP (reifyName cls) tys' } + IPPred _ _ -> noTH (sLit "implicit parameters") (ppr ty) + EqPred ty1 ty2 -> do { ty1' <- reifyType ty1 + ; ty2' <- reifyType ty2 + ; return $ TH.EqualP ty1' ty2' + } + TuplePred _ -> noTH (sLit "tuple predicates") (ppr ty) + IrredPred _ -> noTH (sLit "irreducible predicates") (ppr ty) ------------------------------ diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 93d0f5dcbc..0cc8835ad8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -91,7 +91,7 @@ tcTyAndClassDecls boot_details decls_s ; let rec_flags = calcRecFlags boot_details rec_tyclss ; concatMapM (tcTyClDecl rec_flags) kc_decls } - ; traceTc "tcTyAndCl3" (ppr tyclss) + ; traceTc "tcTyAndCl" (ppr tyclss) ; tcExtendGlobalEnv tyclss $ do { -- Perform the validity check @@ -120,7 +120,7 @@ zipRecTyClss :: [[LTyClDecl Name]] -> [(Name,TyThing)] -- Build a name-TyThing mapping for the things bound by decls -- being careful not to look at the [TyThing] --- The TyThings in the result list must have a visible ATyCon/AClass, +-- The TyThings in the result list must have a visible ATyCon, -- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor zipRecTyClss decls_s rec_things = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ] @@ -129,9 +129,6 @@ zipRecTyClss decls_s rec_things rec_type_env = mkTypeEnv rec_things get :: TyClDecl Name -> (Name, TyThing) - get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl) - where - Just (AClass cl) = lookupTypeEnv rec_type_env name get decl = (name, ATyCon tc) where name = tcdName decl @@ -216,14 +213,15 @@ kcTyClDecls1 decls ; mod <- getModule ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) - -- First check for cyclic classes - ; checkClassCycleErrs alg_decls - - -- Kind checking; see Note [Kind checking for type and class decls] + -- Kind checking; see Note [Kind checking for type and class decls] ; alg_kinds <- mapM getInitialKind alg_at_decls ; tcExtendKindEnv alg_kinds $ do { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls) + + -- Now check for cyclic classes + ; checkClassCycleErrs syn_decls alg_decls + ; setLclEnv tcl_env $ do { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls @@ -255,7 +253,8 @@ getInitialKind (L _ decl) mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind -- On GADT-style declarations we allow a kind signature -- data T :: *->* where { ... } - mk_res_kind _ = return liftedTypeKind + mk_res_kind (ClassDecl {}) = return constraintKind + mk_res_kind _ = return liftedTypeKind ---------------- @@ -507,25 +506,21 @@ tcTyClDecl1 _parent calc_isrec h98_syntax = consUseH98Syntax cons tcTyClDecl1 _parent calc_isrec - (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, + (ClassDecl {tcdLName = L _ class_tycon_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) = ASSERT( isNoParent _parent ) tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mapM (addLocM tc_fundep) fundeps - ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_tycon_name sigs meths ; clas <- fixM $ \ clas -> do - { let -- 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 - tycon_name = tyConName (classTyCon clas) - tc_isrec = calc_isrec tycon_name + { let tc_isrec = calc_isrec class_tycon_name ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats -- NB: 'ats' only contains "type family" and "data family" -- declarations as well as type family defaults ; buildClass False {- Must include unfoldings for selectors -} - class_name tvs' ctxt' fds' (concat atss') + class_tycon_name tvs' ctxt' fds' (concat atss') sig_stuff tc_isrec } ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) @@ -538,7 +533,7 @@ tcTyClDecl1 _parent calc_isrec ] class_ats = map ATyCon (classATs clas) - ; return (AClass clas : gen_dm_ids ++ class_ats ) + ; return (ATyCon (classTyCon clas) : gen_dm_ids ++ class_ats ) -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } @@ -790,16 +785,16 @@ Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. \begin{code} -checkClassCycleErrs :: [LTyClDecl Name] -> TcM () -checkClassCycleErrs tyclss +checkClassCycleErrs :: [LTyClDecl Name] -> [LTyClDecl Name] -> TcM () +checkClassCycleErrs syn_decls alg_decls | null cls_cycles = return () | otherwise - = do { mapM_ recClsErr cls_cycles - ; failM } -- Give up now, because later checkValidTyCl - -- will loop if the synonym is recursive + = do { mapM_ recClsErr cls_cycles + ; failM } -- Give up now, because later checkValidTyCl + -- will loop if the synonym is recursive where - cls_cycles = calcClassCycles tyclss + cls_cycles = calcClassCycles syn_decls alg_decls checkValidTyCl :: TyClDecl Name -> TcM () -- We do the validity check over declarations, rather than TyThings @@ -809,9 +804,11 @@ checkValidTyCl decl do { thing <- tcLookupLocatedGlobal (tcdLName decl) ; traceTc "Validity of" (ppr thing) ; case thing of - ATyCon tc -> checkValidTyCon tc - AClass cl -> do { checkValidClass cl - ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) } + ATyCon tc -> do + checkValidTyCon tc + case decl of + ClassDecl { tcdATs = ats } -> mapM_ (addLocM checkValidTyCl) ats + _ -> return () AnId _ -> return () -- Generic default methods are checked -- with their parent class _ -> panic "checkValidTyCl" @@ -835,6 +832,9 @@ checkValidTyCl decl checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc + | Just cl <- tyConClass_maybe tc + = checkValidClass cl + | isSynTyCon tc = case synTyConRhs tc of SynFamilyTyCon {} -> return () @@ -1038,7 +1038,8 @@ mkDefaultMethodIds :: [TyThing] -> [Id] -- See Note [Default method Ids and Template Haskell] mkDefaultMethodIds things = [ mkExportedLocalId dm_name (idType sel_id) - | AClass cls <- things + | ATyCon tc <- things + , Just cls <- [tyConClass_maybe tc] , (sel_id, DefMeth dm_name) <- classOpItems cls ] \end{code} @@ -1290,7 +1291,7 @@ recClsErr :: [Located (TyClDecl Name)] -> TcRn () recClsErr cls_decls = setSrcSpan (getLoc (head sorted_decls)) $ addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"), - nest 2 (vcat (map ppr_decl sorted_decls))]) + nest 2 (vcat (map ppr_decl sorted_decls))]) where sorted_decls = sortLocated cls_decls ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] }) diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 347e2b705e..02ac0b824b 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -11,7 +11,7 @@ files for imported data types. \begin{code} module TcTyDecls( calcRecFlags, - calcClassCycles, calcSynCycles + calcSynCycles, calcClassCycles ) where #include "HsVersions.h" @@ -22,7 +22,6 @@ import RnHsSyn import Type import HscTypes import TyCon -import Class import DataCon import Name import NameEnv @@ -92,8 +91,6 @@ synTyConsOfType ty 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 (PredTy (IParam _ ty)) = go ty - go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class go (ForAllTy _ ty) = go ty go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc @@ -102,27 +99,34 @@ synTyConsOfType ty ---------------------------------------- END NOTE ] \begin{code} -calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] -calcSynCycles decls - = stronglyConnCompFromEdgedVertices syn_edges +mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] +mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl), + mk_syn_edges (tcdSynRhs decl)) + | ldecl@(L _ decl) <- syn_decls ] where - syn_edges = [ (ldecl, unLoc (tcdLName decl), - mk_syn_edges (tcdSynRhs decl)) - | ldecl@(L _ decl) <- decls ] - mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ] - -calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]] -calcClassCycles decls - = [decls | CyclicSCC decls <- stronglyConnCompFromEdgedVertices cls_edges] +calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] +calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges + +-- We can't allow cycles via superclasses because it would result in the +-- type checker looping when it canonicalises a class constraint (superclasses +-- are added during canonicalisation) +-- +-- It is OK for superclasses to be type synonyms for other classes, so look for cycles +-- through there too. +calcClassCycles :: [LTyClDecl Name] -> [LTyClDecl Name] -> [[LTyClDecl Name]] +calcClassCycles syn_decls alg_decls + = [decls | CyclicSCC decls <- stronglyConnCompFromEdgedVertices (mkSynEdges syn_decls ++ cls_edges)] where cls_edges = [ (ldecl, unLoc (tcdLName decl), mk_cls_edges (unLoc (tcdCtxt decl))) - | ldecl@(L _ decl) <- decls, isClassDecl decl ] + | ldecl@(L _ decl) <- alg_decls, isClassDecl decl ] - mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ] + mk_cls_edges :: HsContext Name -> [Name] + mk_cls_edges ctxt = [ tc | tc <- nameSetToList (extractHsTyNames_s ctxt) + , not (isTyVarName tc) ] \end{code} @@ -322,7 +326,6 @@ new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables getTyCon :: TyThing -> Maybe TyCon getTyCon (ATyCon tc) = Just tc -getTyCon (AClass cl) = Just (classTyCon cl) getTyCon _ = Nothing findLoopBreakers :: [(TyCon, [TyCon])] -> [Name] @@ -353,9 +356,6 @@ tcTyConsOfType ty 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 (PredTy (IParam _ ty)) = go ty - go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys - go (PredTy (EqPred ty1 ty2)) = go ty1 `plusNameEnv` go ty2 go (ForAllTy _ ty) = go ty go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 134ab54d83..cc6eac0d36 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -43,7 +43,6 @@ module TcType ( tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, - tcSplitPredTy_maybe, tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars, tcGetTyVar_maybe, tcGetTyVar, tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe, @@ -59,6 +58,7 @@ module TcType ( isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, isSynFamilyTyConApp, isPredTy, isTyVarClassPred, + shallowPredTypePredTree, --------------------------------- -- Misc type manipulators @@ -70,8 +70,7 @@ module TcType ( --------------------------------- -- Predicate types mkMinimalBySCs, transSuperClasses, immSuperClasses, - getClassPredTys, getClassPredTys_maybe, - + -- * Finding type instances tcTyFamInsts, @@ -83,7 +82,7 @@ module TcType ( tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, - tidyTopType, tidyPred, + tidyTopType, tidyKind, tidyCo, tidyCos, @@ -108,21 +107,21 @@ module TcType ( -- Rexported from Kind Kind, typeKind, unliftedTypeKind, liftedTypeKind, argTypeKind, - openTypeKind, mkArrowKind, mkArrowKinds, + openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, kindVarRef, mkKindVar, -------------------------------- -- Rexported from Type - Type, Pred(..), PredType, ThetaType, + Type, PredType, ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys, - mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, + mkTyVarTy, mkTyVarTys, mkTyConTy, isClassPred, isEqPred, isIPPred, - mkClassPred, mkIPPred, mkDictTy, + mkClassPred, mkIPPred, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, mkEqPred, @@ -141,12 +140,12 @@ module TcType ( isUnboxedTupleType, -- Ditto isPrimitiveType, - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - tcTyVarsOfType, tcTyVarsOfTypes, tcTyVarsOfPred, + tyVarsOfType, tyVarsOfTypes, + tcTyVarsOfType, tcTyVarsOfTypes, pprKind, pprParendKind, pprType, pprParendType, pprTypeApp, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred + pprTheta, pprThetaArrowTy, pprClassPred ) where @@ -487,7 +486,6 @@ tidyType env@(_, subst) ty Just tv' -> expand tv' go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args - go (PredTy sty) = PredTy (tidyPred env sty) go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) @@ -507,12 +505,6 @@ tidyTypes :: TidyEnv -> [Type] -> [Type] tidyTypes env tys = map (tidyType env) tys --------------- -tidyPred :: TidyEnv -> PredType -> PredType -tidyPred env (IParam n ty) = IParam n (tidyType env ty) -tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) -tidyPred env (EqPred ty1 ty2) = EqPred (tidyType env ty1) (tidyType env ty2) - ---------------- -- | Grabs the free type variables, tidies them -- and then uses 'tidyType' to work over the type itself tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) @@ -589,15 +581,6 @@ tcTyFamInsts (TyConApp tc tys) tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty -tcTyFamInsts (PredTy pty) = tcPredFamInsts pty - --- | Finds type family instances occuring in a predicate type after expanding --- synonyms. -tcPredFamInsts :: PredType -> [(TyCon, [Type])] -tcPredFamInsts (ClassP _cla tys) = concat (map tcTyFamInsts tys) -tcPredFamInsts (IParam _ ty) = tcTyFamInsts ty -tcPredFamInsts (EqPred ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 - \end{code} %************************************************************************ @@ -644,15 +627,10 @@ exactTyVarsOfType ty go ty | Just ty' <- tcView ty = go ty' -- This is the key line go (TyVarTy tv) = unitVarSet tv go (TyConApp _ tys) = exactTyVarsOfTypes tys - go (PredTy ty) = go_pred ty 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_pred (IParam _ ty) = go ty - go_pred (ClassP _ tys) = exactTyVarsOfTypes tys - go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 - exactTyVarsOfTypes :: [Type] -> TyVarSet exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys \end{code} @@ -758,7 +736,7 @@ mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta +mkPhiTy theta ty = foldr mkFunTy ty theta \end{code} @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. @@ -770,7 +748,6 @@ isTauTy (TyVarTy _) = 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 (PredTy _) = True -- Don't look through source types isTauTy _ = False isTauTyCon :: TyCon -> Bool @@ -788,8 +765,6 @@ getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (FunTy _ _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) --- PredTy shouldn't happen \end{code} @@ -800,8 +775,7 @@ getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) %************************************************************************ These tcSplit functions are like their non-Tc analogues, but - a) they do not look through newtypes - b) they do not look through PredTys + *) they do not look through newtypes 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. @@ -824,7 +798,7 @@ tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' tcSplitPredFunTy_maybe (FunTy arg res) - | Just p <- tcSplitPredTy_maybe arg = Just (p, res) + | isPredTy arg = Just (arg, res) tcSplitPredFunTy_maybe _ = Nothing @@ -896,7 +870,7 @@ tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res) tcSplitFunTy_maybe _ = Nothing - -- Note the (not (isPredTy arg)) guard + -- Note the typeKind guard -- Consider (?x::Int) => Bool -- We don't want to treat this as a function type! -- A concrete example is test tc230: @@ -978,10 +952,7 @@ tcSplitDFunTy ty split_dfun_args n ty = (n, ty) tcSplitDFunHead :: Type -> (Class, [Type]) -tcSplitDFunHead tau - = case tcSplitPredTy_maybe tau of - Just (ClassP clas tys) -> (clas, tys) - _ -> pprPanic "tcSplitDFunHead" (ppr tau) +tcSplitDFunHead = getClassPredTys tcInstHeadTyNotSynonym :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head @@ -1025,35 +996,45 @@ tcInstHeadTyAppAllTyVars ty Deconstructors and tests on predicate types \begin{code} -tcSplitPredTy_maybe :: Type -> Maybe PredType --- Returns Just for predicates only -tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty' -tcSplitPredTy_maybe (PredTy p) = Just p -tcSplitPredTy_maybe _ = Nothing - -isPredTy :: Type -> Bool -isPredTy ty = isJust (tcSplitPredTy_maybe ty) +-- | Like 'predTypePredTree' but doesn't look through type synonyms. +-- Used to check that programs only use "simple" contexts without any +-- synonyms in them. +shallowPredTypePredTree :: PredType -> PredTree +shallowPredTypePredTree ev_ty + | TyConApp tc tys <- ev_ty + = case () of + () | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys + () | tc `hasKey` eqTyConKey + , let [ty1, ty2] = tys + -> EqPred ty1 ty2 + () | Just ip <- tyConIP_maybe tc + , let [ty] = tys + -> IPPred ip ty + () | isTupleTyCon tc + -> TuplePred (map shallowPredTypePredTree tys) + _ -> IrredPred ev_ty + | otherwise + = IrredPred ev_ty isTyVarClassPred :: PredType -> Bool -isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys -isTyVarClassPred _ = False - -getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) -getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) -getClassPredTys_maybe _ = Nothing - -getClassPredTys :: PredType -> (Class, [Type]) -getClassPredTys (ClassP clas tys) = (clas, tys) -getClassPredTys _ = panic "getClassPredTys" +isTyVarClassPred ty = case getClassPredTys_maybe ty of + Just (_, tys) -> all isTyVarTy tys + _ -> False evVarPred_maybe :: EvVar -> Maybe PredType -evVarPred_maybe = tcSplitPredTy_maybe . varType +evVarPred_maybe v = if isPredTy ty then Just ty else Nothing + where ty = varType v evVarPred :: EvVar -> PredType +#ifdef DEBUG evVarPred var = case evVarPred_maybe var of Just pred -> pred Nothing -> pprPanic "tcEvVarPred" (ppr var <+> ppr (varType var)) +#else +evVarPred = varType +#endif \end{code} Superclasses @@ -1064,20 +1045,26 @@ mkMinimalBySCs :: [PredType] -> [PredType] mkMinimalBySCs ptys = [ ploc | ploc <- ptys , ploc `not_in_preds` rec_scs ] where - rec_scs = concatMap trans_super_classes ptys + rec_scs = concatMap (trans_super_classes . predTypePredTree) ptys not_in_preds p ps = null (filter (eqPred p) ps) - trans_super_classes (ClassP cls tys) = transSuperClasses cls tys - trans_super_classes _other_pty = [] + trans_super_classes (ClassPred cls tys) = transSuperClasses cls tys + trans_super_classes (TuplePred ts) = concatMap trans_super_classes ts + trans_super_classes _other_pty = [] transSuperClasses :: Class -> [Type] -> [PredType] transSuperClasses cls tys = foldl (\pts p -> trans_sc p ++ pts) [] $ immSuperClasses cls tys where trans_sc :: PredType -> [PredType] - trans_sc this_pty@(ClassP cls tys) - = foldl (\pts p -> trans_sc p ++ pts) [this_pty] $ + trans_sc = trans_sc' . predTypePredTree + + trans_sc' :: PredTree -> [PredType] + trans_sc' ptree@(ClassPred cls tys) + = foldl (\pts p -> trans_sc p ++ pts) [predTreePredType ptree] $ immSuperClasses cls tys - trans_sc pty = [pty] + trans_sc' ptree@(TuplePred ts) + = foldl (\pts t -> trans_sc' t ++ pts) [predTreePredType ptree] ts + trans_sc' ptree = [predTreePredType ptree] immSuperClasses :: Class -> [Type] -> [PredType] immSuperClasses cls tys @@ -1168,7 +1155,6 @@ tcTyVarsOfType :: Type -> TcTyVarSet tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys -tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty 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 @@ -1176,28 +1162,23 @@ tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar tcTyVarsOfTypes :: [Type] -> TyVarSet tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys - -tcTyVarsOfPred :: PredType -> TyVarSet -tcTyVarsOfPred (IParam _ ty) = tcTyVarsOfType ty -tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys -tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2 \end{code} Find the free tycons and classes of a type. This is used in the front end of the compiler. \begin{code} +orphNamesOfTyCon :: TyCon -> NameSet +orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSets` case tyConClass_maybe tycon of + Nothing -> emptyNameSet + Just cls -> unitNameSet (getName cls) + orphNamesOfType :: Type -> NameSet orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty' -- Look through type synonyms (Trac #4912) orphNamesOfType (TyVarTy _) = emptyNameSet -orphNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) +orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSets` orphNamesOfTypes tys -orphNamesOfType (PredTy (IParam _ ty)) = orphNamesOfType ty -orphNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) - `unionNameSets` orphNamesOfTypes tys -orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1 - `unionNameSets` orphNamesOfType ty2 orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 572ad4437c..b48e78b4e3 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -16,11 +16,15 @@ module TcUnify ( -------------------------------- -- Holes - tcInfer, - matchExpectedListTy, matchExpectedPArrTy, - matchExpectedTyConApp, matchExpectedAppTy, - matchExpectedFunTys, matchExpectedFunKind, - wrapFunResCoercion, failWithMisMatch + tcInfer, + matchExpectedListTy, + matchExpectedPArrTy, + matchExpectedTyConApp, + matchExpectedAppTy, + matchExpectedFunTys, + matchExpectedFunKind, + wrapFunResCoercion, + failWithMisMatch ) where #include "HsVersions.h" @@ -36,6 +40,7 @@ import TcType import Type import Coercion import Inst +import Kind ( isConstraintKind, isConstraintKindCon ) import TyCon import TysWiredIn import Var @@ -102,7 +107,7 @@ expected type, becuase it expects that to have been done already matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] -> Arity -> TcRhoType - -> TcM (Coercion, [TcSigmaType], TcRhoType) + -> TcM (LCoercion, [TcSigmaType], TcRhoType) -- If matchExpectFunTys n ty = (co, [t1,..,tn], ty_r) -- then co : ty ~ (t1 -> ... -> tn -> ty_r) @@ -127,9 +132,9 @@ matchExpectedFunTys herald arity orig_ty | Just ty' <- tcView ty = go n_req ty' go n_req (FunTy arg_ty res_ty) - | not (isPredTy arg_ty) - = do { (coi, tys, ty_r) <- go (n_req-1) res_ty - ; return (mkFunCo (mkReflCo arg_ty) coi, arg_ty:tys, ty_r) } + | not (isPredTy arg_ty) + = do { (co, tys, ty_r) <- go (n_req-1) res_ty + ; return (mkFunCo (mkReflCo arg_ty) co, arg_ty:tys, ty_r) } go _ (TyConApp tc _) -- A common case | not (isSynFamilyTyCon tc) @@ -151,8 +156,8 @@ matchExpectedFunTys herald arity orig_ty = addErrCtxtM mk_ctxt $ do { arg_tys <- newFlexiTyVarTys n_req argTypeKind ; res_ty <- newFlexiTyVarTy openTypeKind - ; coi <- unifyType fun_ty (mkFunTys arg_tys res_ty) - ; return (coi, arg_tys, res_ty) } + ; co <- unifyType fun_ty (mkFunTys arg_tys res_ty) + ; return (co, arg_tys, res_ty) } ------------ mk_ctxt :: TidyEnv -> TcM (TidyEnv, Message) @@ -172,23 +177,23 @@ matchExpectedFunTys herald arity orig_ty \begin{code} ---------------------- -matchExpectedListTy :: TcRhoType -> TcM (Coercion, TcRhoType) +matchExpectedListTy :: TcRhoType -> TcM (LCoercion, TcRhoType) -- Special case for lists matchExpectedListTy exp_ty - = do { (coi, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty - ; return (coi, elt_ty) } + = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty + ; return (co, elt_ty) } ---------------------- -matchExpectedPArrTy :: TcRhoType -> TcM (Coercion, TcRhoType) +matchExpectedPArrTy :: TcRhoType -> TcM (LCoercion, TcRhoType) -- Special case for parrs matchExpectedPArrTy exp_ty - = do { (coi, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty - ; return (coi, elt_ty) } + = do { (co, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty + ; return (co, elt_ty) } ---------------------- matchExpectedTyConApp :: TyCon -- T :: k1 -> ... -> kn -> * -> TcRhoType -- orig_ty - -> TcM (Coercion, -- T a b c ~ orig_ty + -> TcM (LCoercion, -- T a b c ~ orig_ty [TcSigmaType]) -- Element types, a b c -- It's used for wired-in tycons, so we call checkWiredInTyCon @@ -199,7 +204,7 @@ matchExpectedTyConApp tc orig_ty = do { checkWiredInTyCon tc ; go (tyConArity tc) orig_ty [] } where - go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (Coercion, [TcSigmaType]) + go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (LCoercion, [TcSigmaType]) -- If go n ty tys = (co, [t1..tn] ++ tys) -- then co : T t1..tn ~ ty @@ -220,22 +225,22 @@ matchExpectedTyConApp tc orig_ty go n_req (AppTy fun arg) tys | n_req > 0 - = do { (coi, args) <- go (n_req - 1) fun (arg : tys) - ; return (mkAppCo coi (mkReflCo arg), args) } + = do { (co, args) <- go (n_req - 1) fun (arg : tys) + ; return (mkAppCo co (mkReflCo arg), args) } go n_req ty tys = defer n_req ty tys ---------- defer n_req ty tys = do { tau_tys <- mapM newFlexiTyVarTy arg_kinds - ; coi <- unifyType (mkTyConApp tc tau_tys) ty - ; return (coi, tau_tys ++ tys) } + ; co <- unifyType (mkTyConApp tc tau_tys) ty + ; return (co, tau_tys ++ tys) } where (arg_kinds, _) = splitKindFunTysN n_req (tyConKind tc) ---------------------- matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (Coercion, -- m a ~ orig_ty + -> TcM (LCoercion, -- m a ~ 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 *. @@ -261,8 +266,8 @@ matchExpectedAppTy orig_ty -- Defer splitting by generating an equality constraint defer = do { ty1 <- newFlexiTyVarTy kind1 ; ty2 <- newFlexiTyVarTy kind2 - ; coi <- unifyType (mkAppTy ty1 ty2) orig_ty - ; return (coi, (ty1, ty2)) } + ; co <- unifyType (mkAppTy ty1 ty2) orig_ty + ; return (co, (ty1, ty2)) } orig_kind = typeKind orig_ty kind1 = mkArrowKind liftedTypeKind (defaultKind orig_kind) @@ -304,15 +309,15 @@ tcSubType origin ctxt ty_actual ty_expected = do { (sk_wrap, inst_wrap) <- tcGen ctxt ty_expected $ \ _ sk_rho -> do { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual - ; coi <- unifyType in_rho sk_rho - ; return (coToHsWrapper coi <.> in_wrap) } + ; cow <- unifyType in_rho sk_rho + ; return (coToHsWrapper cow <.> in_wrap) } ; return (sk_wrap <.> inst_wrap) } | otherwise -- Urgh! It seems deeply weird to have equality -- when actual is not a polytype, and it makes a big -- difference e.g. tcfail104 - = do { coi <- unifyType ty_actual ty_expected - ; return (coToHsWrapper coi) } + = do { cow <- unifyType ty_actual ty_expected + ; return (coToHsWrapper cow) } tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind @@ -322,9 +327,9 @@ tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind ----------------- tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId) tcWrapResult expr actual_ty res_ty - = do { coi <- unifyType actual_ty res_ty + = do { cow <- unifyType actual_ty res_ty -- Both types are deeply skolemised - ; return (mkHsWrapCo coi expr) } + ; return (mkHsWrapCo cow expr) } ----------------------------------- wrapFunResCoercion @@ -449,19 +454,18 @@ The exported functions are all defined as versions of some non-exported generic functions. \begin{code} ---------------- -unifyType :: TcTauType -> TcTauType -> TcM Coercion +unifyType :: TcTauType -> TcTauType -> TcM LCoercion -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 unifyType ty1 ty2 = uType [] ty1 ty2 --------------- -unifyPred :: PredType -> PredType -> TcM Coercion +unifyPred :: PredType -> PredType -> TcM LCoercion -- Actual and expected types -unifyPred p1 p2 = uPred [UnifyOrigin (mkPredTy p1) (mkPredTy p2)] p1 p2 +unifyPred = unifyType --------------- -unifyTheta :: TcThetaType -> TcThetaType -> TcM [Coercion] +unifyTheta :: TcThetaType -> TcThetaType -> TcM [LCoercion] -- Actual and expected types unifyTheta theta1 theta2 = do { checkTc (equalLength theta1 theta2) @@ -512,23 +516,23 @@ uType, uType_np, uType_defer :: [EqOrigin] -> TcType -- ty1 is the *actual* type -> TcType -- ty2 is the *expected* type - -> TcM Coercion + -> TcM LCoercion -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] uType_defer (item : origin) ty1 ty2 = wrapEqCtxt origin $ - do { co_var <- newCoVar ty1 ty2 + do { eqv <- newEq ty1 ty2 ; loc <- getCtLoc (TypeEqOrigin item) - ; emitFlat (mkEvVarX co_var loc) + ; emitFlat (mkEvVarX eqv loc) -- Error trace only ; ctxt <- getErrCtxt ; doc <- mkErrInfo emptyTidyEnv ctxt - ; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin, doc]) + ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, ppr ty2, ppr origin, doc]) - ; return $ mkCoVarCo co_var } + ; return (mkEqVarLCo eqv) } uType_defer [] _ _ = panic "uType_defer" @@ -543,16 +547,16 @@ uType_np origin orig_ty1 orig_ty2 = do { traceTc "u_tys " $ vcat [ sep [ ppr orig_ty1, text "~", ppr orig_ty2] , ppr origin] - ; coi <- go orig_ty1 orig_ty2 - ; if isReflCo coi + ; co <- go orig_ty1 orig_ty2 + ; if isReflCo co then traceTc "u_tys yields no coercion" empty - else traceTc "u_tys yields coercion:" (ppr coi) - ; return coi } + else traceTc "u_tys yields coercion:" (ppr co) + ; return co } where bale_out :: [EqOrigin] -> TcM a bale_out origin = failWithMisMatch origin - go :: TcType -> TcType -> TcM Coercion + go :: TcType -> TcType -> TcM LCoercion -- The arguments to 'go' are always semantically identical -- to orig_ty{1,2} except for looking through type synonyms @@ -578,14 +582,11 @@ uType_np origin orig_ty1 orig_ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - -- Predicates - go (PredTy p1) (PredTy p2) = uPred origin p1 p2 - -- Functions (or predicate functions) just check the two parts go (FunTy fun1 arg1) (FunTy fun2 arg2) - = do { coi_l <- uType origin fun1 fun2 - ; coi_r <- uType origin arg1 arg2 - ; return $ mkFunCo coi_l coi_r } + = do { co_l <- uType origin fun1 fun2 + ; co_r <- uType origin arg1 arg2 + ; return $ mkFunCo co_l co_r } -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.) @@ -596,21 +597,21 @@ uType_np origin orig_ty1 orig_ty2 go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2 -- See Note [TyCon app] - = do { cois <- uList origin uType tys1 tys2 - ; return $ mkTyConAppCo tc1 cois } + = do { cos <- uList origin uType tys1 tys2 + ; return $ mkTyConAppCo tc1 cos } -- See Note [Care with type applications] go (AppTy s1 t1) ty2 | Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = do { coi_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] - ; coi_t <- uType origin t1 t2 - ; return $ mkAppCo coi_s coi_t } + = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] + ; co_t <- uType origin t1 t2 + ; return $ mkAppCo co_s co_t } go ty1 (AppTy s2 t2) | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - = do { coi_s <- uType_np origin s1 s2 - ; coi_t <- uType origin t1 t2 - ; return $ mkAppCo coi_s coi_t } + = do { co_s <- uType_np origin s1 s2 + ; co_t <- uType origin t1 t2 + ; return $ mkAppCo co_s co_t } go ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 @@ -619,7 +620,7 @@ uType_np origin orig_ty1 orig_ty2 -- Anything else fails go _ _ = bale_out origin -unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM Coercion +unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM LCoercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 @@ -633,7 +634,7 @@ unifySigmaTy origin ty1 ty2 ; ((coi, _untch), lie) <- captureConstraints $ captureUntouchables $ - uType origin phi1 phi2 + uType origin phi1 phi2 -- Check for escape; e.g. (forall a. a->b) ~ (forall a. a->a) -- VERY UNSATISFACTORY; the constraint might be fine, but -- we fail eagerly because we don't have any place to put @@ -646,25 +647,6 @@ unifySigmaTy origin ty1 ty2 ; emitConstraints lie ; return (foldr mkForAllCo coi skol_tvs) } ----------- -uPred :: [EqOrigin] -> PredType -> PredType -> TcM Coercion -uPred origin (IParam n1 t1) (IParam n2 t2) - | n1 == n2 - = do { coi <- uType origin t1 t2 - ; return $ mkPredCo $ IParam n1 coi } -uPred origin (ClassP c1 tys1) (ClassP c2 tys2) - | c1 == c2 - = do { cois <- uList origin uType tys1 tys2 - -- Guaranteed equal lengths because the kinds check - ; return $ mkPredCo $ ClassP c1 cois } - -uPred origin (EqPred ty1a ty1b) (EqPred ty2a ty2b) - = do { coa <- uType origin ty1a ty2a - ; cob <- uType origin ty1b ty2b - ; return $ mkPredCo $ EqPred coa cob } - -uPred origin _ _ = failWithMisMatch origin - --------------- uList :: [EqOrigin] -> ([EqOrigin] -> a -> a -> TcM b) @@ -805,7 +787,7 @@ of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM Coercion +uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM LCoercion uVar origin swapped tv1 ty2 = do { traceTc "uVar" (vcat [ ppr origin , ppr swapped @@ -823,7 +805,7 @@ uUnfilledVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTauType -- Type 2 - -> TcM Coercion + -> TcM LCoercion -- "Unfilled" means that the variable is definitely not a filled-in meta tyvar -- It might be a skolem, or untouchable, or meta @@ -863,7 +845,7 @@ uUnfilledVars :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTyVar -> TcTyVarDetails -- Tyvar 2 - -> TcM Coercion + -> TcM LCoercion -- Invarant: The type variables are distinct, -- Neither is filled in yet @@ -934,7 +916,6 @@ checkTauTvUpdate tv ty = Just (TyConApp tc tys') | isSynTyCon tc, Just ty_expanded <- tcView this_ty = ok ty_expanded -- See Note [Type synonyms and the occur check] - ok (PredTy sty) | Just sty' <- ok_pred sty = Just (PredTy sty') ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res = Just (FunTy arg' res') ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg @@ -942,16 +923,6 @@ checkTauTvUpdate tv ty ok (ForAllTy tv1 ty1) | Just ty1' <- ok ty1 = Just (ForAllTy tv1 ty1') -- Fall-through ok _ty = Nothing - - ok_pred (IParam nm ty) | Just ty' <- ok ty = Just (IParam nm ty') - ok_pred (ClassP cl tys) - | Just tys' <- allMaybes (map ok tys) - = Just (ClassP cl tys') - ok_pred (EqPred ty1 ty2) - | Just ty1' <- ok ty1, Just ty2' <- ok ty2 - = Just (EqPred ty1' ty2') - -- Fall-through - ok_pred _pty = Nothing \end{code} Note [Avoid deferring] @@ -1042,7 +1013,7 @@ lookupTcTyVar tyvar details = ASSERT2( isTcTyVar tyvar, ppr tyvar ) tcTyVarDetails tyvar -updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM Coercion +updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM LCoercion updateMeta tv1 ref1 ty2 = do { writeMetaTyVarRef tv1 ref1 ty2 ; return (mkReflCo ty2) } @@ -1139,6 +1110,14 @@ addSubCtxt orig actual_res_ty expected_res_ty thing_inside 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. + \begin{code} matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing @@ -1162,7 +1141,13 @@ unifyKind :: TcKind -- Expected -> TcM () unifyKind (TyConApp kc1 []) (TyConApp kc2 []) - | isSubKindCon kc2 kc1 = return () + | isSubKindCon kc2 kc1 + , not (isConstraintKindCon kc2) || isConstraintKindCon kc1 = return () + -- For the purposes of the front end ONLY, only allow + -- the Constraint kind to unify with itself. + -- + -- This prevents the user from writing constraints types + -- on the left or right of an arrow. unifyKind (FunTy a1 r1) (FunTy a2 r2) = do { unifyKind a2 a1; unifyKind r1 r2 } @@ -1228,6 +1213,7 @@ kindSimpleKind orig_swapped orig_kind go _ k | isLiftedTypeKind k = return liftedTypeKind | isUnliftedTypeKind k = return unliftedTypeKind + | isConstraintKind k = return constraintKind go _ k@(TyVarTy _) = return k -- KindVars are always simple go _ _ = failWithTc (ptext (sLit "Unexpected kind unification failure:") <+> ppr orig_swapped <+> ppr orig_kind) @@ -1236,16 +1222,16 @@ kindSimpleKind orig_swapped orig_kind -- T v = MkT v v must be a type -- T v w = MkT (v -> w) v must not be an umboxed tuple -unifyKindMisMatch :: TcKind -> TcKind -> TcM () +unifyKindMisMatch :: TcKind -- Expected + -> TcKind -- Actual + -> TcM () unifyKindMisMatch ty1 ty2 = do ty1' <- zonkTcKind ty1 ty2' <- zonkTcKind ty2 - let - msg = hang (ptext (sLit "Couldn't match kind")) - 2 (sep [quotes (ppr ty1'), - ptext (sLit "against"), - quotes (ppr ty2')]) - failWithTc msg + failWithTc $ hang (ptext (sLit "Couldn't match kind")) + 2 (sep [quotes (ppr ty1'), + ptext (sLit "against"), + quotes (ppr ty2')]) ---------------- kindOccurCheckErr :: Var -> Type -> SDoc diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index e7ad4181fc..631b6fecc6 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -2,10 +2,10 @@ module TcUnify where import TcType ( TcTauType ) import TcRnTypes( TcM ) -import Coercion (Coercion) +import Coercion (LCoercion) -- This boot file exists only to tie the knot between --- TcUnify and TcSimplify +-- TcUnify and Inst -unifyType :: TcTauType -> TcTauType -> TcM Coercion +unifyType :: TcTauType -> TcTauType -> TcM LCoercion \end{code} diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 6489a2fdac..a10b19efe7 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -22,7 +22,7 @@ module Class ( #include "Typeable.h" #include "HsVersions.h" -import {-# SOURCE #-} TyCon ( TyCon ) +import {-# SOURCE #-} TyCon ( TyCon, tyConName, tyConUnique ) import {-# SOURCE #-} TypeRep ( PredType ) import Var @@ -49,14 +49,14 @@ A @Class@ corresponds to a Greek kappa in the static semantics: data Class = Class { classKey :: Unique, -- Key for fast comparison - className :: Name, + className :: Name, -- Just the cached name of the TyCon classTyVars :: [TyVar], -- The class type variables 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 the dictionary - -- superclasses, but not for the equality superclasses + -- We need value-level selectors for both the dictionary + -- superclasses and the equality superclasses classSCTheta :: [PredType], -- Immediate superclasses, classSCSels :: [Id], -- Selector functions to extract the -- superclasses from a @@ -98,7 +98,7 @@ defMethSpecOfDefMeth meth The @mkClass@ function fills in the indirect superclasses. \begin{code} -mkClass :: Name -> [TyVar] +mkClass :: [TyVar] -> [([TyVar], [TyVar])] -> [PredType] -> [Id] -> [TyCon] @@ -106,10 +106,10 @@ mkClass :: Name -> [TyVar] -> TyCon -> Class -mkClass name tyvars fds super_classes superdict_sels ats +mkClass tyvars fds super_classes superdict_sels ats op_stuff tycon - = Class { classKey = getUnique name, - className = name, + = Class { classKey = tyConUnique tycon, + className = tyConName tycon, classTyVars = tyvars, classFunDeps = fds, classSCTheta = super_classes, @@ -221,5 +221,4 @@ instance Data.Data Class where toConstr _ = abstractConstr "Class" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Class" -\end{code} - +\end{code}
\ No newline at end of file diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index d9f48a3abb..eaa5c8e853 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -10,6 +10,7 @@ module Coercion ( -- * Main data type Coercion(..), Var, CoVar, + LCoercion, -- ** Deconstructing Kinds kindFunResult, kindAppResult, synTyConResKind, @@ -24,20 +25,19 @@ module Coercion ( isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind, isSubKindCon, - mkCoType, coVarKind, coVarKind_maybe, + coVarKind, coVarKind_maybe, coercionType, coercionKind, coercionKinds, isReflCo, + mkCoercionType, -- ** Constructing coercions - mkReflCo, mkCoVarCo, + mkReflCo, mkCoVarCo, mkEqVarLCo, mkAxInstCo, mkPiCo, mkPiCos, mkSymCo, mkTransCo, mkNthCo, mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, mkForAllCo, mkUnsafeCo, - mkNewTypeCo, mkFamInstCo, - mkPredCo, + mkNewTypeCo, mkFamInstCo, -- ** Decomposition - splitCoPredTy_maybe, splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo, getCoVar_maybe, @@ -74,8 +74,7 @@ module Coercion ( pprCo, pprParendCo, pprCoAxiom, -- * Other - applyCo, coVarPred - + applyCo ) where #include "HsVersions.h" @@ -85,7 +84,6 @@ import TypeRep import qualified Type import Type hiding( substTy, substTyVarBndr, extendTvSubst ) import Kind -import Class ( classTyCon ) import TyCon import Var import VarEnv @@ -98,8 +96,7 @@ import BasicTypes import Outputable import Unique import Pair -import TysPrim ( eqPredPrimTyCon ) -import PrelNames ( funTyConKey, eqPredPrimTyConKey ) +import PrelNames ( funTyConKey, eqPrimTyConKey ) import Control.Applicative import Data.Traversable (traverse, sequenceA) import Control.Arrow (second) @@ -157,6 +154,20 @@ data Coercion deriving (Data.Data, Data.Typeable) \end{code} +\begin{code} +-- | LCoercions are a hack used by the typechecker. Normally, 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 LCoercion is simply a Coercion whose free variables have that boxed type. 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 LCoercions. However, +-- mkCoVarCo will not work! The equivalent is mkEqVarLCo. +type LCoercion = Coercion +\end{code} + Note [Refl invariant] ~~~~~~~~~~~~~~~~~~~~~ Coercions have the following invariant @@ -279,9 +290,8 @@ isCoVar :: Var -> Bool isCoVar v = isCoVarType (varType v) isCoVarType :: Type -> Bool --- Don't rely on a PredTy; look at the representation type isCoVarType ty - | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPredPrimTyConKey + | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey | otherwise = False \end{code} @@ -459,11 +469,6 @@ splitForAllCo_maybe _ = Nothing ------------------------------------------------------- -- and some coercion kind stuff -coVarPred :: CoVar -> PredType -coVarPred cv = case coVarKind_maybe cv of - Just (ty1, ty2) -> mkEqPred (ty1, ty2) - Nothing -> pprPanic "coVarPred" (ppr cv $$ ppr (varType cv)) - coVarKind :: CoVar -> (Type,Type) -- c :: t1 ~ t2 coVarKind cv = case coVarKind_maybe cv of @@ -472,22 +477,13 @@ coVarKind cv = case coVarKind_maybe cv of coVarKind_maybe :: CoVar -> Maybe (Type,Type) coVarKind_maybe cv = case splitTyConApp_maybe (varType cv) of - Just (tc, [ty1, ty2]) | tc `hasKey` eqPredPrimTyConKey -> Just (ty1, ty2) + Just (tc, [ty1, ty2]) | tc `hasKey` eqPrimTyConKey -> Just (ty1, ty2) _ -> Nothing -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' -mkCoType :: Type -> Type -> Type -mkCoType ty1 ty2 = PredTy (EqPred ty1 ty2) - -splitCoPredTy_maybe :: Type -> Maybe (Type, Type, Type) -splitCoPredTy_maybe ty - | Just (cv,r) <- splitForAllTy_maybe ty - , isCoVar cv - , Just (s,t) <- coVarKind_maybe cv - = Just (s,t,r) - | otherwise - = Nothing +mkCoercionType :: Type -> Type -> Type +mkCoercionType = curry mkPrimEqType isReflCo :: Coercion -> Bool isReflCo (Refl {}) = True @@ -512,6 +508,15 @@ mkCoVarCo cv where (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv +mkEqVarLCo :: EqVar -> LCoercion +mkEqVarLCo ipv + | ty1 `eqType` ty2 = Refl ty1 + | otherwise = CoVarCo ipv + where + (ty1, ty2) = case getEqPredTys_maybe (varType ipv) of + Nothing -> pprPanic "mkCoVarLCo" (ppr ipv) + Just tys -> tys + mkReflCo :: Type -> Coercion mkReflCo = Refl @@ -563,12 +568,6 @@ mkForAllCo :: Var -> Coercion -> Coercion mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty) mkForAllCo tv co = ASSERT ( isTyVar tv ) ForAllCo tv co -mkPredCo :: Pred Coercion -> Coercion --- See Note [Predicate coercions] -mkPredCo (EqPred co1 co2) = mkTyConAppCo eqPredPrimTyCon [co1,co2] -mkPredCo (ClassP cls cos) = mkTyConAppCo (classTyCon cls) cos -mkPredCo (IParam _ co) = co - ------------------------------- -- | Create a symmetric version of the given 'Coercion' that asserts @@ -917,7 +916,6 @@ ty_co_subst subst ty go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) where (subst', v') = liftCoSubstTyVarBndr subst v - go (PredTy p) = mkPredCo (go <$> p) liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv @@ -1044,7 +1042,7 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos \begin{code} coercionType :: Coercion -> Type coercionType co = case coercionKind co of - Pair ty1 ty2 -> mkCoType ty1 ty2 + Pair ty1 ty2 -> mkCoercionType ty1 ty2 ------------------ -- | If it is the case that @@ -1085,4 +1083,4 @@ applyCo :: Type -> Coercion -> Type applyCo ty co | Just ty' <- coreView ty = applyCo ty' co applyCo (FunTy _ ty) _ = ty applyCo _ _ = panic "applyCo" -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 41ddffe609..da6f26f449 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -520,19 +520,4 @@ normaliseType env (ForAllTy tyvar ty1) in (mkForAllCo tyvar coi, ForAllTy tyvar nty1) normaliseType _ ty@(TyVarTy _) = (Refl ty,ty) -normaliseType env (PredTy predty) - = normalisePred env predty - ---------------- -normalisePred :: FamInstEnvs -> PredType -> (Coercion,Type) -normalisePred env (ClassP cls tys) - = let (cos,tys') = mapAndUnzip (normaliseType env) tys - in (mkPredCo $ ClassP cls cos, PredTy $ ClassP cls tys') -normalisePred env (IParam ipn ty) - = let (co,ty') = normaliseType env ty - in (mkPredCo $ (IParam ipn co), PredTy $ IParam ipn ty') -normalisePred env (EqPred ty1 ty2) - = let (co1,ty1') = normaliseType env ty1 - (co2,ty2') = normaliseType env ty2 - in (mkPredCo $ (EqPred co1 co2), PredTy $ EqPred ty1' ty2') \end{code} diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs index cb29c6b8a2..792ca5f82a 100644 --- a/compiler/types/FunDeps.lhs +++ b/compiler/types/FunDeps.lhs @@ -21,7 +21,7 @@ module FunDeps ( import Name import Var import Class -import TcType +import Type import Unify import InstEnv import VarSet @@ -126,11 +126,18 @@ oclose preds fixed_tvs -- In our example, tv_fds will be [ ({x,y}, {z}), ({x,p},{q}) ] -- Meaning "knowing x,y fixes z, knowing x,p fixes q" tv_fds = [ (tyVarsOfTypes xs, tyVarsOfTypes ys) - | ClassP cls tys <- preds, -- Ignore implicit params + | (cls, tys) <- concatMap classesOfPredTy preds, -- Ignore implicit params let (cls_tvs, cls_fds) = classTvsFds cls, fd <- cls_fds, let (xs,ys) = instFD fd cls_tvs tys ] + + classesOfPredTy :: PredType -> [(Class, [Type])] + classesOfPredTy = go . predTypePredTree + where + go (ClassPred cls tys) = [(cls, tys)] + go (TuplePred ts) = concatMap go ts + go _ = [] \end{code} @@ -264,8 +271,10 @@ improveFromAnother :: Pred_Loc -- Template item (usually given, or inert) -> [Equation] -- Post: FDEqs always oriented from the other to the workitem -- Equations have empty quantified variables -improveFromAnother pred1@(ClassP cls1 tys1, _) pred2@(ClassP cls2 tys2, _) - | tys1 `lengthAtLeast` 2 && cls1 == cls2 +improveFromAnother pred1@(ty1, _) pred2@(ty2, _) + | Just (cls1, tys1) <- getClassPredTys_maybe ty1 + , Just (cls2, tys2) <- getClassPredTys_maybe ty2 + , tys1 `lengthAtLeast` 2 && cls1 == cls2 = [ FDEqn { fd_qtvs = emptyVarSet, fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2 } | let (cls_tvs, cls_fds) = classTvsFds cls1 , fd <- cls_fds @@ -294,8 +303,12 @@ improveFromInstEnv :: (InstEnv,InstEnv) improveFromInstEnv _inst_env (pred,_loc) | not (isClassPred pred) = panic "improveFromInstEnv: not a class predicate" -improveFromInstEnv inst_env pred@(ClassP cls tys, _) - | tys `lengthAtLeast` 2 +improveFromInstEnv inst_env pred@(ty, _) + | Just (cls, tys) <- getClassPredTys_maybe ty + , tys `lengthAtLeast` 2 + , let (cls_tvs, cls_fds) = classTvsFds cls + instances = classInstances inst_env cls + rough_tcs = roughMatchTcs tys = [ FDEqn { fd_qtvs = qtvs, fd_eqs = eqs, fd_pred1 = p_inst, fd_pred2=pred } | fd <- cls_fds -- Iterate through the fundeps first, -- because there often are none! @@ -314,10 +327,6 @@ improveFromInstEnv inst_env pred@(ClassP cls tys, _) , (qtvs, eqs) <- checkClsFD qtvs fd cls_tvs tys_inst tys -- NB: orientation , not (null eqs) ] - where - (cls_tvs, cls_fds) = classTvsFds cls - instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys improveFromInstEnv _ _ = [] diff --git a/compiler/types/IParam.lhs b/compiler/types/IParam.lhs new file mode 100644 index 0000000000..67d46c3a82 --- /dev/null +++ b/compiler/types/IParam.lhs @@ -0,0 +1,41 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% + +\begin{code} +module IParam ( + ipFastString, ipTyConName, ipTyCon, ipCoAxiom + ) where + +#include "HsVersions.h" + +import Name +import TyCon (CoAxiom, TyCon, newTyConCo_maybe) +import Type + +import BasicTypes (IPName(..), ipNameName) +import FastString +import Outputable +\end{code} + +\begin{code} +ipFastString :: IPName Name -> FastString +ipFastString = occNameFS . nameOccName . ipTyConName + +ipTyConName :: IPName Name -> Name +ipTyConName = ipNameName + +ipTyCon :: IPName Name -> TyCon +ipTyCon ip = case wiredInNameTyThing_maybe (ipTyConName ip) of + Just (ATyCon tc) -> tc + _ -> pprPanic "ipTyCon" (ppr ip) + +ipCoAxiom :: IPName Name -> CoAxiom +ipCoAxiom ip = case newTyConCo_maybe (ipTyCon ip) of + Just ax -> ax + _ -> pprPanic "ipCoAxiom" (ppr ip) + +-- The IParam DataCon never gets any code generated for it, so it's +-- a bit dangerous to actually make use of it, hence no ipDataCon function +\end{code} diff --git a/compiler/types/IParam.lhs-boot b/compiler/types/IParam.lhs-boot new file mode 100644 index 0000000000..34acf1a5da --- /dev/null +++ b/compiler/types/IParam.lhs-boot @@ -0,0 +1,10 @@ +\begin{code} +module IParam where + +import Name +import BasicTypes +import {-# SOURCE #-} TyCon (TyCon) + +ipTyConName :: IPName Name -> Name +ipTyCon :: IPName Name -> TyCon +\end{code}
\ No newline at end of file diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 777ed43118..2bdabc639a 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -9,12 +9,12 @@ module Kind ( -- Kinds liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, + argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, -- Kind constructors... liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, -- Super Kinds tySuperKind, tySuperKindTyCon, @@ -27,9 +27,9 @@ module Kind ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, + isUbxTupleKind, isArgTypeKind, isConstraintKind, isKind, isTySuperKind, isSuperKind, - isLiftedTypeKindCon, + isLiftedTypeKindCon, isConstraintKindCon, isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, isSubKindCon, @@ -38,10 +38,11 @@ module Kind ( #include "HsVersions.h" +import {-# SOURCE #-} Type (typeKind) + import TypeRep import TysPrim import TyCon -import Var import PrelNames import Outputable \end{code} @@ -66,42 +67,6 @@ isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey %************************************************************************ %* * - The kind of a type -%* * -%************************************************************************ - -\begin{code} -typeKind :: Type -> Kind -typeKind _ty@(TyConApp tc tys) - = ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty ) - -- Assertion checks for unsaturated application of (~) - -- See Note [The (~) TyCon] in TysPrim - kindAppResult (tyConKind tc) tys - -typeKind (PredTy pred) = predKind pred -typeKind (AppTy fun _) = kindFunResult (typeKind fun) -typeKind (ForAllTy _ ty) = typeKind ty -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (FunTy _arg res) - -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), - -- not unliftedTypKind (#) - -- 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. * -> (* -> *)) - | isTySuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind - where - k = typeKind res - ------------------- -predKind :: PredType -> Kind -predKind (EqPred {}) = unliftedTypeKind -- Coercions are unlifted -predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are -predKind (IParam {}) = liftedTypeKind -- always represented by lifted types -\end{code} - -%************************************************************************ -%* * Functions over Kinds %* * %************************************************************************ @@ -141,9 +106,9 @@ synTyConResKind :: TyCon -> Kind synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon) -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool +isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, isConstraintKind :: Kind -> Bool isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, - isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool + isUnliftedTypeKindCon, isSubArgTypeKindCon, isConstraintKindCon :: TyCon -> Bool isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey @@ -165,6 +130,11 @@ isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc isUnliftedTypeKind _ = False +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey + +isConstraintKind (TyConApp tc _) = isConstraintKindCon tc +isConstraintKind _ = False + isSubOpenTypeKind :: Kind -> Bool -- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow) isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) @@ -180,6 +150,7 @@ isSubArgTypeKindCon kc | isUnliftedTypeKindCon kc = True | isLiftedTypeKindCon kc = True | isArgTypeKindCon kc = True + | isConstraintKindCon kc = True | otherwise = False isSubArgTypeKind :: Kind -> Bool @@ -208,6 +179,7 @@ isSubKindCon kc1 kc2 | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True + | isConstraintKindCon kc1 && isConstraintKindCon kc2 = True | isOpenTypeKindCon kc2 = True -- we already know kc1 is not a fun, its a TyCon | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 560fadf63f..ae6c248f18 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -20,6 +20,7 @@ module TyCon( -- ** Constructing TyCons mkAlgTyCon, mkClassTyCon, + mkIParamTyCon, mkFunTyCon, mkPrimTyCon, mkKindTyCon, @@ -60,13 +61,13 @@ module TyCon( tyConStupidTheta, tyConArity, tyConParent, - tyConClass_maybe, + tyConClass_maybe, tyConIP_maybe, tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe, synTyConDefn, synTyConRhs, synTyConType, tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, - tupleTyConBoxity, tupleTyConArity, + tupleTyConBoxity, tupleTyConSort, tupleTyConArity, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -83,6 +84,7 @@ module TyCon( import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) +import {-# SOURCE #-} IParam ( ipTyConName ) import Var import Class @@ -369,13 +371,13 @@ data TyCon -- | Represents the infinite family of tuple type constructors, -- @()@, @(a,b)@, @(# a, b #)@ etc. | TupleTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - tyConBoxed :: Boxity, - tyConTyVars :: [TyVar], - dataCon :: DataCon -- ^ Corresponding tuple data constructor + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, + tyConTupleSort :: TupleSort, + tyConTyVars :: [TyVar], + dataCon :: DataCon -- ^ Corresponding tuple data constructor } -- | Represents type synonyms @@ -545,6 +547,10 @@ data TyConParent | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the current tycon + -- | Associated type of a implicit parameter. + | IPTyCon + (IPName Name) + -- | An *associated* type of a class. | AssocFamilyTyCon Class -- The class in whose declaration the family is declared @@ -573,11 +579,19 @@ data TyConParent -- axiom co a :: T [a] ~ R:TList a -- with R:TList's algTcParent = FamInstTyCon T [a] co +instance Outputable TyConParent where + ppr NoParentTyCon = text "No parent" + ppr (ClassTyCon cls) = text "Class parent" <+> ppr cls + ppr (IPTyCon n) = text "IP parent" <+> ppr n + ppr (AssocFamilyTyCon cls) = text "Class parent (assoc. family)" <+> ppr cls + ppr (FamInstTyCon tc tys _) = text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys) + -- | Checks the invariants of a 'TyConParent' given the appropriate type class name, if any okParent :: Name -> TyConParent -> Bool okParent _ NoParentTyCon = True okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls) okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls) +okParent tc_name (IPTyCon ip) = tc_name == ipTyConName ip okParent _ (FamInstTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys isNoParent :: TyConParent -> Bool @@ -818,7 +832,7 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn tyConTyVars = tyvars, algTcStupidTheta = stupid, algTcRhs = rhs, - algTcParent = ASSERT( okParent name parent ) parent, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, algTcRec = is_rec, algTcGadtSyntax = gadt_syn } @@ -828,20 +842,25 @@ mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> Ty mkClassTyCon name kind tyvars rhs clas is_rec = mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False +-- | Simpler specialization of 'mkAlgTyCon' for implicit paramaters +mkIParamTyCon :: Name -> Kind -> TyVar -> AlgTyConRhs -> RecFlag -> TyCon +mkIParamTyCon name kind tyvar rhs is_rec = + mkAlgTyCon name kind [tyvar] [] rhs NoParentTyCon is_rec False + mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' -> Arity -- ^ Arity of the tuple -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon - -> Boxity -- ^ Whether the tuple is boxed or unboxed + -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> TyCon -mkTupleTyCon name kind arity tyvars con boxed +mkTupleTyCon name kind arity tyvars con sort = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, tc_kind = kind, tyConArity = arity, - tyConBoxed = boxed, + tyConTupleSort = sort, tyConTyVars = tyvars, dataCon = con } @@ -947,7 +966,7 @@ isPrimTyCon _ = False -- be true for primitive and unboxed-tuple 'TyCon's isUnLiftedTyCon :: TyCon -> Bool isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted -isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) +isUnLiftedTyCon (TupleTyCon {tyConTupleSort = sort}) = not (isBoxed (tupleSortBoxity sort)) isUnLiftedTyCon _ = False -- | Returns @True@ if the supplied 'TyCon' resulted from either a @@ -970,11 +989,11 @@ isDataTyCon :: TyCon -> Bool -- get an info table. The family declaration 'TyCon' does not isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of - DataFamilyTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False -isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity + DataFamilyTyCon {} -> False + DataTyCon {} -> True + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort) isDataTyCon _ = False -- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to @@ -1114,18 +1133,23 @@ isTupleTyCon _ = False -- | Is this the 'TyCon' for an unboxed tuple? isUnboxedTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) -isUnboxedTupleTyCon _ = False +isUnboxedTupleTyCon (TupleTyCon {tyConTupleSort = sort}) = not (isBoxed (tupleSortBoxity sort)) +isUnboxedTupleTyCon _ = False -- | Is this the 'TyCon' for a boxed tuple? isBoxedTupleTyCon :: TyCon -> Bool -isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity -isBoxedTupleTyCon _ = False +isBoxedTupleTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort) +isBoxedTupleTyCon _ = False -- | Extract the boxity of the given 'TyCon', if it is a 'TupleTyCon'. -- Panics otherwise tupleTyConBoxity :: TyCon -> Boxity -tupleTyConBoxity tc = tyConBoxed tc +tupleTyConBoxity tc = tupleSortBoxity (tyConTupleSort tc) + +-- | Extract the 'TupleSort' of the given 'TyCon', if it is a 'TupleTyCon'. +-- Panics otherwise +tupleTyConSort :: TyCon -> TupleSort +tupleTyConSort tc = tyConTupleSort tc -- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'. -- Panics otherwise @@ -1166,8 +1190,7 @@ isAnyTyCon _ = False isImplicitTyCon :: TyCon -> Bool isImplicitTyCon tycon | isTyConAssoc tycon = True | isSynTyCon tycon = False - | isAlgTyCon tycon = isClassTyCon tycon || - isTupleTyCon tycon + | isAlgTyCon tycon = isTupleTyCon tycon isImplicitTyCon _other = True -- catches: FunTyCon, PrimTyCon, -- CoTyCon, SuperKindTyCon @@ -1352,6 +1375,12 @@ tyConClass_maybe :: TyCon -> Maybe Class tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas tyConClass_maybe _ = Nothing +-- | If this 'TyCon' is that for implicit parameter, return the IP it is for. +-- Otherwise returns @Nothing@ +tyConIP_maybe :: TyCon -> Maybe (IPName Name) +tyConIP_maybe (AlgTyCon {algTcParent = IPTyCon ip}) = Just ip +tyConIP_maybe _ = Nothing + ---------------------------------------------------------------------------- tyConParent :: TyCon -> TyConParent tyConParent (AlgTyCon {algTcParent = parent}) = parent diff --git a/compiler/types/TyCon.lhs-boot b/compiler/types/TyCon.lhs-boot index 83b4b7d07a..51ea99b17c 100644 --- a/compiler/types/TyCon.lhs-boot +++ b/compiler/types/TyCon.lhs-boot @@ -1,8 +1,13 @@ \begin{code} module TyCon where +import Name (Name) +import Unique (Unique) + data TyCon +tyConName :: TyCon -> Name +tyConUnique :: TyCon -> Unique isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool isFunTyCon :: TyCon -> Bool diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index db943d4fde..27108a541f 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -20,7 +20,7 @@ module Type ( -- $type_classification -- $representation_types - TyThing(..), Type, Pred(..), PredType, ThetaType, + TyThing(..), Type, PredType, ThetaType, Var, TyVar, isTyVar, -- ** Constructing and deconstructing types @@ -44,37 +44,47 @@ module Type ( newTyConInstRhs, carefullySplitNewType_maybe, -- Pred types - isClassPred, isEqPred, isIPPred, - mkPredTy, mkPredTys, mkFamilyTyConApp, - mkDictTy, isDictLikeTy, - mkEqPred, mkClassPred, + mkFamilyTyConApp, + isDictLikeTy, + mkEqPred, mkClassPred, mkIPPred, + noParenPred, isClassPred, isEqPred, isIPPred, + mkPrimEqType, + + -- Deconstructing predicate types + PredTree(..), predTreePredType, predTypePredTree, + getClassPredTys, getClassPredTys_maybe, + getEqPredTys, getEqPredTys_maybe, + getIPPredTy_maybe, -- ** Common type constructors funTyCon, -- ** Predicates on types - isTyVarTy, isFunTy, isDictTy, isCertainlyPredReprTy, + isTyVarTy, isFunTy, isDictTy, isCertainlyPredReprTy, isPredTy, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, - isPrimitiveType, isStrictType, isStrictPred, + isPrimitiveType, isStrictType, -- * Main data types representing Kinds -- $kind_subtyping Kind, SimpleKind, KindVar, + + -- ** Finding the kind of a type + typeKind, -- ** Common Kinds and SuperKinds liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, + argTypeKind, ubxTupleKind, constraintKind, tySuperKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, -- * Type free variables - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, + tyVarsOfType, tyVarsOfTypes, expandTypeSynonyms, typeSize, @@ -83,7 +93,7 @@ module Type ( eqPred, eqPredX, cmpPred, eqKind, -- * Forcing evaluation of types - seqType, seqTypes, seqPred, + seqType, seqTypes, -- * Other views onto Types coreView, tcView, @@ -93,7 +103,7 @@ module Type ( -- * Type representation for the code generator PrimRep(..), - typePrimRep, predTypeRep, + typePrimRep, -- * Main type substitution data types TvSubstEnv, -- Representation widely visible @@ -112,12 +122,12 @@ module Type ( -- ** Performing substitution on types substTy, substTys, substTyWith, substTysWith, substTheta, - substPred, substTyVar, substTyVars, substTyVarBndr, + substTyVar, substTyVars, substTyVarBndr, cloneTyVarBndr, deShadowTy, lookupTyVar, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, - pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, + pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon @@ -128,6 +138,7 @@ module Type ( -- We import the representation and primitive functions from TypeRep. -- Many things are reexported, but not the representation! +import Kind ( kindAppResult, kindFunResult, isTySuperKind, isSubOpenTypeKind ) import TypeRep -- friends: @@ -138,11 +149,13 @@ import VarSet import Class import TyCon import TysPrim -import PrelNames ( eqPredPrimTyConKey ) +import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy ) +import PrelNames ( eqTyConKey, eqPrimTyConKey ) -- others +import {-# SOURCE #-} IParam ( ipTyCon ) import Unique ( Unique, hasKey ) -import BasicTypes ( IPName ) +import BasicTypes ( IPName(..) ) import Name ( Name ) import NameSet import StaticFlags @@ -205,8 +218,7 @@ infixr 3 `mkFunTy` -- Associates to the right -- $representation_types -- A /source type/ is a type that is a separate type as far as the type checker is -- concerned, but which has a more low-level representation as far as Core-to-Core --- passes and the rest of the back end is concerned. Notably, 'PredTy's are removed --- from the representation type while they do exist in the source types. +-- passes and the rest of the back end is concerned. -- -- You don't normally have to worry about this, as the utility functions in -- this module will automatically convert a source into a representation type @@ -232,15 +244,13 @@ 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 (PredTy p) = Just (predTypeRep p) coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys - = Just (mkAppTys (substTy (mkTopTvSubst 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! + = Just (mkAppTys (substTy (mkTopTvSubst 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 - ----------------------------------------------- {-# INLINE tcView #-} tcView :: Type -> Maybe Type @@ -269,11 +279,6 @@ expandTypeSynonyms ty go (AppTy t1 t2) = AppTy (go t1) (go t2) go (FunTy t1 t2) = FunTy (go t1) (go t2) go (ForAllTy tv t) = ForAllTy tv (go t) - go (PredTy p) = PredTy (go_pred p) - - go_pred (ClassP c ts) = ClassP c (map go ts) - go_pred (IParam ip t) = IParam ip (go t) - go_pred (EqPred t1 t2) = EqPred (go t1) (go t2) \end{code} @@ -615,7 +620,7 @@ deepRepType ty = go rec_nts' ty' -- Apply recursively; this is the "deep" bit - go rec_nts (TyConApp tc tys) = mkTyConApp tc (map (go rec_nts) tys) + go rec_nts (TyConApp tc tys) = TyConApp tc (map (go rec_nts) tys) go rec_nts (AppTy ty1 ty2) = mkAppTy (go rec_nts ty1) (go rec_nts ty2) go rec_nts (FunTy ty1 ty2) = FunTy (go rec_nts ty1) (go rec_nts ty2) @@ -759,75 +764,68 @@ applyTysD doc orig_fun_ty arg_tys %* * %************************************************************************ -Polymorphic functions over Pred +Predicates on PredType \begin{code} -isClassPred :: Pred a -> Bool -isClassPred (ClassP {}) = True -isClassPred _ = False - -isEqPred :: Pred a -> Bool -isEqPred (EqPred {}) = True -isEqPred _ = False - -isIPPred :: Pred a -> Bool -isIPPred (IParam {}) = True -isIPPred _ = False +noParenPred :: PredType -> Bool +-- A predicate that can appear without parens before a "=>" +-- C a => a -> a +-- a~b => a -> b +-- But (?x::Int) => Int -> Int +noParenPred p = isClassPred p || isEqPred p + +isClassPred, isEqPred, 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 + _ -> False +isIPPred ty = case tyConAppTyCon_maybe ty of + Just tyCon | Just _ <- tyConIP_maybe tyCon -> True + _ -> False \end{code} Make PredTypes \begin{code} -mkPredTy :: PredType -> Type -mkPredTy pred = PredTy pred - -mkPredTys :: ThetaType -> [Type] -mkPredTys preds = map PredTy preds - -predTypeRep :: PredType -> Type --- ^ Convert a 'PredType' to its representation type. However, it unwraps --- only the outermost level; for example, the result might be a newtype application -predTypeRep (IParam _ ty) = ty -predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [ty1,ty2] - -- We can't tell if a type originated from an IParam predicate, so -- this function is conservative. It is only used in the eta-contraction/expansion -- logic at the moment, so this doesn't matter a great deal. isCertainlyPredReprTy :: Type -> Bool isCertainlyPredReprTy ty | Just ty' <- coreView ty = isCertainlyPredReprTy ty' isCertainlyPredReprTy ty = case tyConAppTyCon_maybe ty of - Just tc -> tc `hasKey` eqPredPrimTyConKey || isClassTyCon tc + Just tc -> tc `hasKey` eqPrimTyConKey || isClassTyCon tc Nothing -> False + +isPredTy :: Type -> Bool +isPredTy ty = typeKind ty `eqKind` constraintKind \end{code} --------------------- Equality types --------------------------------- \begin{code} -- | Creates a type equality predicate -mkEqPred :: (a, a) -> Pred a -mkEqPred (ty1, ty2) = EqPred ty1 ty2 +mkEqPred :: (Type, Type) -> PredType +mkEqPred (ty1, ty2) = TyConApp eqTyCon [ty1, ty2] + +mkPrimEqType :: (Type, Type) -> Type +mkPrimEqType (ty1, ty2) = TyConApp eqPrimTyCon [ty1, ty2] \end{code} --------------------- Implicit parameters --------------------------------- \begin{code} mkIPPred :: IPName Name -> Type -> PredType -mkIPPred ip ty = IParam ip ty +mkIPPred ip ty = TyConApp (ipTyCon ip) [ty] \end{code} --------------------- Dictionary types --------------------------------- \begin{code} mkClassPred :: Class -> [Type] -> PredType -mkClassPred clas tys = ClassP clas tys - -mkDictTy :: Class -> [Type] -> Type -mkDictTy clas tys = mkPredTy (ClassP clas tys) +mkClassPred clas tys = TyConApp (classTyCon clas) tys isDictTy :: Type -> Bool -isDictTy ty | Just ty' <- coreView ty = isDictTy ty' -isDictTy ty = case tyConAppTyCon_maybe ty of - Just tyCon -> isClassTyCon tyCon - _ -> False +isDictTy = isClassPred isDictLikeTy :: Type -> Bool -- Note [Dictionary-like types] @@ -867,6 +865,65 @@ we ended up with something like This is all a bit ad-hoc; eg it relies on knowing that implication constraints build tuples. + +Decomposing PredType + +\begin{code} +data PredTree = ClassPred Class [Type] + | EqPred Type Type + | IPPred (IPName Name) Type + | TuplePred [PredTree] + | IrredPred PredType + +predTreePredType :: PredTree -> PredType +predTreePredType (ClassPred clas tys) = mkClassPred clas tys +predTreePredType (EqPred ty1 ty2) = mkEqPred (ty1, ty2) +predTreePredType (IPPred ip ty) = mkIPPred ip ty +predTreePredType (TuplePred tys) = mkBoxedTupleTy (map predTreePredType tys) +predTreePredType (IrredPred ty) = ty + +predTypePredTree :: PredType -> PredTree +predTypePredTree ev_ty = case splitTyConApp_maybe ev_ty of + Just (tc, tys) | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys + Just (tc, tys) | tc `hasKey` eqTyConKey + , let [ty1, ty2] = tys + -> EqPred ty1 ty2 + Just (tc, tys) | Just ip <- tyConIP_maybe tc + , let [ty] = tys + -> IPPred ip ty + Just (tc, tys) | isTupleTyCon tc + -> TuplePred (map predTypePredTree tys) + _ -> IrredPred ev_ty +\end{code} + +\begin{code} +getClassPredTys :: PredType -> (Class, [Type]) +getClassPredTys ty = case getClassPredTys_maybe ty of + Just (clas, tys) -> (clas, tys) + Nothing -> pprPanic "getClassPredTys" (ppr ty) + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe ty = case splitTyConApp_maybe ty of + Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) + _ -> Nothing + +getEqPredTys :: PredType -> (Type, Type) +getEqPredTys ty = case getEqPredTys_maybe ty of + Just (ty1, ty2) -> (ty1, ty2) + Nothing -> pprPanic "getEqPredTys" (ppr ty) + +getEqPredTys_maybe :: PredType -> Maybe (Type, Type) +getEqPredTys_maybe ty = case splitTyConApp_maybe ty of + Just (tc, [ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2) + _ -> Nothing + +getIPPredTy_maybe :: PredType -> Maybe (IPName Name, Type) +getIPPredTy_maybe ty = case splitTyConApp_maybe ty of + Just (tc, [ty1]) | Just ip <- tyConIP_maybe tc -> Just (ip, ty1) + _ -> Nothing +\end{code} + %************************************************************************ %* * Size @@ -878,7 +935,6 @@ typeSize :: Type -> Int typeSize (TyVarTy _) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (PredTy p) = predSize typeSize p typeSize (ForAllTy _ t) = 1 + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) \end{code} @@ -941,7 +997,6 @@ isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc isUnLiftedType _ = False - -- There is no need to check for (PredTy (EqPred {})) because coreView eliminates PredTy isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of @@ -979,22 +1034,19 @@ isClosedAlgType ty -- Since it takes account of class 'PredType's, you might think -- this function should be in 'TcType', but 'isStrictType' is used by 'DataCon', -- which is below 'TcType' in the hierarchy, so it's convenient to put it here. -isStrictType :: Type -> Bool -isStrictType (PredTy pred) = isStrictPred pred -isStrictType ty | Just ty' <- coreView ty = isStrictType ty' -isStrictType (ForAllTy _ ty) = isStrictType ty -isStrictType (TyConApp tc _) = isUnLiftedTyCon tc -isStrictType _ = False - --- | We may be strict in dictionary types, but only if it +-- +-- We may be strict in dictionary types, but only if it -- has more than one component. -- -- (Being strict in a single-component dictionary risks -- poking the dictionary component, which is wrong.) -isStrictPred :: PredType -> Bool -isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) -isStrictPred (EqPred {}) = True -isStrictPred (IParam {}) = False +isStrictType :: Type -> Bool +isStrictType ty | Just ty' <- coreView ty = isStrictType ty' +isStrictType (ForAllTy _ ty) = isStrictType ty +isStrictType (TyConApp tc _) + | isUnLiftedTyCon tc = True + | isClassTyCon tc, opt_DictsStrict = True +isStrictType _ = False \end{code} \begin{code} @@ -1020,18 +1072,12 @@ seqType :: Type -> () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (PredTy p) = seqPred seqType p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty seqTypes :: [Type] -> () seqTypes [] = () seqTypes (ty:tys) = seqType ty `seq` seqTypes tys - -seqPred :: (a -> ()) -> Pred a -> () -seqPred seqt (ClassP c tys) = c `seq` foldr (seq . seqt) () tys -seqPred seqt (IParam n ty) = n `seq` seqt ty -seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2 \end{code} @@ -1058,10 +1104,10 @@ eqTypes :: [Type] -> [Type] -> Bool eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 eqPred :: PredType -> PredType -> Bool -eqPred p1 p2 = isEqual $ cmpPred p1 p2 +eqPred = eqType eqPredX :: RnEnv2 -> PredType -> PredType -> Bool -eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 +eqPredX env p1 p2 = isEqual $ cmpTypeX env p1 p2 \end{code} Now here comes the real worker @@ -1078,9 +1124,9 @@ cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2 rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2)) cmpPred :: PredType -> PredType -> Ordering -cmpPred p1 p2 = cmpPredX rn_env p1 p2 +cmpPred p1 p2 = cmpTypeX rn_env p1 p2 where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2)) + rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType p1 `unionVarSet` tyVarsOfType p2)) cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 @@ -1095,7 +1141,6 @@ cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = 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 (PredTy p1) (PredTy p2) = cmpPredX env p1 p2 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy @@ -1113,8 +1158,6 @@ cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT -cmpTypeX _ (PredTy _) _ = GT - cmpTypeX _ _ _ = LT ------------- @@ -1123,34 +1166,8 @@ cmpTypesX _ [] [] = EQ cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2 cmpTypesX _ [] _ = LT cmpTypesX _ _ [] = GT - -------------- -cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering -cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2 - -- Compare names only for implicit parameters - -- This comparison is used exclusively (I believe) - -- for the Avails finite map built in TcSimplify - -- If the types differ we keep them distinct so that we see - -- a distinct pair to run improvement on -cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTypesX env tys1 tys2) -cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2') - --- Constructor order: IParam < ClassP < EqPred -cmpPredX _ (IParam {}) _ = LT -cmpPredX _ (ClassP {}) (IParam {}) = GT -cmpPredX _ (ClassP {}) (EqPred {}) = LT -cmpPredX _ (EqPred {}) _ = GT \end{code} -PredTypes are used as a FM key in TcSimplify, -so we take the easy path and make them an instance of Ord - -\begin{code} -instance Eq PredType where { (==) = eqPred } -instance Ord PredType where { compare = cmpPred } -\end{code} - - %************************************************************************ %* * Type substitutions @@ -1332,13 +1349,7 @@ substTys subst tys | isEmptyTvSubst subst = tys substTheta :: TvSubst -> ThetaType -> ThetaType substTheta subst theta | isEmptyTvSubst subst = theta - | otherwise = map (substPred subst) theta - --- | Substitute within a 'PredType' -substPred :: TvSubst -> PredType -> PredType -substPred subst (IParam n ty) = IParam n (subst_ty subst ty) -substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) -substPred subst (EqPred ty1 ty2) = EqPred (subst_ty subst ty1) (subst_ty subst ty2) + | otherwise = map (substTy subst) theta -- | Remove any nested binders mentioning the 'TyVar's in the 'TyVarSet' deShadowTy :: TyVarSet -> Type -> Type @@ -1359,8 +1370,6 @@ subst_ty subst ty go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args - go (PredTy p) = PredTy $! (substPred subst p) - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) -- The mkAppTy smart constructor is important @@ -1462,6 +1471,36 @@ type KindVar = TyVar -- invariant: KindVar will always be a type SimpleKind = Kind \end{code} +%************************************************************************ +%* * + The kind of a type +%* * +%************************************************************************ + +\begin{code} +typeKind :: Type -> Kind +typeKind ty@(TyConApp tc tys) + = ASSERT2( not (tc `hasKey` eqPrimTyConKey) || length tys == 2, ppr ty ) + -- Assertion checks for unsaturated application of ~# + -- See Note [The ~# TyCon] in TysPrim + kindAppResult (tyConKind tc) tys + +typeKind (AppTy fun _) = kindFunResult (typeKind fun) +typeKind (ForAllTy _ ty) = typeKind ty +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (FunTy _arg res) + -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), + -- not unliftedTypKind (#) + -- 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. * -> (* -> *)) + | isTySuperKind k = k + | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind + where + k = typeKind res + +\end{code} + Kind inference ~~~~~~~~~~~~~~ During kind inference, a kind variable unifies only with diff --git a/compiler/types/Type.lhs-boot b/compiler/types/Type.lhs-boot new file mode 100644 index 0000000000..c9378fb214 --- /dev/null +++ b/compiler/types/Type.lhs-boot @@ -0,0 +1,9 @@ +\begin{code} +module Type where +import {-# SOURCE #-} TypeRep( Type, Kind ) + +noParenPred :: Type -> Bool +isPredTy :: Type -> Bool + +typeKind :: Type -> Kind +\end{code} diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 6a0b87c581..178ffdc00e 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -9,30 +9,25 @@ {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module TypeRep ( - TyThing(..), + TyThing(..), Type(..), - Pred(..), -- to friends - Kind, SuperKind, PredType, ThetaType, -- Synonyms -- Functions over types mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, - isLiftedTypeKind, - + isLiftedTypeKind, + -- Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThing, pprTyThingCategory, - pprPredTy, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, + pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, Prec(..), maybeParen, pprTcApp, pprTypeNameApp, - pprPrefixApp, pprPred, pprArrowChain, pprThetaArrow, + pprPrefixApp, pprArrowChain, -- Free variables tyVarsOfType, tyVarsOfTypes, - tyVarsOfPred, tyVarsOfTheta, - varsOfPred, varsOfTheta, - predSize, -- Substitutions TvSubst(..), TvSubstEnv @@ -41,6 +36,7 @@ module TypeRep ( #include "HsVersions.h" import {-# SOURCE #-} DataCon( DataCon, dataConName ) +import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: import Var @@ -59,8 +55,6 @@ import Pair -- libraries import qualified Data.Data as Data hiding ( TyCon ) -import qualified Data.Foldable as Data -import qualified Data.Traversable as Data \end{code} ---------------------- @@ -153,13 +147,6 @@ data Type TyVar -- Type variable Type -- ^ A polymorphic type - | PredTy - PredType -- ^ The type of evidence for a type predictate. - -- See Note [PredTy] - -- By the time we are in Core-land, PredTys are - -- synonymous with their representation - -- (see Type.predTypeRep) - deriving (Data.Data, Data.Typeable) -- | The key type representing kinds in the compiler. @@ -184,16 +171,20 @@ The type forall ab. (a ~ [b]) => blah is encoded like this: ForAllTy (a:*) $ ForAllTy (b:*) $ - FunTy (PredTy (EqPred a [b]) $ + FunTy (TyConApp (~) [a, [b]]) $ blah ------------------------------------- Note [PredTy] \begin{code} --- | A type of the form @PredTy p@ represents a value whose type is +-- | 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 @@ -207,13 +198,7 @@ is encoded like this: -- > h :: (r\l) => {r} => {l::Int | r} -- -- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -type PredType = Pred Type - -data Pred a -- Typically 'a' is instantiated with Type or Coercion - = ClassP Class [a] -- ^ Class predicate e.g. @Eq a@ - | IParam (IPName Name) a -- ^ Implicit parameter e.g. @?x :: Int@ - | EqPred a a -- ^ Equality predicate e.g @ty1 ~ ty2@ - deriving (Data.Data, Data.Typeable, Data.Foldable, Data.Traversable, Functor) +type PredType = Type -- | A collection of 'PredType's type ThetaType = [PredType] @@ -225,12 +210,11 @@ 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 PredTy as the function argument + * 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 (PredTy p) then the predicate p is -represented by evidence (a dictionary, for example, of type (predRepTy p). - +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. %************************************************************************ %* * @@ -276,36 +260,16 @@ isLiftedTypeKind _ = False %************************************************************************ \begin{code} -tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred = varsOfPred tyVarsOfType - -tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = varsOfTheta tyVarsOfType - tyVarsOfType :: Type -> VarSet -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym tyVarsOfType (TyVarTy v) = unitVarSet v tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys -tyVarsOfType (PredTy sty) = varsOfPred tyVarsOfType sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys - -varsOfPred :: (a -> VarSet) -> Pred a -> VarSet -varsOfPred f (IParam _ ty) = f ty -varsOfPred f (ClassP _ tys) = foldr (unionVarSet . f) emptyVarSet tys -varsOfPred f (EqPred ty1 ty2) = f ty1 `unionVarSet` f ty2 - -varsOfTheta :: (a -> VarSet) -> [Pred a] -> VarSet -varsOfTheta f = foldr (unionVarSet . varsOfPred f) emptyVarSet - -predSize :: (a -> Int) -> Pred a -> Int -predSize size (IParam _ t) = 1 + size t -predSize size (ClassP _ ts) = 1 + sum (map size ts) -predSize size (EqPred t1 t2) = size t1 + size t2 \end{code} %************************************************************************ @@ -324,7 +288,6 @@ data TyThing = AnId Id | ADataCon DataCon | ATyCon TyCon | ACoAxiom CoAxiom - | AClass Class instance Outputable TyThing where ppr = pprTyThing @@ -333,9 +296,10 @@ pprTyThing :: TyThing -> SDoc pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor") +pprTyThingCategory (ATyCon tc) + | isClassTyCon tc = ptext (sLit "Class") + | otherwise = ptext (sLit "Type constructor") pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") -pprTyThingCategory (AClass _) = ptext (sLit "Class") pprTyThingCategory (AnId _) = ptext (sLit "Identifier") pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor") @@ -343,8 +307,8 @@ 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 (AClass cl) = getName cl getName (ADataCon dc) = dataConName dc + \end{code} @@ -464,15 +428,6 @@ pprKind = pprType pprParendKind = pprParendType ------------------ -pprPredTy :: PredType -> SDoc -pprPredTy = pprPred ppr_type - -pprPred :: (Prec -> a -> SDoc) -> Pred a -> SDoc -pprPred pp (ClassP cls tys) = ppr_class_pred pp cls tys -pprPred pp (IParam ip ty) = ppr ip <> dcolon <> pp TopPrec ty -pprPred pp (EqPred ty1 ty2) = ppr_eq_pred pp (Pair ty1 ty2) - ------------- pprEqPred :: Pair Type -> SDoc pprEqPred = ppr_eq_pred ppr_type @@ -495,16 +450,13 @@ ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys ------------ pprTheta :: ThetaType -> SDoc -- pprTheta [pred] = pprPred pred -- I'm in two minds about this -pprTheta theta = parens (sep (punctuate comma (map pprPredTy theta))) +pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy = pprThetaArrow ppr_type - -pprThetaArrow :: (Prec -> a -> SDoc) -> [Pred a] -> SDoc -pprThetaArrow _ [] = empty -pprThetaArrow pp [pred] - | noParenPred pred = pprPred pp pred <+> darrow -pprThetaArrow pp preds = parens (fsep (punctuate comma (map (pprPred pp) preds))) +pprThetaArrowTy [] = empty +pprThetaArrowTy [pred] + | noParenPred pred = ppr_type TopPrec pred <+> darrow +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 @@ -527,24 +479,11 @@ pprThetaArrow pp preds = parens (fsep (punctuate comma (map (pprPred pp) preds -- 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) - -noParenPred :: Pred a -> Bool --- A predicate that can appear without parens before a "=>" --- C a => a -> a --- a~b => a -> b --- But (?x::Int) => Int -> Int -noParenPred (ClassP {}) = True -noParenPred (EqPred {}) = True -noParenPred (IParam {}) = False ------------------ instance Outputable Type where ppr ty = pprType ty -instance Outputable (Pred Type) where - ppr = pprPredTy -- Not for arbitrary (Pred a), because the - -- (Outputable a) doesn't give precedence - instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now @@ -553,27 +492,23 @@ instance Outputable name => OutputableBndr (IPName name) where ppr_type :: Prec -> Type -> SDoc ppr_type _ (TyVarTy tv) = ppr_tvar tv -ppr_type p (PredTy pred) = maybeParen p TyConPrec $ - ifPprDebug (ptext (sLit "<pred>")) <> (pprPredTy pred) ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty -ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty - -ppr_type p (FunTy ty1 ty2) +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 (is_pred ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 + | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] - is_pred (PredTy {}) = True - is_pred _ = False - ppr_forall_type :: Prec -> Type -> SDoc ppr_forall_type p ty = maybeParen p FunPrec $ @@ -583,10 +518,10 @@ ppr_forall_type p ty (ctxt, tau) = split2 [] rho split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) + split1 tvs ty = (reverse tvs, ty) - split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty - split2 ps ty = (reverse ps, ty) + split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 + split2 ps ty = (reverse ps, ty) ppr_tvar :: TyVar -> SDoc ppr_tvar tv -- Note [Infix type variables] @@ -641,10 +576,15 @@ pprTcApp _ pp tc [ty] | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)") | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??") + | Just n <- tyConIP_maybe tc = ppr n <> ptext (sLit "::") <> pp TopPrec ty pprTcApp p pp tc tys | isTupleTyCon tc && tyConArity tc == length tys - = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys))) + = tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) + | tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because + -- its not a SymOcc so won't get printed infix + , [ty1,ty2] <- tys + = pprInfixApp p pp (getName tc) ty1 ty2 | otherwise = pprTypeNameApp p pp (getName tc) tys @@ -659,14 +599,18 @@ pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc pprTypeNameApp p pp tc tys | is_sym_occ -- Print infix if possible , [ty1,ty2] <- tys -- We know nothing of precedence though - = maybeParen p FunPrec $ - sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2] + = pprInfixApp p pp tc ty1 ty2 | otherwise = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys) where is_sym_occ = isSymOcc (getOccName tc) ---------------- +pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> Name -> a -> a -> SDoc +pprInfixApp p pp tc ty1 ty2 + = maybeParen p FunPrec $ + sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2] + pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $ hang pp_fun 2 (sep pp_tys) diff --git a/compiler/types/TypeRep.lhs-boot b/compiler/types/TypeRep.lhs-boot index fe8fd59d1b..05c9d9b7cd 100644 --- a/compiler/types/TypeRep.lhs-boot +++ b/compiler/types/TypeRep.lhs-boot @@ -1,13 +1,14 @@ \begin{code} module TypeRep where +import Outputable (Outputable) + data Type -data Pred a data TyThing -type PredType = Pred Type +type PredType = Type type Kind = Type -isCoercionKind :: Kind -> Bool +instance Outputable Type \end{code} diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 559682ed3a..06bae088c0 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -126,10 +126,10 @@ tcMatchPreds -> [PredType] -> [PredType] -> Maybe TvSubstEnv tcMatchPreds tmpls ps1 ps2 - = matchList (match_pred menv) emptyTvSubstEnv 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 (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2) + 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 @@ -185,8 +185,6 @@ match menv subst (ForAllTy tv1 ty1) (ForAllTy tv2 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 (PredTy p1) (PredTy p2) - = match_pred menv subst p1 p2 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) @@ -233,14 +231,6 @@ matchList _ subst [] [] = Just subst matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b ; matchList fn subst' as bs } matchList _ _ _ _ = Nothing - --------------- -match_pred :: MatchEnv -> TvSubstEnv -> PredType -> PredType -> Maybe TvSubstEnv -match_pred menv subst (ClassP c1 tys1) (ClassP c2 tys2) - | c1 == c2 = match_tys menv subst tys1 tys2 -match_pred menv subst (IParam n1 t1) (IParam n2 t2) - | n1 == n2 = match menv subst t1 t2 -match_pred _ _ _ _ = Nothing \end{code} @@ -435,8 +425,6 @@ unify subst ty1 (TyVarTy tv2) = uVar subst tv2 ty1 unify subst ty1 ty2 | Just ty1' <- tcView ty1 = unify subst ty1' ty2 unify subst ty1 ty2 | Just ty2' <- tcView ty2 = unify subst ty1 ty2' -unify subst (PredTy p1) (PredTy p2) = unify_pred subst p1 p2 - unify subst (TyConApp tyc1 tys1) (TyConApp tyc2 tys2) | tyc1 == tyc2 = unify_tys subst tys1 tys2 @@ -462,14 +450,6 @@ unify _ ty1 ty2 = failWith (misMatch ty1 ty2) -- ForAlls?? ------------------------------ -unify_pred :: TvSubstEnv -> PredType -> PredType -> UM TvSubstEnv -unify_pred subst (ClassP c1 tys1) (ClassP c2 tys2) - | c1 == c2 = unify_tys subst tys1 tys2 -unify_pred subst (IParam n1 t1) (IParam n2 t2) - | n1 == n2 = unify subst t1 t2 -unify_pred _ p1 p2 = failWith (misMatch (PredTy p1) (PredTy p2)) - ------------------------------- unify_tys :: TvSubstEnv -> [Type] -> [Type] -> UM TvSubstEnv unify_tys subst xs ys = unifyList subst xs ys diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index c5f1c0c2ed..ad678fd45d 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -32,6 +32,7 @@ module Util ( -- * Tuples fstOf3, sndOf3, thirdOf3, + firstM, first3M, -- * List operations controlled by another list takeList, dropList, splitAtList, split, @@ -104,7 +105,7 @@ import Data.List hiding (group) import FastTypes #endif -import Control.Monad ( unless ) +import Control.Monad ( unless, liftM ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, createDirectory, getModificationTime ) @@ -210,6 +211,14 @@ sndOf3 (_,b,_) = b thirdOf3 (_,_,c) = c \end{code} +\begin{code} +firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) +firstM f (x, y) = liftM (\x' -> (x', y)) (f x) + +first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) +first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) +\end{code} + %************************************************************************ %* * \subsection[Utils-lists]{General list processing} diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index 8456d340fc..8d02b3e1ff 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -156,7 +156,7 @@ sumTyCon = indexBuiltin "sumTyCon" sumTyCons prodTyCon :: Int -> Builtins -> TyCon prodTyCon n _ | n >= 2 && n <= mAX_DPH_PROD - = tupleTyCon Boxed n + = tupleTyCon BoxedTuple n | otherwise = pprPanic "prodTyCon" (ppr n) diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 025bcc7da2..4a9c8e2399 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -233,7 +233,7 @@ initBuiltinVars (Builtins { dphModules = mods }) preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] where - mk_tup n mod name = (tupleCon Boxed n, mod, name) + mk_tup n mod name = (tupleCon BoxedTuple n, mod, name) -- |Get a list of names to `TyCon`s in the mock prelude. -- @@ -316,4 +316,4 @@ externalType mod fs -- externalClass :: Module -> FastString -> DsM Class externalClass mod fs - = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs) + = fmap (maybe (panic "externalClass") id . tyConClass_maybe) $ dsLookupTyCon =<< lookupOrig mod (mkClsOccFS fs) diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 283af8175d..5bf768310c 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -24,7 +24,6 @@ import TyCon import TypeRep import Type import Digraph -import Outputable -- |From a list of type constructors, extract those thatcan be vectorised, returning them in two @@ -102,4 +101,3 @@ tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) `addOneToUniqSet` funTyCon tyConsOfType (ForAllTy _ ty) = tyConsOfType ty -tyConsOfType other = pprPanic "ClosureConv.tyConsOfType" $ ppr other diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs index fe12304be5..e1aa6eab95 100644 --- a/compiler/vectorise/Vectorise/Type/PADict.hs +++ b/compiler/vectorise/Vectorise/Type/PADict.hs @@ -16,7 +16,6 @@ import CoreUnfold import DsMonad import TyCon import Type -import TypeRep import Id import Var import Name @@ -73,7 +72,7 @@ buildPADict vect_tc prepr_tc arr_tc repr ; pa_cls <- builtin paClass ; let dfun_ty = mkForAllTys tvs $ mkFunTys (map varType args) - (PredTy $ ClassP pa_cls [inst_ty]) + (mkClassPred pa_cls [inst_ty]) -- Set the unfolding for the inliner. ; raw_dfun <- newExportedVar dfun_name dfun_ty diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs index 2a953ff947..db26366d4c 100644 --- a/compiler/vectorise/Vectorise/Type/PRepr.hs +++ b/compiler/vectorise/Vectorise/Type/PRepr.hs @@ -13,7 +13,6 @@ import CoreUtils import MkCore ( mkWildCase ) import TyCon import Type -import Kind import BuildTyCl import OccName import Coercion diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index a8290befcc..c4308e433f 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -32,7 +32,7 @@ vectTyConDecl tycon -- a type class constructor. -- TODO: check for no stupid theta, fds, assoc types. | isClassTyCon tycon - , Just cls <- tyConClass_maybe tycon + , Just cls <- tyConClass_maybe tycon = do -- make the name of the vectorised class tycon. name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon) @@ -88,12 +88,12 @@ vectTyConDecl tycon NoParentTyCon Nothing -- not a family instance - -- some other crazy thing that we don't handle. - | otherwise - = cantVectorise "Can't vectorise type constructor: " (ppr tycon) + -- some other crazy thing that we don't handle. + | otherwise + = cantVectorise "Can't vectorise type constructor: " (ppr tycon) --- |Vectorise a class method. --- + +-- | Vectorise a class method. vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type) vectMethod (id, defMeth) = do { -- Vectorise the method type. diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index 2a3dc534e4..64a4a22dab 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -81,8 +81,6 @@ vectType ty@(ForAllTy _ _) traceVt "vect ForAllTy: " $ ppr (abstractType tyvars (dictsPA ++ dictsVect) tyBody'') return $ abstractType tyvars (dictsPA ++ dictsVect) tyBody'' -vectType ty = cantVectorise "Can't vectorise type" (ppr ty) - -- |Add quantified vars and dictionary parameters to the front of a type. -- abstractType :: [TyVar] -> [Type] -> Type -> Type diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index d784984f21..443850d531 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -23,7 +23,7 @@ import TyCon import DataCon import MkId import TysWiredIn -import BasicTypes( Boxity(..) ) +import BasicTypes( TupleSort(..) ) import FastString @@ -124,7 +124,7 @@ buildEnv [v] = return (vVarType v, vVar v, buildEnv vs = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty - let venv_con = tupleCon Boxed (length vs) + let venv_con = tupleCon BoxedTuple (length vs) [lenv_con] = tyConDataCons lenv_tc venv = mkCoreTup (map Var vvs) diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 03a0e3d93d..33418d45e3 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -45,7 +45,7 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) | isLiftedTypeKind k = do pa_cls <- builtin paClass - return $ Just $ PredTy $ ClassP pa_cls [ty] + return $ Just $ mkClassPred pa_cls [ty] go _ _ = return Nothing |