diff options
125 files changed, 2679 insertions, 2328 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 diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index e7fe56528d..5368d8f082 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -791,6 +791,12 @@ <entry><option>-XNoTypeFamilies</option></entry> </row> <row> + <entry><option>-XConstraintKind</option></entry> + <entry>Enable a <link linkend="constraint-kind">kind of constraints</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoConstraintKind</option></entry> + </row> + <row> <entry><option>-XScopedTypeVariables</option></entry> <entry>Enable <link linkend="scoped-type-variables">lexically-scoped type variables</link>. Implied by <option>-fglasgow-exts</option>.</entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 1988f74746..4bef4eef95 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -5137,6 +5137,98 @@ class (F a ~ b) => C a b where </para> </sect1> +<sect1 id="constraint-kind"> +<title>The <literal>Constraint</literal> kind</title> + +<para> + Normally, <emphasis>constraints</emphasis> (which appear in types to the left of the + <literal>=></literal> arrow) have a very restricted syntax. They can only be: + <itemizedlist> + <listitem> + <para>Class constraints, e.g. <literal>Show a</literal></para> + </listitem> + <listitem> + <para><link linkend="implicit-parameters">Implicit parameter</link> constraints, + e.g. <literal>?x::Int</literal> (with the <option>-XImplicitParams</option> flag)</para> + </listitem> + <listitem> + <para><link linkend="equality-constraints">Equality constraints</link>, + e.g. <literal>a ~ Int</literal> (with the <option>-XTypeFamilies</option> or + <option>-XGADTs</option> flag)</para> + </listitem> + </itemizedlist> +</para> + +<para> + With the <option>-XConstraintKind</option> flag, GHC becomes more liberal in + what it accepts as constraints in your program. To be precise, with this flag any + <emphasis>type</emphasis> of the new kind <literal>Constraint</literal> can be used as a constraint. + The following things have kind <literal>Constraint</literal>: + + <itemizedlist> + <listitem> + Anything which is already valid as a constraint without the flag: saturated applications to type classes, + implicit parameter and equality constraints. + </listitem> + <listitem> + Tuples, all of whose component types have kind <literal>Constraint</literal>. So for example the + type <literal>(Show a, Ord a)</literal> is of kind <literal>Constraint</literal>. + </listitem> + <listitem> + Anything whose form is not yet know, but the user has declared to have kind <literal>Constraint</literal>. + So for example <literal>type Foo (f :: * -> Constraint) = forall b. f b => b -> b</literal> is allowed, as + well as examples involving type families: +<programlisting> +type family Typ a b :: Constraint +type instance Typ Int b = Show b +type instance Typ Bool b = Num b + +func :: Typ a b => a -> b -> b +func = ... +</programlisting> + </listitem> + </itemizedlist> +</para> + +<para> + Note that because constraints are just handled as types of a particular kind, this extension allows type + constraint synonyms: +</para> + +<programlisting> +type Stringy a = (Read a, Show a) +foo :: Stringy a => a -> (String, String -> a) +foo x = (show x, read) +</programlisting> + +<para> + Presently, only standard constraints, tuples and type synonyms for those two sorts of constraint are + permitted in instance contexts and superclasses (without extra flags). The reason is that permitting more general + constraints can cause type checking to loop, as it would with these two programs: +</para> + +<programlisting> +type family Clsish u a +type instance Clsish () a = Cls a +class Clsish () a => Cls a where +</programlisting> + +<programlisting> +class OkCls a where + +type family OkClsish u a +type instance OkClsish () a = OkCls a +instance OkClsish () a => OkCls a where +</programlisting> + +<para> + You may write programs that use exotic sorts of constraints in instance contexts and superclasses, but + to do so you must use <option>-XUndecidableInstances</option> to signal that you don't mind if the type checker + fails to terminate. +</para> + +</sect1> + <sect1 id="other-type-extensions"> <title>Other type system extensions</title> diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs index 95bc83e0bb..650ed876ee 100644 --- a/ghc/GhciTags.hs +++ b/ghc/GhciTags.hs @@ -104,7 +104,6 @@ listModuleTags m = do tyThing2TagKind (AnId _) = 'v' tyThing2TagKind (ADataCon _) = 'd' tyThing2TagKind (ATyCon _) = 't' - tyThing2TagKind (AClass _) = 'c' tyThing2TagKind (ACoAxiom _) = 'x' diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index f5fce67d4d..ddae677262 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -665,7 +665,7 @@ ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x ++ " " ++ ppType y ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x ++ " " ++ ppType y -ppType (TyUTup ts) = "(mkTupleTy Unboxed " +ppType (TyUTup ts) = "(mkTupleTy UnboxedTuple " ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" |