From: simonpj Date: Tue, 13 Mar 2001 14:58:28 +0000 (+0000) Subject: [project @ 2001-03-13 14:58:25 by simonpj] X-Git-Tag: Approximately_9120_patches~2435 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=788faebb40b51d37e73ed94dfc99460d39a1a811;p=ghc-hetmet.git [project @ 2001-03-13 14:58:25 by simonpj] ---------------- Nuke ClassContext ---------------- This commit tidies up a long-standing inconsistency in GHC. The context of a class or instance decl used to be restricted to predicates of the form C t1 .. tn with type ClassContext = [(Class,[Type])] but everywhere else in the compiler we used type ThetaType = [PredType] where PredType can be any sort of constraint (= predicate). The inconsistency actually led to a crash, when compiling class (?x::Int) => C a where {} I've tidied all this up by nuking ClassContext altogether, and using PredType throughout. Lots of modified files, but all in more-or-less trivial ways. I've also added a check that the context of a class or instance decl doesn't include a non-inheritable predicate like (?x::Int). Other things * rename constructor 'Class' from type TypeRep.Pred to 'ClassP' (makes it easier to grep for) * rename constructor HsPClass => HsClassP HsPIParam => HsIParam --- diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 4ad15df..dd6212b 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -28,9 +28,9 @@ module DataCon ( import {-# SOURCE #-} Subst( substTy, mkTyVarSubst ) import CmdLineOpts ( opt_DictsStrict ) -import Type ( Type, TauType, ClassContext, +import Type ( Type, TauType, ThetaType, mkForAllTys, mkFunTys, mkTyConApp, - mkTyVarTys, mkDictTys, + mkTyVarTys, mkPredTys, getClassPredTys_maybe, splitTyConApp_maybe ) import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon, @@ -106,10 +106,10 @@ data DataCon -- These are ALWAYS THE SAME AS THE TYVARS -- FOR THE PARENT TyCon. We occasionally rely on -- this just to avoid redundant instantiation - dcTheta :: ClassContext, + dcTheta :: ThetaType, dcExTyVars :: [TyVar], -- Ditto for the context of the constructor, - dcExTheta :: ClassContext, -- the existentially quantified stuff + dcExTheta :: ThetaType, -- the existentially quantified stuff dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of @@ -233,8 +233,8 @@ instance Show DataCon where \begin{code} mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> ClassContext - -> [TyVar] -> ClassContext + -> [TyVar] -> ThetaType + -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> Id -> Id -> DataCon @@ -260,7 +260,7 @@ mkDataCon name arg_stricts fields (real_arg_stricts, strict_arg_tyss) = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys) - rep_arg_tys = mkDictTys ex_theta ++ concat strict_arg_tyss + rep_arg_tys = mkPredTys ex_theta ++ concat strict_arg_tyss ex_dict_stricts = map mk_dict_strict_mark ex_theta -- Add a strictness flag for the existential dictionary arguments @@ -274,9 +274,9 @@ mkDataCon name arg_stricts fields result_ty = mkTyConApp tycon (mkTyVarTys tyvars) -mk_dict_strict_mark (clas,tys) - | opt_DictsStrict && - -- Don't mark newtype things as strict! +mk_dict_strict_mark pred + | opt_DictsStrict, -- Don't mark newtype things as strict! + Just (clas,_) <- getClassPredTys_maybe pred, isDataTyCon (classTyCon clas) = MarkedStrict | otherwise = NotMarkedStrict \end{code} @@ -334,8 +334,8 @@ dataConRepStrictness dc go (NotMarkedStrict : ss) = wwLazy : go ss go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss) -dataConSig :: DataCon -> ([TyVar], ClassContext, - [TyVar], ClassContext, +dataConSig :: DataCon -> ([TyVar], ThetaType, + [TyVar], ThetaType, [TauType], TyCon) dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, @@ -355,7 +355,7 @@ dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars, dcExTyVars = ex_tyvars}) inst_tys = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys -dataConTheta :: DataCon -> ClassContext +dataConTheta :: DataCon -> ThetaType dataConTheta dc = dcTheta dc -- And the same deal for the original arg tys: diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 443d75f..fb7fff8 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -38,7 +38,7 @@ import TysWiredIn ( charTy, mkListTy ) import PrelNames ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) -import Type ( Type, ThetaType, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, +import Type ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, splitFunTys, splitForAllTys, mkPredTy @@ -256,8 +256,8 @@ mkDataConWrapId data_con (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con all_tyvars = tyvars ++ ex_tyvars - dict_tys = mkDictTys theta - ex_dict_tys = mkDictTys ex_theta + dict_tys = mkPredTys theta + ex_dict_tys = mkPredTys ex_theta all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys result_ty = mkTyConApp tycon (mkTyVarTys tyvars) @@ -360,8 +360,8 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id tycon_theta = tyConTheta tycon -- The context on the data decl -- eg data (Eq a, Ord b) => T a b = ... - dict_tys = [mkDictTy cls tys | (cls, tys) <- tycon_theta, - needed_dict (cls, tys)] + dict_tys = [mkPredTy pred | pred <- tycon_theta, + needed_dict pred] needed_dict pred = or [ pred `elem` (dataConTheta dc) | (DataAlt dc, _, _) <- the_alts] n_dict_tys = length dict_tys @@ -632,9 +632,6 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) - info = noCafNoTyGenIdInfo - -- Type is wired-in (see comment at TcClassDcl.tcClassSig), - -- so do not generalise it {- 1 dec 99: disable the Mark Jones optimisation for the sake of compatibility with Hugs. diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index cffa095..90a3ead 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -28,7 +28,7 @@ module Subst ( -- Type stuff mkTyVarSubst, mkTopTyVarSubst, - substTy, substClasses, substTheta, + substTy, substTheta, -- Expression stuff substExpr, substIdInfo @@ -43,7 +43,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, ) import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( ThetaType, PredType(..), ClassContext, +import Type ( ThetaType, PredType(..), tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy ) import VarSet @@ -392,19 +392,14 @@ substTy :: Subst -> Type -> Type substTy subst ty | isEmptySubst subst = ty | otherwise = subst_ty subst ty -substClasses :: TyVarSubst -> ClassContext -> ClassContext -substClasses subst theta - | isEmptySubst subst = theta - | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta] - substTheta :: TyVarSubst -> ThetaType -> ThetaType substTheta subst theta | isEmptySubst subst = theta | otherwise = map (substPred subst) theta substPred :: TyVarSubst -> PredType -> PredType -substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys) -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 (IParam n ty) = IParam n (subst_ty subst ty) subst_ty subst ty = go ty diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 7e1f46d..6736153 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -30,7 +30,7 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, NamedThing(..), ) import Type ( repType, splitTyConApp_maybe, - tyConAppTyCon, splitFunTys, splitForAllTys, + splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, mkFunTy, splitAppTy, applyTy, funResultTy ) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 354180d..a37e27d 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -27,7 +27,7 @@ module HsTypes ( #include "HsVersions.h" import Class ( FunDep ) -import Type ( Type, Kind, PredType(..), ClassContext, +import Type ( Type, Kind, ThetaType, PredType(..), splitSigmaTy, liftedTypeKind ) import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation @@ -52,8 +52,8 @@ This is the syntax for types as seen in type signatures. \begin{code} type HsContext name = [HsPred name] -data HsPred name = HsPClass name [HsType name] - | HsPIParam name (HsType name) +data HsPred name = HsClassP name [HsType name] + | HsIParam name (HsType name) data HsType name = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures @@ -123,8 +123,8 @@ mkHsForAllTy mtvs1 [] (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty -mkHsDictTy cls tys = HsPredTy (HsPClass cls tys) -mkHsIParamTy v ty = HsPredTy (HsPIParam v ty) +mkHsDictTy cls tys = HsPredTy (HsClassP cls tys) +mkHsIParamTy v ty = HsPredTy (HsIParam v ty) data HsTyVarBndr name = UserTyVar name @@ -162,8 +162,8 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind instance Outputable name => Outputable (HsPred name) where - ppr (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys) - ppr (HsPIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty] + ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys) + ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty] pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc pprHsTyVarBndr name kind | kind == liftedTypeKind = ppr name @@ -324,11 +324,11 @@ toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty) -- **! consider dropping usMany annotations ToDo KSW 2000-10 -toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys) -toHsPred (IParam n ty) = HsPIParam (getName n) (toHsType ty) +toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys) +toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty) -toHsContext :: ClassContext -> HsContext Name -toHsContext cxt = [HsPClass (getName cls) (map toHsType tys) | (cls,tys) <- cxt] +toHsContext :: ThetaType -> HsContext Name +toHsContext theta = map toHsPred theta toHsFDs :: [FunDep TyVar] -> [FunDep Name] toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds] @@ -438,9 +438,9 @@ eq_hsType env ty1 ty2 = False eq_hsContext env a b = eqListBy (eq_hsPred env) a b ------------------- -eq_hsPred env (HsPClass c1 tys1) (HsPClass c2 tys2) +eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2) = c1 == c2 && eq_hsTypes env tys1 tys2 -eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2) +eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2) = n1 == n2 && eq_hsType env ty1 ty2 eq_hsPred env _ _ = False diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 7b8715e..901b7bb 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -17,7 +17,7 @@ import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, ) import Class ( Class, classTyCon ) import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, + isUnLiftedType, isTyVarTy, mkTyVarTy, predRepTy, splitForAllTys, splitFunTys, applyTy, applyTys ) import TypeRep ( Type(..) ) @@ -92,11 +92,11 @@ importsBinds :: [StgBinding] -> ImportsInfo importsBinds binds = unionImpInfos (map importsBind binds) importsBind :: StgBinding -> ImportsInfo -importsBind (StgNonRec b rhs) = importsRhs rhs `unionImpInfo` importsVar b -importsBind (StgRec pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs) +importsBind (StgNonRec _ b rhs) = importsRhs rhs `unionImpInfo` importsVar b +importsBind (StgRec _ pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs) importsRhs (StgRhsCon _ con args) = importsDataCon con `unionImpInfo` importsStgArgs args -importsRhs (StgRhsClosure _ _ srt _ upd args body) = importsExpr body `unionImpInfo` importsVars args +importsRhs (StgRhsClosure _ _ _ upd args body) = importsExpr body `unionImpInfo` importsVars args importsExpr :: StgExpr -> ImportsInfo importsExpr (StgLit l) = emptyImpInfo @@ -237,8 +237,8 @@ pprIlxDataCon env dcon = \begin{code} ilxBindClosures :: IlxEnv -> StgBinding -> SDoc -ilxBindClosures env (StgNonRec b rhs) = ilxRhsClosures env (b,rhs) -ilxBindClosures env (StgRec pairs) +ilxBindClosures env (StgNonRec _ b rhs) = ilxRhsClosures env (b,rhs) +ilxBindClosures env (StgRec _ pairs) = vcat (map (ilxRhsClosures new_env) pairs) where new_env = extendIlxEnvWithBinds env pairs @@ -247,7 +247,7 @@ ilxBindClosures env (StgRec pairs) ilxRhsClosures env (bndr, StgRhsCon _ _ _) = empty -ilxRhsClosures env (bndr, StgRhsClosure _ _ _ fvs upd args rhs) +ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) = vcat [ilxExprClosures next_env rhs, empty $$ line, @@ -375,8 +375,8 @@ ilxCCallArgLocals env arg@(StgVarArg v) | pinCCallArg v = [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)] ilxCCallArgLocals _ _ | otherwise = [] -ilxBindLocals env (StgNonRec b rhs) = [(LocalId b,Just (env, rhs))] -ilxBindLocals env (StgRec pairs) = map (\(x,y) -> (LocalId x,Just (env, y))) pairs +ilxBindLocals env (StgNonRec _ b rhs) = [(LocalId b,Just (env, rhs))] +ilxBindLocals env (StgRec _ pairs) = map (\(x,y) -> (LocalId x,Just (env, y))) pairs ilxAltsLocals env (StgAlgAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts) ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts) @@ -481,10 +481,10 @@ ilxExpr eenv@(IlxEEnv env _) (StgPrimApp primop args ret_ty) sequel --BEGIN TEMPORARY -- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t" -- I think would be subsumed by a general treatmenet of let-no-rec bindings?? -ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel +ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ fvs upd [] rhs)) (StgApp fun [])) sequel | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? = ilxExpr eenv rhs sequel -ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel +ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ fvs upd [] rhs)) (StgApp fun [])) sequel | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? = ilxExpr eenv rhs sequel --END TEMPORARY @@ -697,8 +697,8 @@ ilxFunApp env fun args tail_call where known_clo = case lookupIlxBindEnv env fun of - Just (place, StgRhsClosure _ _ _ _ Updatable _ _) -> Nothing - Just (place, StgRhsClosure _ _ _ fvs _ args _) -> Just (place,fun,args,fvs) + Just (place, StgRhsClosure _ _ _ Updatable _ _) -> Nothing + Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs) _ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing -- Push as many arguments as ILX allows us to in one go. @@ -848,7 +848,7 @@ ilxRhs env rec (bndr, StgRhsCon _ con args) text "stloc" <+> pprId bndr ] -ilxRhs env rec (bndr, StgRhsClosure _ _ _ fvs upd args rhs) +ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) = -- Assume .closure v(int64,!A) { -- .apply (int32) (B) { ... } -- } @@ -872,7 +872,7 @@ ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recur ilxFixupRec env rec (bndr, StgRhsCon _ con args) = text "// no recursive fixup" -ilxFixupRec env rec (bndr, StgRhsClosure _ _ _ fvs upd args rhs) +ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) = vcat [vcat (map fixFv rec)] where fixFv recid = if elem recid fvs then @@ -889,11 +889,11 @@ ilxFixupRec env rec (bndr, StgRhsClosure _ _ _ fvs upd args rhs) -- Code for a top-level binding in a module ilxPairs binds = concat (map ilxPairs1 binds) -ilxPairs1 (StgNonRec bndr rhs) = [(bndr,rhs)] -ilxPairs1 (StgRec pairs) = pairs +ilxPairs1 (StgNonRec _ bndr rhs) = [(bndr,rhs)] +ilxPairs1 (StgRec _ pairs) = pairs -ilxRecIds1 (StgNonRec bndr rhs) = [] -ilxRecIds1 (StgRec pairs) = map fst pairs +ilxRecIds1 (StgNonRec _ bndr rhs) = [] +ilxRecIds1 (StgRec _ pairs) = map fst pairs --------------------------------------------- -- Code for a top-level binding in a module @@ -921,7 +921,7 @@ isArg m _ = False ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc ---ilxTopBind mod env (StgNonRec bndr rhs) = +--ilxTopBind mod env (StgNonRec _ bndr rhs) = --ilxTopRhs env (bndr,rhs) ilxTopBind mod env pairs = vcat [text ".class" <+> pprId mod, @@ -940,7 +940,7 @@ ilxTopBind mod env pairs = --ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr -- = empty -ilxTopRhs mod env (bndr, StgRhsClosure _ _ _ fvs upd args rhs) +ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs) = vcat [vcat (map (pushId env) free_vs), (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))), text "newclo" <+> pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs), @@ -960,7 +960,7 @@ ilxTopRhs mod env (bndr, StgRhsCon _ data_con args) pprFieldRef env (mod,ty,id) = pprIlxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id -ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _ _) +ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _) = text ".field public static " <+> pprIlxTypeL env bndTy <+> pprId bndr where bndTy = idIlxRepType bndr @@ -1091,6 +1091,7 @@ deepIlxRepType (TyConApp tc tys) deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty) deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty +deepIlxRepType (PredTy p) = deepIlxRepType (predRepTy p) deepIlxRepType ty@(TyVarTy tv) = ty idIlxRepType id = deepIlxRepType (idType id) diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 1e33654..33357fc 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -35,6 +35,7 @@ import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) import TmpFiles ( newTempName ) import IO ( IOMode(..), hClose, openFile, Handle ) +import IO ( hPutStr, stderr) -- Debugging \end{code} @@ -81,7 +82,8 @@ codeOutput dflags mod_name tycons core_binds stg_binds doOutput :: String -> (Handle -> IO ()) -> IO () doOutput filenm io_action - = (do handle <- openFile filenm WriteMode + = (do hPutStr stderr ("Writing to" ++ filenm) + handle <- openFile filenm WriteMode io_action handle hClose handle) `catch` (\err -> pprPanic "Failed to open or write code output file" diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index f568672..2b69fa7 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.53 2001/03/06 15:00:25 rrt Exp $ +-- $Id: DriverPipeline.hs,v 1.54 2001/03/13 14:58:26 simonpj Exp $ -- -- GHC Driver -- @@ -884,7 +884,7 @@ compile ghci_mode summary source_unchanged old_iface hst hit pcs = do HscC -> newTempName (phaseInputExt HCc) HscJava -> newTempName "java" -- ToDo #ifdef ILX - HscILX -> newTempName (phaseInputExt Ilx) + HscILX -> newTempName "ilx" -- ToDo #endif HscInterpreted -> return (error "no output file") diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index d0d3419..969ca93 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -130,9 +130,9 @@ checkContext t checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName) checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (HsPClass t args) + = returnP (HsClassP t args) checkPred (HsAppTy l r) args = checkPred l (r:args) -checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty) +checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty) checkPred _ _ = parseError "Illegal class assertion" checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 1dd7c00..ea34147 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -149,8 +149,8 @@ extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty) extract_ctxt ctxt acc = foldr extract_pred acc ctxt -extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys -extract_pred (HsPIParam n ty) acc = extract_ty ty acc +extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys +extract_pred (HsIParam n ty) acc = extract_ty ty acc extract_tys tys = foldr extract_ty [] tys diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 961325a..f67ee06 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -111,7 +111,7 @@ import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, splitTyConApp_maybe, repType, - TauType, ClassContext ) + TauType, ThetaType ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) import PrelNames import CmdLineOpts @@ -197,7 +197,7 @@ mk_tc_gen_info mod tc_uniq tc_name tycon name1 = mkWiredInName mod occ_name1 fn1_key name2 = mkWiredInName mod occ_name2 fn2_key -pcDataCon :: Name -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon +pcDataCon :: Name -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon -- The unique is the first of two free uniques; -- the first is used for the datacon itself and the worker; -- the second is used for the wrapper. diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 7fa4cd3..e4bcf4b 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -524,8 +524,8 @@ context_list1 : class { [$1] } | class ',' context_list1 { $1 : $3 } class :: { HsPred RdrName } -class : qcls_name atypes { (HsPClass $1 $2) } - | ipvar_name '::' type { (HsPIParam $1 $3) } +class : qcls_name atypes { (HsClassP $1 $2) } + | ipvar_name '::' type { (HsIParam $1 $3) } types0 :: { [RdrNameHsType] {- Zero or more -} } types0 : {- empty -} { [ ] } diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 04531ed..80627db 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -97,9 +97,9 @@ extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNa -- You don't import or export implicit parameters, -- so don't mention the IP names -extractHsPredTyNames (HsPClass cls tys) +extractHsPredTyNames (HsClassP cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys -extractHsPredTyNames (HsPIParam n ty) +extractHsPredTyNames (HsIParam n ty) = extractHsTyNames ty \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index fe24db1..491e4bf 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -651,19 +651,19 @@ rnContext doc ctxt (naughtyCCallContextErr pred') `thenRn_` returnRn pred' - bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys + bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys bad_pred other = False -rnPred doc (HsPClass clas tys) +rnPred doc (HsClassP clas tys) = lookupOccRn clas `thenRn` \ clas_name -> rnHsTypes doc tys `thenRn` \ tys' -> - returnRn (HsPClass clas_name tys') + returnRn (HsClassP clas_name tys') -rnPred doc (HsPIParam n ty) +rnPred doc (HsIParam n ty) = newIPName n `thenRn` \ name -> rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsPIParam name ty') + returnRn (HsIParam name ty') \end{code} \begin{code} @@ -893,7 +893,7 @@ dupClassAssertWarn ctxt (assertion : dups) ptext SLIT("in the context:")], nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] -naughtyCCallContextErr (HsPClass clas _) +naughtyCCallContextErr (HsClassP clas _) = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), ptext SLIT("in a context")] \end{code} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index efe9eed..ba81958 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -9,15 +9,15 @@ module Inst ( plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, Inst, - pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, + pprInst, pprInsts, pprInstsInFull, tidyInsts, - newDictsFromOld, newDicts, newClassDicts, + newDictsFromOld, newDicts, newMethod, newMethodWithGivenTy, newOverloadedLit, newIPDict, tcInstId, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys, getIPs, - predsOfInsts, + predsOfInsts, predsOfInst, lookupInst, lookupSimpleInst, LookupInstResult(..), @@ -25,7 +25,7 @@ module Inst ( isTyVarDict, isStdClassTyVarDict, isMethodFor, instBindingRequired, instCanBeGeneralised, - zonkInst, zonkInsts, + zonkInst, zonkInsts, instToId, InstOrigin(..), InstLoc, pprInstLoc @@ -41,27 +41,29 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) -import TcType ( TcThetaType, TcClassContext, +import TcType ( TcThetaType, TcType, TcTauType, TcTyVarSet, - zonkTcType, zonkTcTypes, + zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType ) import CoreFVs ( idFreeTyVars ) import Class ( Class ) import Id ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) -import Name ( mkDictOcc, mkMethodOcc, getOccName, mkLocalName ) +import Name ( mkMethodOcc, getOccName ) import NameSet ( NameSet ) import PprType ( pprPred ) -import Type ( Type, PredType(..), +import Type ( Type, PredType(..), ThetaType, isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, splitForAllTys, splitSigmaTy, funArgTy, - splitMethodTy, splitRhoTy, classesOfPreds, - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tidyOpenType, tidyOpenTypes, predMentionsIPs + splitMethodTy, splitRhoTy, + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, + predMentionsIPs, isClassPred, isTyVarClassPred, + getClassPredTys, getClassPredTys_maybe, mkPredName, + tidyType, tidyTypes, tidyFreeTyVars ) import Subst ( emptyInScopeSet, mkSubst, - substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst + substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst ) import Literal ( inIntRange ) import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) ) @@ -72,7 +74,7 @@ import TysWiredIn ( isIntTy, isIntegerTy ) import PrelNames( fromIntegerName, fromRationalName ) -import Util ( thenCmp, zipWithEqual, mapAccumL ) +import Util ( thenCmp, zipWithEqual ) import Bag import Outputable \end{code} @@ -202,7 +204,7 @@ instLoc (Dict _ _ loc) = loc instLoc (Method _ _ _ _ _ loc) = loc instLoc (LitInst _ _ _ loc) = loc -getDictClassTys (Dict _ (Class clas tys) _) = (clas, tys) +getDictClassTys (Dict _ pred _) = getClassPredTys pred predsOfInsts :: [Inst] -> [PredType] predsOfInsts insts = concatMap predsOfInst insts @@ -238,8 +240,12 @@ isDict (Dict _ _ _) = True isDict other = False isClassDict :: Inst -> Bool -isClassDict (Dict _ (Class _ _) _) = True -isClassDict other = False +isClassDict (Dict _ pred _) = isClassPred pred +isClassDict other = False + +isTyVarDict :: Inst -> Bool +isTyVarDict (Dict _ pred _) = isTyVarClassPred pred +isTyVarDict other = False isMethod :: Inst -> Bool isMethod (Method _ _ _ _ _ _) = True @@ -256,14 +262,9 @@ instMentionsIPs (Dict _ pred _) ip_names = pred `predMentionsIPs` ip_na instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta instMentionsIPs other ip_names = False -isTyVarDict :: Inst -> Bool -isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys -isTyVarDict other = False - -isStdClassTyVarDict (Dict _ (Class clas [ty]) _) - = isStandardClass clas && isTyVarTy ty -isStdClassTyVarDict other - = False +isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of + Just (clas, [ty]) -> isStandardClass clas && isTyVarTy ty + other -> False \end{code} Two predicates which deal with the case where class constraints don't @@ -273,13 +274,13 @@ must be witnessed by an actual binding; the second tells whether an \begin{code} instBindingRequired :: Inst -> Bool -instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas) -instBindingRequired (Dict _ (IParam _ _) _) = False -instBindingRequired other = True +instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas) +instBindingRequired (Dict _ (IParam _ _) _) = False +instBindingRequired other = True instCanBeGeneralised :: Inst -> Bool -instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas) -instCanBeGeneralised other = True +instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas) +instCanBeGeneralised other = True \end{code} @@ -297,13 +298,8 @@ newDicts orig theta = tcGetInstLoc orig `thenNF_Tc` \ loc -> newDictsAtLoc loc theta -newClassDicts :: InstOrigin - -> TcClassContext - -> NF_TcM [Inst] -newClassDicts orig theta = newDicts orig (map (uncurry Class) theta) - -newDictsFromOld :: Inst -> TcClassContext -> NF_TcM [Inst] -newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc (map (uncurry Class) theta) +newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst] +newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta -- Local function, similar to newDicts, -- but with slightly different interface @@ -314,10 +310,7 @@ newDictsAtLoc inst_loc@(_,loc,_) theta = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta) where - mk_dict uniq pred = Dict (mkLocalId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc - - mk_dict_name uniq (Class cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc - mk_dict_name uniq (IParam name ty) = name + mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc newIPDict orig name ty = tcGetInstLoc orig `thenNF_Tc` \ inst_loc -> @@ -470,17 +463,9 @@ but doesn't do the same for any of the Ids in an Inst. There's no need, and it's a lot of extra work. \begin{code} -zonkPred :: TcPredType -> NF_TcM TcPredType -zonkPred (Class clas tys) - = zonkTcTypes tys `thenNF_Tc` \ new_tys -> - returnNF_Tc (Class clas new_tys) -zonkPred (IParam n ty) - = zonkTcType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (IParam n new_ty) - zonkInst :: Inst -> NF_TcM Inst zonkInst (Dict id pred loc) - = zonkPred pred `thenNF_Tc` \ new_pred -> + = zonkTcPredType pred `thenNF_Tc` \ new_pred -> returnNF_Tc (Dict id new_pred loc) zonkInst (Method m id tys theta tau loc) @@ -528,36 +513,20 @@ pprInst m@(Method u id tys theta tau loc) show_uniq u, ppr (instToId m) -}] -tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType) -tidyPred env (Class clas tys) - = (env', Class clas tys') - where - (env', tys') = tidyOpenTypes env tys -tidyPred env (IParam n ty) - = (env', IParam n ty') - where - (env', ty') = tidyOpenType env ty +show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") -tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst) -tidyInst env (LitInst u lit ty loc) - = (env', LitInst u lit ty' loc) - where - (env', ty') = tidyOpenType env ty +tidyInst :: TidyEnv -> Inst -> Inst +tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc +tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc +tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc -tidyInst env (Dict u pred loc) - = (env', Dict u pred' loc) +tidyInsts :: [Inst] -> (TidyEnv, [Inst]) +-- This function doesn't assume that the tyvars are in scope +-- so it works like tidyOpenType, returning a TidyEnv +tidyInsts insts + = (env, map (tidyInst env) insts) where - (env', pred') = tidyPred env pred - -tidyInst env (Method u id tys theta tau loc) - = (env', Method u id tys' theta tau loc) - -- Leave theta, tau alone cos we don't print them - where - (env', tys') = tidyOpenTypes env tys - -tidyInsts env insts = mapAccumL tidyInst env insts - -show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") + env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts) \end{code} @@ -578,7 +547,7 @@ lookupInst :: Inst -- Dictionaries -lookupInst dict@(Dict _ (Class clas tys) loc) +lookupInst dict@(Dict _ (ClassP clas tys) loc) = tcGetInstEnv `thenNF_Tc` \ inst_env -> case lookupInstEnv inst_env clas tys of @@ -667,16 +636,15 @@ ambiguous dictionaries. \begin{code} lookupSimpleInst :: Class -> [Type] -- Look up (c,t) - -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s + -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s lookupSimpleInst clas tys = tcGetInstEnv `thenNF_Tc` \ inst_env -> case lookupInstEnv inst_env clas tys of FoundInst tenv dfun - -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta')) + -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta)) where (_, theta, _) = splitSigmaTy (idType dfun) - theta' = classesOfPreds theta other -> returnNF_Tc Nothing \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 7f8ffda..3994e93 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -31,7 +31,7 @@ import TcEnv ( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo, tcExtendLocalValEnv, tcExtendTyVarEnv ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) -import TcMonoType ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig ) +import TcMonoType ( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcType ( TcType, TcTyVar, tcInstTyVars ) import TcMonad @@ -47,7 +47,7 @@ import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts ) import NameSet ( emptyNameSet ) import Outputable -import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred, +import Type ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred, splitTyConApp_maybe, isTyVarTy ) import Var ( TyVar ) @@ -148,7 +148,7 @@ tcClassDecl1 is_rec rec_env -- MAKE THE CLASS DETAILS let (op_tys, op_items) = unzip sig_stuff - sc_tys = mkDictTys sc_theta + sc_tys = mkPredTys sc_theta dict_component_tys = sc_tys ++ op_tys dict_con = mkDataCon datacon_name @@ -219,23 +219,20 @@ checkGenericClassIsUnary clas dm_env tcSuperClasses :: RecFlag -> Bool -> Class -> RenamedContext -- class context -> [Name] -- Names for superclass selectors - -> TcM (ClassContext, -- the superclass context - [Id]) -- superclass selector Ids + -> TcM (ThetaType, -- the superclass context + [Id]) -- superclass selector Ids tcSuperClasses is_rec gla_exts clas context sc_sel_names - = -- Check the context. + = ASSERT( length context == length sc_sel_names ) + -- Check the context. -- The renamer has already checked that the context mentions -- only the type variable of the class decl. -- For std Haskell check that the context constrains only tyvars - (if gla_exts then - returnTc () - else - mapTc_ check_constraint context - ) `thenTc_` + mapTc_ check_constraint context `thenTc_` -- Context is already kind-checked - tcRecClassContext is_rec context `thenTc` \ sc_theta -> + tcRecTheta is_rec context `thenTc` \ sc_theta -> let sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] in @@ -243,8 +240,10 @@ tcSuperClasses is_rec gla_exts clas context sc_sel_names returnTc (sc_theta, sc_sel_ids) where - check_constraint sc@(HsPClass c tys) - = checkTc (all is_tyvar tys) (superClassErr clas sc) + check_constraint sc = checkTc (ok sc) (superClassErr clas sc) + ok (HsClassP c tys) | gla_exts = True + | otherwise = all is_tyvar tys + ok (HsIParam _ _) = False -- Never legal is_tyvar (HsTyVar _) = True is_tyvar other = False diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index b28b07d..c0330d4 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -17,7 +17,7 @@ import TcMonoType ( tcHsType ) import TcSimplify ( tcSimplifyCheckThetas ) import TysWiredIn ( integerTy, doubleTy ) -import Type ( Type ) +import Type ( Type, mkClassPred ) import PrelNames ( numClassName ) import Outputable import HscTypes ( TyThing(..) ) @@ -57,7 +57,7 @@ tc_defaults [DefaultDecl mono_tys locn] tcAddErrCtxt defaultDeclCtxt $ tcSimplifyCheckThetas [{- Nothing given -}] - [ (num_class, [ty]) | ty <- tau_tys ] `thenTc_` + [ mkClassPred num_class [ty] | ty <- tau_tys ] `thenTc_` returnTc tau_tys diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 103af50..298d2dd 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -44,8 +44,8 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, TyCon ) -import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp, - isUnLiftedType ) +import Type ( TauType, ThetaType, PredType, mkTyVarTys, mkTyConApp, + isUnLiftedType, mkClassPred ) import Var ( TyVar ) import PrelNames import Util ( zipWithEqual, sortLt ) @@ -143,9 +143,7 @@ type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs) -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the RHS -type DerivRhs = [(Class, [TauType])] -- Same as a ThetaType! - --[PredType] -- ... | Class Class [Type==TauType] - +type DerivRhs = ThetaType type DerivSoln = DerivRhs \end{code} @@ -316,7 +314,7 @@ makeDerivEqns tycl_decls offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys mk_constraints data_con - = [ (clas, [arg_ty]) + = [ mkClassPred clas [arg_ty] | arg_ty <- dataConArgTys data_con tyvar_tys, not (isUnLiftedType arg_ty) -- No constraints for unlifted types? ] @@ -436,10 +434,9 @@ add_solns dflags inst_env_in eqns solns -- They'll appear later, when we do the top-level extendInstEnvs mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta - = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] - (map pair2PredType theta) - - pair2PredType (clas, tautypes) = Class clas tautypes + = mkDictFunId dfun_name clas tyvars + [mkTyConApp tycon (mkTyVarTys tyvars)] + theta \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 8cfac29..809abce 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -48,13 +48,13 @@ import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe ) import IdInfo ( vanillaIdInfo ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet -import Type ( Type, +import Type ( Type, ThetaType, tyVarsOfTypes, splitDFunTy, getDFunTyKey, tyConAppTyCon ) import DataCon ( DataCon ) import TyCon ( TyCon ) -import Class ( Class, ClassOpItem, ClassContext ) +import Class ( Class, ClassOpItem ) import Name ( Name, OccName, NamedThing(..), nameOccName, getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom @@ -173,8 +173,8 @@ getTcGEnv (TcEnv { tcGEnv = genv }) = genv -- This data type is used to help tie the knot -- when type checking type and class declarations data TyThingDetails = SynTyDetails Type - | DataTyDetails ClassContext [DataCon] [Id] - | ClassDetails ClassContext [Id] [ClassOpItem] DataCon + | DataTyDetails ThetaType [DataCon] [Id] + | ClassDetails ThetaType [Id] [ClassOpItem] DataCon \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 37fdce6..ebc25af 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -20,7 +20,7 @@ import BasicTypes ( RecFlag(..) ) import Inst ( InstOrigin(..), LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newIPDict, - newDicts, newClassDicts, + newDicts, instToId, tcInstId ) import TcBinds ( tcBindsAndThen ) @@ -44,14 +44,14 @@ import DataCon ( dataConFieldLabels, dataConSig, import Name ( Name ) import Type ( mkFunTy, mkAppTy, mkTyConTy, splitFunTy_maybe, splitFunTys, - mkTyConApp, splitSigmaTy, + mkTyConApp, splitSigmaTy, mkClassPred, isTauTy, tyVarsOfType, tyVarsOfTypes, isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe, liftedTypeKind, openTypeKind, mkArrowKind, tidyOpenType ) import TyCon ( TyCon, tyConTyVars ) -import Subst ( mkTopTyVarSubst, substClasses, substTy ) +import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( elemVarSet ) import TysWiredIn ( boolTy, mkListTy, listTyCon ) import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) @@ -268,8 +268,8 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) - = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) - [(cCallableClass, [arg_ty])] `thenNF_Tc` \ arg_dicts -> + = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) + [mkClassPred cCallableClass [arg_ty]] `thenNF_Tc` \ arg_dicts -> returnNF_Tc arg_dicts -- Actually a singleton bag result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -} @@ -295,7 +295,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty -- Construct the extra insts, which encode the -- constraints on the argument and result types. mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> - newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ ccres_dict -> + newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenNF_Tc` \ ccres_dict -> returnTc (HsCCall lbl args' may_gc is_asm io_result_ty, mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie) \end{code} @@ -532,9 +532,9 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let (tyvars, theta, _, _, _, _) = dataConSig (head data_cons) inst_env = mkTopTyVarSubst tyvars result_inst_tys - theta' = substClasses inst_env theta + theta' = substTheta inst_env theta in - newClassDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts -> + newDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts -> -- Phew! returnTc (RecordUpdOut record_expr' result_record_ty (map instToId dicts) rbinds', @@ -925,8 +925,8 @@ Overloaded literals. tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE) tcLit (HsLitLit s _) res_ty = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> - newClassDicts (LitLitOrigin (_UNPK_ s)) - [(cCallableClass,[res_ty])] `thenNF_Tc` \ dicts -> + newDicts (LitLitOrigin (_UNPK_ s)) + [mkClassPred cCallableClass [res_ty]] `thenNF_Tc` \ dicts -> returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts) tcLit lit res_ty diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 53e30cc..b658e93 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -25,7 +25,7 @@ import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad import TcType ( tcInstType ) import Inst ( InstOrigin(..), - newDicts, newClassDicts, instToId, + newDicts, instToId, LIE, mkLIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) import TcEnv ( TcEnv, tcExtendGlobalValEnv, @@ -60,9 +60,9 @@ import Type ( splitDFunTy, isTyVarTy, splitTyConApp_maybe, splitDictTy, splitForAllTys, tyVarsOfTypes, mkClassPred, mkTyVarTy, - getClassTys_maybe + isTyVarClassPred, inheritablePred ) -import Subst ( mkTopTyVarSubst, substClasses ) +import Subst ( mkTopTyVarSubst, substTheta ) import VarSet ( varSetElems ) import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) @@ -527,7 +527,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, sel_names = [idName sel_id | (sel_id, _) <- op_items] -- Instantiate the super-class context with inst_tys - sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta + sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta -- Find any definitions in monobinds that aren't from the class bad_bndrs = collectMonoBinders monobinds `minusList` sel_names @@ -541,9 +541,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` -- Create dictionary Ids from the specified instance contexts. - newClassDicts origin sc_theta' `thenNF_Tc` \ sc_dicts -> - newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts -> - newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ [this_dict] -> + newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts -> + newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts -> + newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] -> tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( tcExtendGlobalValEnv dm_ids ( @@ -668,15 +668,16 @@ checkInstValidity dflags theta clas inst_tys [err | pred <- theta, err <- checkInstConstraint dflags pred] checkInstConstraint dflags pred - | dopt Opt_AllowUndecidableInstances dflags - = [] + -- Checks whether a predicate is legal in the + -- context of an instance declaration + | ok = [] + | otherwise = [instConstraintErr pred] + where + ok = inheritablePred pred && + (isTyVarClassPred pred || arbitrary_preds_ok) - | Just (clas,tys) <- getClassTys_maybe pred, - all isTyVarTy tys - = [] + arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags - | otherwise - = [instConstraintErr pred] checkInstHead dflags theta clas inst_taus | -- CCALL CHECK diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index d9fb249..b8adcc9 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -2,7 +2,7 @@ module TcMonad( TcType, TcTauType, TcPredType, TcThetaType, TcRhoType, - TcTyVar, TcTyVarSet, TcClassContext, + TcTyVar, TcTyVarSet, TcKind, TcM, NF_TcM, TcDown, TcEnv, @@ -55,7 +55,7 @@ import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, War import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) -import Class ( Class, ClassContext ) +import Class ( Class ) import Name ( Name ) import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar ) import VarEnv ( TidyEnv, emptyTidyEnv ) @@ -94,7 +94,6 @@ type TcType = Type -- A TcType can have mutable type variables -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a -type TcClassContext = ClassContext type TcPredType = PredType type TcThetaType = ThetaType type TcRhoType = RhoType diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index c86db59..445c519 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -6,7 +6,7 @@ \begin{code} module TcMonoType ( tcHsType, tcHsRecType, tcIfaceType, tcHsSigType, tcHsLiftedSigType, - tcRecClassContext, checkAmbiguity, + tcRecTheta, checkAmbiguity, -- Kind checking kcHsTyVar, kcHsTyVars, mkTyClTyVars, @@ -46,7 +46,7 @@ import Type ( Type, Kind, PredType(..), ThetaType, SigmaType, TauType, mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, tyVarsOfType, tyVarsOfPred, mkForAllTys, - classesOfPreds, isUnboxedTupleType, isForAllTy + isUnboxedTupleType, isForAllTy, isIPPred ) import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) @@ -57,7 +57,7 @@ import VarEnv import VarSet import ErrUtils ( Message ) import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind ) -import Class ( ClassContext, classArity, classTyCon ) +import Class ( classArity, classTyCon ) import Name ( Name ) import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) import BasicTypes ( Boxity(..), RecFlag(..), isRec ) @@ -241,11 +241,11 @@ kcAppKind fun_kind arg_kind kcHsContext ctxt = mapTc_ kcHsPred ctxt kcHsPred :: RenamedHsPred -> TcM () -kcHsPred pred@(HsPIParam name ty) +kcHsPred pred@(HsIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ kcLiftedType ty -kcHsPred pred@(HsPClass cls tys) +kcHsPred pred@(HsClassP cls tys) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ kcClass cls `thenTc` \ kind -> mapTc kcHsType tys `thenTc` \ arg_kinds -> @@ -397,7 +397,7 @@ tc_type wimp_out full_ty@(HsForAllTy (Just tv_names) ctxt ty) kind_check = kcHsContext ctxt `thenTc_` kcHsType ty in tcHsTyVars tv_names kind_check $ \ tyvars -> - tc_context wimp_out ctxt `thenTc` \ theta -> + tcRecTheta wimp_out ctxt `thenTc` \ theta -> -- Context behaves like a function type -- This matters. Return-unboxed-tuple analysis can @@ -492,22 +492,17 @@ tc_fun_type name arg_tys Contexts ~~~~~~~~ \begin{code} -tcRecClassContext :: RecFlag -> RenamedContext -> TcM ClassContext +tcRecTheta :: RecFlag -> RenamedContext -> TcM ThetaType -- Used when we are expecting a ClassContext (i.e. no implicit params) -tcRecClassContext wimp_out context - = tc_context wimp_out context `thenTc` \ theta -> - returnTc (classesOfPreds theta) +tcRecTheta wimp_out context = mapTc (tc_pred wimp_out) context -tc_context :: RecFlag -> RenamedContext -> TcM ThetaType -tc_context wimp_out context = mapTc (tc_pred wimp_out) context - -tc_pred wimp_out assn@(HsPClass class_name tys) +tc_pred wimp_out assn@(HsClassP class_name tys) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ tc_arg_types wimp_out tys `thenTc` \ arg_tys -> tcLookupGlobal class_name `thenTc` \ thing -> case thing of AClass clas -> checkTc (arity == n_tys) err `thenTc_` - returnTc (Class clas arg_tys) + returnTc (ClassP clas arg_tys) where arity = classArity clas n_tys = length tys @@ -515,7 +510,7 @@ tc_pred wimp_out assn@(HsPClass class_name tys) other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name) -tc_pred wimp_out assn@(HsPIParam name ty) +tc_pred wimp_out assn@(HsIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ tc_arg_type wimp_out ty `thenTc` \ arg_ty -> returnTc (IParam name arg_ty) @@ -574,14 +569,12 @@ checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau not (ct_var `elemVarSet` extended_tau_vars) is_free ct_var = not (ct_var `elem` forall_tyvars) - check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_` - checkTc (is_ip pred || not all_free) (freeErr pred sigma_ty) + check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_` + checkTc (isIPPred pred || not all_free) (freeErr pred sigma_ty) where ct_vars = varSetElems (tyVarsOfPred pred) all_free = all is_free ct_vars any_ambig = is_source_polytype && any is_ambig ct_vars - is_ip (IParam _ _) = True - is_ip _ = False \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e6c6949..4d1a49d 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -15,7 +15,7 @@ import TcHsSyn ( TcPat, TcId ) import TcMonad import Inst ( InstOrigin(..), emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, - newMethod, newOverloadedLit, newDicts, newClassDicts + newMethod, newOverloadedLit, newDicts ) import Id ( mkLocalId ) import Name ( Name ) @@ -30,7 +30,7 @@ import DataCon ( dataConSig, dataConFieldLabels, dataConSourceArity ) import Type ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind ) -import Subst ( substTy, substClasses ) +import Subst ( substTy, substTheta ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) @@ -372,14 +372,14 @@ tcConstructor pat con_name pat_ty in tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) -> let - ex_theta' = substClasses tenv ex_theta + ex_theta' = substTheta tenv ex_theta arg_tys' = map (substTy tenv) arg_tys n_ex_tvs = length ex_tvs ex_tvs' = take n_ex_tvs all_tvs' result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args') in - newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts -> + newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts -> -- Check overall type matches unifyTauTy pat_ty result_ty `thenTc_` diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 2e6c240..c6317ce 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -9,6 +9,7 @@ module TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop, + tcSimplifyThetas, tcSimplifyCheckThetas, bindInstsOfLocalFuns ) where @@ -22,14 +23,14 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - tyVarsOfInst, predsOfInsts, + tyVarsOfInst, predsOfInsts, predsOfInst, isDict, isClassDict, isStdClassTyVarDict, isMethodFor, instToId, tyVarsOfInsts, instBindingRequired, instCanBeGeneralised, newDictsFromOld, instMentionsIPs, - getDictClassTys, getIPs, isTyVarDict, - instLoc, pprInst, zonkInst, tidyInst, tidyInsts, + getDictClassTys, isTyVarDict, + instLoc, pprInst, zonkInst, tidyInsts, Inst, LIE, pprInsts, pprInstsInFull, mkLIE, lieToList ) @@ -41,22 +42,23 @@ import TcUnify ( unifyTauTy ) import Id ( idType ) import Name ( Name ) import NameSet ( mkNameSet ) -import Class ( Class, classBigSig ) +import Class ( classBigSig ) import FunDeps ( oclose, grow, improve ) import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) -import Type ( Type, ClassContext, - mkTyVarTy, getTyVar, - isTyVarTy, splitSigmaTy, tyVarsOfTypes +import Type ( Type, ThetaType, PredType, mkClassPred, + mkTyVarTy, getTyVar, isTyVarClassPred, + splitSigmaTy, tyVarsOfPred, + getClassPredTys_maybe, isClassPred, isIPPred, + inheritablePred ) -import Subst ( mkTopTyVarSubst, substClasses, substTy ) -import PprType ( pprClassPred ) +import Subst ( mkTopTyVarSubst, substTheta, substTy ) import TysWiredIn ( unitTy ) import VarSet import FiniteMap import Outputable import ListSetOps ( equivClasses ) -import Util ( zipEqual, mapAccumL ) +import Util ( zipEqual ) import List ( partition ) import CmdLineOpts \end{code} @@ -453,7 +455,7 @@ with (Max Z (S x) y)! \begin{code} isFree qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs) -- Constrains no quantified vars - && null (getIPs inst) -- And no implicit parameter involved + && all inheritablePred (predsOfInst inst) -- And no implicit parameter involved -- (see "Notes on implicit parameters") \end{code} @@ -1129,7 +1131,7 @@ add_scs avails dict where (clas, tys) = getDictClassTys dict (tyvars, sc_theta, sc_sels, _) = classBigSig clas - sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta + sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses = case lookupFM avails sc_dict of @@ -1278,10 +1280,10 @@ disambigGroup dicts try_default (default_ty : default_tys) = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try -- default_tys instead - tcSimplifyCheckThetas [] thetas `thenTc` \ _ -> + tcSimplifyCheckThetas [] theta `thenTc` \ _ -> returnTc default_ty where - thetas = classes `zip` repeat [default_ty] + theta = [mkClassPred clas [default_ty] | clas <- classes] in -- See if any default works, and if so bind the type variable to it -- If not, add an AmbigErr @@ -1364,8 +1366,8 @@ a,b,c are type variables. This is required for the context of instance declarations. \begin{code} -tcSimplifyThetas :: ClassContext -- Wanted - -> TcM ClassContext -- Needed +tcSimplifyThetas :: ThetaType -- Wanted + -> TcM ThetaType -- Needed tcSimplifyThetas wanteds = doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts -> @@ -1376,10 +1378,10 @@ tcSimplifyThetas wanteds -- we expect an instance here -- For Haskell 98, check that all the constraints are of the form C a, -- where a is a type variable - bad_guys | glaExts = [ct | ct@(clas,tys) <- irreds, - isEmptyVarSet (tyVarsOfTypes tys)] - | otherwise = [ct | ct@(clas,tys) <- irreds, - not (all isTyVarTy tys)] + bad_guys | glaExts = [pred | pred <- irreds, + isEmptyVarSet (tyVarsOfPred pred)] + | otherwise = [pred | pred <- irreds, + not (isTyVarClassPred pred)] in if null bad_guys then returnTc irreds @@ -1393,8 +1395,8 @@ used with \tr{default} declarations. We are only interested in whether it worked or not. \begin{code} -tcSimplifyCheckThetas :: ClassContext -- Given - -> ClassContext -- Wanted +tcSimplifyCheckThetas :: ThetaType -- Given + -> ThetaType -- Wanted -> TcM () tcSimplifyCheckThetas givens wanteds @@ -1408,23 +1410,23 @@ tcSimplifyCheckThetas givens wanteds \begin{code} -type AvailsSimple = FiniteMap (Class,[Type]) Bool +type AvailsSimple = FiniteMap PredType Bool -- True => irreducible -- False => given, or can be derived from a given or from an irreducible -reduceSimple :: ClassContext -- Given - -> ClassContext -- Wanted - -> NF_TcM ClassContext -- Irreducible +reduceSimple :: ThetaType -- Given + -> ThetaType -- Wanted + -> NF_TcM ThetaType -- Irreducible reduceSimple givens wanteds = reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' -> - returnNF_Tc [ct | (ct,True) <- fmToList givens_fm'] + returnNF_Tc [pred | (pred,True) <- fmToList givens_fm'] where givens_fm = foldl addNonIrred emptyFM givens -reduce_simple :: (Int,ClassContext) -- Stack +reduce_simple :: (Int,ThetaType) -- Stack -> AvailsSimple - -> ClassContext + -> ThetaType -> NF_TcM AvailsSimple reduce_simple (n,stack) avails wanteds @@ -1434,32 +1436,36 @@ reduce_simple (n,stack) avails wanteds go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' -> go avails' ws -reduce_simple_help stack givens wanted@(clas,tys) +reduce_simple_help stack givens wanted | wanted `elemFM` givens = returnNF_Tc givens - | otherwise + | Just (clas, tys) <- getClassPredTys_maybe wanted = lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta -> - case maybe_theta of Nothing -> returnNF_Tc (addSimpleIrred givens wanted) Just theta -> reduce_simple stack (addNonIrred givens wanted) theta -addSimpleIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple -addSimpleIrred givens ct@(clas,tys) - = addSCs (addToFM givens ct True) ct + | otherwise + = returnNF_Tc (addSimpleIrred givens wanted) + +addSimpleIrred :: AvailsSimple -> PredType -> AvailsSimple +addSimpleIrred givens pred + = addSCs (addToFM givens pred True) pred -addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple -addNonIrred givens ct@(clas,tys) - = addSCs (addToFM givens ct False) ct +addNonIrred :: AvailsSimple -> PredType -> AvailsSimple +addNonIrred givens pred + = addSCs (addToFM givens pred False) pred -addSCs givens ct@(clas,tys) - = foldl add givens sc_theta +addSCs givens pred + | not (isClassPred pred) = givens + | otherwise = foldl add givens sc_theta where + Just (clas,tys) = getClassPredTys_maybe pred (tyvars, sc_theta_tmpl, _, _) = classBigSig clas - sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl + sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl - add givens ct@(clas, tys) + add givens ct = case lookupFM givens ct of Nothing -> -- Add it and its superclasses addSCs (addToFM givens ct False) ct @@ -1488,8 +1494,8 @@ addTopAmbigErrs dicts = mapNF_Tc complain tidy_dicts where fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet - (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts - complain d | not (null (getIPs d)) = addTopIPErr tidy_env d + (tidy_env, tidy_dicts) = tidyInsts dicts + complain d | any isIPPred (predsOfInst d) = addTopIPErr tidy_env d | not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d | otherwise = addAmbigErr tidy_env d @@ -1508,7 +1514,7 @@ addTopInstanceErr tidy_env tidy_dict addAmbigErrs dicts = mapNF_Tc (addAmbigErr tidy_env) tidy_dicts where - (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts + (tidy_env, tidy_dicts) = tidyInsts dicts addAmbigErr tidy_env tidy_dict = addInstErrTcM (instLoc tidy_dict) @@ -1526,7 +1532,7 @@ warnDefault dicts default_ty where -- Tidy them first - (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts + (_, tidy_dicts) = tidyInsts dicts -- Group the dictionaries by source location groups = equivClasses cmp tidy_dicts @@ -1575,7 +1581,7 @@ addNoInstanceErr what_doc givens dict | otherwise = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict) - (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens) + (tidy_env, tidy_dict:tidy_givens) = tidyInsts (dict:givens) -- Checks for the ambiguous case when we have overlapping instances ambig_overlap | isClassDict dict @@ -1589,8 +1595,8 @@ addNoInstanceErr what_doc givens dict addInstErrTcM (instLoc dict) (tidy_env, doc) -- Used for the ...Thetas variants; all top level -addNoInstErr (c,ts) - = addErrTc (ptext SLIT("No instance for") <+> quotes (pprClassPred c ts)) +addNoInstErr pred + = addErrTc (ptext SLIT("No instance for") <+> quotes (ppr pred)) reduceDepthErr n stack = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n, diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index b755fe0..de26ef9 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -412,7 +412,7 @@ tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d) mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name]) -mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsPClass c _ <- ctxt]) +mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt]) mkClassEdges other_decl = Nothing mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name]) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 60657db..bde6655 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -16,7 +16,7 @@ import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) import BasicTypes ( NewOrData(..), RecFlag, isRec ) -import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecClassContext, +import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecTheta, kcHsContext, kcHsSigType, kcHsLiftedSigType ) import TcEnv ( tcExtendTyVarEnv, @@ -25,7 +25,6 @@ import TcEnv ( tcExtendTyVarEnv, ) import TcMonad -import Class ( ClassContext ) import DataCon ( DataCon, mkDataCon, dataConFieldLabels, markedStrict, notMarkedStrict, markedUnboxed, dataConRepType ) @@ -35,9 +34,9 @@ import Var ( TyVar ) import Name ( Name, NamedThing(..) ) import Outputable import TyCon ( TyCon, isNewTyCon, tyConTyVars ) -import Type ( tyVarsOfTypes, splitFunTy, applyTys, +import Type ( tyVarsOfTypes, tyVarsOfPred, splitFunTy, applyTys, mkTyConApp, mkTyVarTys, mkForAllTys, - splitAlgTyConApp_maybe, Type + splitAlgTyConApp_maybe, Type, ThetaType ) import TysWiredIn ( unitTy ) import VarSet ( intersectVarSet, isEmptyVarSet ) @@ -80,7 +79,7 @@ tcTyDecl1 is_rec unf_env (TyData {tcdND = new_or_data, tcdCtxt = context, tcExtendTyVarEnv tyvars $ -- Typecheck the pieces - tcRecClassContext is_rec context `thenTc` \ ctxt -> + tcRecTheta is_rec context `thenTc` \ ctxt -> mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> tcRecordSelectors is_rec unf_env tycon data_cons `thenTc` \ sel_ids -> returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids) @@ -127,12 +126,12 @@ kcConDetails new_or_data ex_ctxt details -- going to remove the constructor while coercing it to a lifted type. -tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM DataCon +tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM DataCon tcConDecl is_rec new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) = tcAddSrcLoc src_loc $ tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars -> - tcRecClassContext is_rec ex_ctxt `thenTc` \ ex_theta -> + tcRecTheta is_rec ex_ctxt `thenTc` \ ex_theta -> case details of VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2] @@ -182,8 +181,8 @@ thinContext arg_tys ctxt = filter in_arg_tys ctxt where arg_tyvars = tyVarsOfTypes arg_tys - in_arg_tys (clas,tys) = not $ isEmptyVarSet $ - tyVarsOfTypes tys `intersectVarSet` arg_tyvars + in_arg_tys pred = not $ isEmptyVarSet $ + tyVarsOfPred pred `intersectVarSet` arg_tyvars getBangStrictness (Banged _) = markedStrict getBangStrictness (Unbanged _) = notMarkedStrict diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 73c183b..f332114 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -13,7 +13,7 @@ module TcType ( newTyVarTys, -- Int -> Kind -> NF_TcM [TcType] ----------------------------------------- - TcType, TcTauType, TcThetaType, TcRhoType, TcClassContext, + TcType, TcTauType, TcThetaType, TcRhoType, -- Find the type to which a type variable is bound tcPutTyVar, -- :: TcTyVar -> TcType -> NF_TcM TcType @@ -33,6 +33,7 @@ module TcType ( -------------------------------- zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, + zonkTcPredType, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv @@ -313,9 +314,9 @@ zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta zonkTcPredType :: TcPredType -> NF_TcM TcPredType -zonkTcPredType (Class c ts) = +zonkTcPredType (ClassP c ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts -> - returnNF_Tc (Class c new_ts) + returnNF_Tc (ClassP c new_ts) zonkTcPredType (IParam n t) = zonkTcType t `thenNF_Tc` \ new_t -> returnNF_Tc (IParam n new_t) @@ -446,8 +447,8 @@ zonkType unbound_var_fn ty go ty `thenNF_Tc` \ ty' -> returnNF_Tc (ForAllTy tyvar' ty') - go_pred (Class c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> - returnNF_Tc (Class c tys') + go_pred (ClassP c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> + returnNF_Tc (ClassP c tys') go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' -> returnNF_Tc (IParam n ty') diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 201df05..b502b16 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -164,7 +164,7 @@ uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 -- Predicates uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2)) | n1 == n2 = uTys t1 t1 t2 t2 -uTys _ (PredTy (Class c1 tys1)) _ (PredTy (Class c2 tys2)) +uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2)) | c1 == c2 = unifyTauTyLists tys1 tys2 -- Functions; just check the two parts diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 274c25c..3ecb8f8 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -5,7 +5,7 @@ \begin{code} module Class ( - Class, ClassOpItem, ClassPred, ClassContext, FunDep, + Class, ClassOpItem, FunDep, DefMeth (..), mkClass, classTyVars, classArity, @@ -16,7 +16,7 @@ module Class ( #include "HsVersions.h" import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TypeRep ( Type ) +import {-# SOURCE #-} TypeRep ( PredType ) import Var ( Id, TyVar ) import Name ( NamedThing(..), Name ) @@ -42,7 +42,7 @@ data Class classTyVars :: [TyVar], -- The class type variables classFunDeps :: [FunDep TyVar], -- The functional dependencies - classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the + classSCTheta :: [PredType], -- Immediate superclasses, and the classSCSels :: [Id], -- corresponding selector functions to -- extract them from a dictionary of this -- class @@ -52,9 +52,6 @@ data Class classTyCon :: TyCon -- The data type constructor for dictionaries } -- of this class -type ClassPred = (Class, [Type]) -type ClassContext = [ClassPred] - type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ... -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] @@ -73,7 +70,7 @@ The @mkClass@ function fills in the indirect superclasses. \begin{code} mkClass :: Name -> [TyVar] -> [([TyVar], [TyVar])] - -> [(Class,[Type])] -> [Id] + -> [PredType] -> [Id] -> [ClassOpItem] -> TyCon -> Class diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index 627db87..40e154f 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -108,7 +108,7 @@ 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) - | Class cls tys <- preds, -- Ignore implicit params + | ClassP cls tys <- preds, -- Ignore implicit params let (cls_tvs, cls_fds) = classTvsFds cls, fd <- cls_fds, let (xs,ys) = instFD fd cls_tvs tys @@ -210,11 +210,11 @@ checkGroup inst_env (IParam _ ty : ips) = -- For implicit parameters, all the types must match [(emptyVarSet, ty, ty') | IParam _ ty' <- ips, ty /= ty'] -checkGroup inst_env clss@(Class cls tys : _) +checkGroup inst_env clss@(ClassP cls tys : _) = -- For classes life is more complicated -- Suppose the class is like -- classs C as | (l1 -> r1), (l2 -> r2), ... where ... - -- Then FOR EACH PAIR (Class c tys1, Class c tys2) in the list clss + -- Then FOR EACH PAIR (ClassP c tys1, ClassP c tys2) in the list clss -- we check whether -- U l1[tys1/as] = U l2[tys2/as] -- (where U is a unifier) @@ -235,8 +235,8 @@ checkGroup inst_env clss@(Class cls tys : _) pairwise_eqns :: [Equation] pairwise_eqns -- This group comes from pairwise comparison = [ eqn | fd <- cls_fds, - Class _ tys1 : rest <- tails clss, - Class _ tys2 <- rest, + ClassP _ tys1 : rest <- tails clss, + ClassP _ tys2 <- rest, eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2 ] @@ -244,7 +244,7 @@ checkGroup inst_env clss@(Class cls tys : _) instance_eqns -- This group comes from comparing with instance decls = [ eqn | fd <- cls_fds, (qtvs, tys1, _) <- cls_inst_env, - Class _ tys2 <- clss, + ClassP _ tys2 <- clss, eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2 ] diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 6cfc898..6e4d5d0 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -63,9 +63,9 @@ pprKind = pprType pprParendKind = pprParendType pprPred :: PredType -> SDoc -pprPred (Class clas tys) = pprClassPred clas tys -pprPred (IParam n ty) = hsep [ptext SLIT("?") <> ppr n, - ptext SLIT("::"), ppr ty] +pprPred (ClassP clas tys) = pprClassPred clas tys +pprPred (IParam n ty) = hsep [ptext SLIT("?") <> ppr n, + ptext SLIT("::"), ppr ty] pprClassPred :: Class -> [Type] -> SDoc pprClassPred clas tys = ppr clas <+> hsep (map pprParendType tys) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index a4bf2bc..61c4ac4 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -47,14 +47,13 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) +import {-# SOURCE #-} TypeRep ( Type, PredType, Kind, SuperKind ) -- Should just be Type(Type), but this fails due to bug present up to -- and including 4.02 involving slurping of hi-boot files. Bug is now fixed. import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) -import Class ( ClassContext ) import Var ( TyVar, Id ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, EP(..) ) @@ -92,7 +91,7 @@ data TyCon tyConTyVars :: [TyVar], tyConArgVrcs :: ArgVrcs, - algTyConTheta :: ClassContext, + algTyConTheta :: [PredType], dataCons :: [DataCon], -- Its data constructors, with fully polymorphic types @@ -419,7 +418,7 @@ tyConPrimRep _ = PtrRep \end{code} \begin{code} -tyConTheta :: TyCon -> ClassContext +tyConTheta :: TyCon -> [PredType] tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -- should ask about anything else \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index e475674..d4c14a9 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -42,10 +42,6 @@ module Type ( isUTy, uaUTy, unUTy, liftUTy, mkUTyM, isUsageKind, isUsage, isUTyVar, - -- Predicates and the like - mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, predTyUnique, - splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy, - mkSynTy, deNoteType, repType, splitRepFunTys, splitNewType_maybe, typePrimRep, @@ -53,9 +49,15 @@ module Type ( mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, hoistForAllTys, isForAllTy, - TauType, RhoType, SigmaType, PredType(..), ThetaType, - ClassPred, ClassContext, mkClassPred, - getClassTys_maybe, predMentionsIPs, classesOfPreds, + -- Predicates and the like + PredType(..), getClassPredTys_maybe, getClassPredTys, + isClassPred, isTyVarClassPred, + mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique, + splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy, + mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName, + + -- Tau, Rho, Sigma + TauType, RhoType, SigmaType, ThetaType, isTauTy, mkRhoTy, splitRhoTy, splitMethodTy, mkSigmaTy, isSigmaTy, splitSigmaTy, getDFunTyKey, @@ -70,8 +72,8 @@ module Type ( -- Tidying up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, - tidyTyVar, tidyTyVars, - tidyTopType, + tidyTyVar, tidyTyVars, tidyFreeTyVars, + tidyTopType, tidyPred, -- Seq seqType, seqTypes @@ -96,9 +98,10 @@ import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet -import Name ( NamedThing(..), OccName, mkLocalName, tidyOccName ) +import OccName ( mkDictOcc ) +import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName ) import NameSet -import Class ( classTyCon, Class, ClassPred, ClassContext ) +import Class ( classTyCon, Class ) import TyCon ( TyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, @@ -109,7 +112,7 @@ import TyCon ( TyCon, -- others import Maybes ( maybeToBool ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import PrimRep ( PrimRep(..) ) import Unique ( Unique, Uniquable(..) ) import Util ( mapAccumL, seqList, thenCmp ) @@ -417,8 +420,8 @@ deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty) deNotePred :: PredType -> PredType -deNotePred (Class c tys) = Class c (map deNoteType tys) -deNotePred (IParam n ty) = IParam n (deNoteType ty) +deNotePred (ClassP c tys) = ClassP c (map deNoteType tys) +deNotePred (IParam n ty) = IParam n (deNoteType ty) \end{code} Notes on type synonyms @@ -667,10 +670,7 @@ isUTyVar v %************************************************************************ %* * -\subsection{Stuff to do with the source-language types} - -PredType and ThetaType are used in types for expressions and bindings. -ClassPred and ClassContext are used in class and instance declarations. +\subsection{Predicates} %* * %************************************************************************ @@ -679,27 +679,59 @@ tell from the type constructor whether it's a dictionary or not. \begin{code} mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - Class clas tys + ClassP clas tys + +isClassPred (ClassP clas tys) = True +isClassPred other = False + +isIPPred (IParam _ _) = True +isIPPred other = False + +isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys +isTyVarClassPred other = 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) + +inheritablePred :: PredType -> Bool +-- Can be inherited by a context. For example, consider +-- f x = let g y = (?v, y+x) +-- in (g 3 with ?v = 8, +-- g 4 with ?v = 9) +-- The point is that g's type must be quantifed over ?v: +-- g :: (?v :: a) => a -> a +-- but it doesn't need to be quantified over the Num a dictionary +-- which can be free in g's rhs, and shared by both calls to g +inheritablePred (ClassP _ _) = True +inheritablePred other = False + +predMentionsIPs :: PredType -> NameSet -> Bool +predMentionsIPs (IParam n _) ns = n `elemNameSet` ns +predMentionsIPs other ns = False mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - mkPredTy (Class clas tys) - -mkDictTys :: ClassContext -> [Type] -mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt] + mkPredTy (ClassP clas tys) mkPredTy :: PredType -> Type mkPredTy pred = PredTy pred +mkPredTys :: ThetaType -> [Type] +mkPredTys preds = map PredTy preds + predTyUnique :: PredType -> Unique -predTyUnique (IParam n _) = getUnique n -predTyUnique (Class clas tys) = getUnique clas +predTyUnique (IParam n _) = getUnique n +predTyUnique (ClassP clas tys) = getUnique clas predRepTy :: PredType -> Type -- Convert a predicate to its "representation type"; -- the type of evidence for that predicate, which is actually passed at runtime -predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys -predRepTy (IParam n ty) = ty +predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys +predRepTy (IParam n ty) = ty isPredTy :: Type -> Bool isPredTy (NoteTy _ ty) = isPredTy ty @@ -708,10 +740,10 @@ isPredTy (UsageTy _ ty)= isPredTy ty isPredTy _ = False isDictTy :: Type -> Bool -isDictTy (NoteTy _ ty) = isDictTy ty -isDictTy (PredTy (Class _ _)) = True -isDictTy (UsageTy _ ty) = isDictTy ty -isDictTy other = False +isDictTy (NoteTy _ ty) = isDictTy ty +isDictTy (PredTy (ClassP _ _)) = True +isDictTy (UsageTy _ ty) = isDictTy ty +isDictTy other = False splitPredTy_maybe :: Type -> Maybe PredType splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty @@ -721,12 +753,12 @@ splitPredTy_maybe other = Nothing splitDictTy :: Type -> (Class, [Type]) splitDictTy (NoteTy _ ty) = splitDictTy ty -splitDictTy (PredTy (Class clas tys)) = (clas, tys) +splitDictTy (PredTy (ClassP clas tys)) = (clas, tys) splitDictTy_maybe :: Type -> Maybe (Class, [Type]) -splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty) -splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys) -splitDictTy_maybe other = Nothing +splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty +splitDictTy_maybe (PredTy (ClassP clas tys)) = Just (clas, tys) +splitDictTy_maybe other = Nothing splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) -- Split the type of a dictionary function @@ -735,18 +767,17 @@ splitDFunTy ty case splitDictTy tau of { (clas, tys) -> (tvs, theta, clas, tys) }} -getClassTys_maybe :: PredType -> Maybe ClassPred -getClassTys_maybe (Class clas tys) = Just (clas, tys) -getClassTys_maybe _ = Nothing - -predMentionsIPs :: PredType -> NameSet -> Bool -predMentionsIPs (IParam n _) ns = n `elemNameSet` ns -predMentionsIPs other ns = False - -classesOfPreds :: ThetaType -> ClassContext -classesOfPreds theta = [(clas,tys) | Class clas tys <- theta] +mkPredName :: Unique -> SrcLoc -> PredType -> Name +mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc +mkPredName uniq loc (IParam name ty) = name \end{code} +%************************************************************************ +%* * +\subsection{Tau, sigma and rho} +%* * +%************************************************************************ + @isTauTy@ tests for nested for-alls. \begin{code} @@ -891,8 +922,8 @@ tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys -tyVarsOfPred (IParam n ty) = tyVarsOfType ty +tyVarsOfPred (ClassP clas tys) = tyVarsOfTypes tys +tyVarsOfPred (IParam n ty) = tyVarsOfType ty tyVarsOfTheta :: ThetaType -> TyVarSet tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet @@ -975,8 +1006,16 @@ tidyTyVar env@(tidy_env, subst) tyvar where name = tyVarName tyvar +tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars +tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv +-- Add the free tyvars to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars) + where + add env tv = fst (tidyTyVar env tv) + tidyType :: TidyEnv -> Type -> Type tidyType env@(tidy_env, subst) ty = go ty @@ -987,7 +1026,7 @@ tidyType env@(tidy_env, subst) ty go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty) - go (PredTy p) = PredTy (go_pred p) + go (PredTy p) = PredTy (tidyPred env p) go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg) go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg) go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty) @@ -998,10 +1037,11 @@ tidyType env@(tidy_env, subst) ty go_note (SynNote ty) = SynNote SAPPLY (go ty) go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars - go_pred (Class c tys) = Class c (tidyTypes env tys) - go_pred (IParam n ty) = IParam n (go ty) - tidyTypes env tys = map (tidyType env) tys + +tidyPred :: TidyEnv -> PredType -> PredType +tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) +tidyPred env (IParam n ty) = IParam n (tidyType env ty) \end{code} @@ -1013,8 +1053,7 @@ tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) tidyOpenType env ty = (env', tidyType env' ty) where - env' = foldl go env (varSetElems (tyVarsOfType ty)) - go env tyvar = fst (tidyTyVar env tyvar) + env' = tidyFreeTyVars env (tyVarsOfType ty) tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) tidyOpenTypes env tys = mapAccumL tidyOpenType env tys @@ -1098,8 +1137,8 @@ seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () seqPred :: PredType -> () -seqPred (Class c tys) = c `seq` seqTypes tys -seqPred (IParam n ty) = n `seq` seqType ty +seqPred (ClassP c tys) = c `seq` seqTypes tys +seqPred (IParam n ty) = n `seq` seqType ty \end{code} @@ -1180,7 +1219,7 @@ cmpPred env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmp -- Compare types as well as names for implicit parameters -- This comparison is used exclusively (I think) for the -- finite map built in TcSimplify -cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) -cmpPred env (IParam _ _) (Class _ _) = LT -cmpPred env (Class _ _) (IParam _ _) = GT +cmpPred env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) +cmpPred env (IParam _ _) (ClassP _ _) = LT +cmpPred env (ClassP _ _) (IParam _ _) = GT \end{code} diff --git a/ghc/compiler/types/TypeRep.hi-boot b/ghc/compiler/types/TypeRep.hi-boot index 5f779df..c9fc223 100644 --- a/ghc/compiler/types/TypeRep.hi-boot +++ b/ghc/compiler/types/TypeRep.hi-boot @@ -1,7 +1,8 @@ _interface_ TypeRep 1 -_exports_ TypeRep Type Kind SuperKind ; +_exports_ TypeRep Type PredType Kind SuperKind ; _declarations_ 1 data Type ; +1 data PredType ; 1 type Kind = Type ; 1 type SuperKind = Type ; diff --git a/ghc/compiler/types/TypeRep.hi-boot-5 b/ghc/compiler/types/TypeRep.hi-boot-5 index f12a1df..5679aa8 100644 --- a/ghc/compiler/types/TypeRep.hi-boot-5 +++ b/ghc/compiler/types/TypeRep.hi-boot-5 @@ -1,6 +1,7 @@ __interface TypeRep 1 0 where -__export TypeRep Type Kind SuperKind ; +__export TypeRep Type PredType Kind SuperKind ; 1 data Type ; +1 data PredType ; 1 type Kind = Type ; 1 type SuperKind = Type ; diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 1770772..d48bcac 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -163,7 +163,7 @@ Here the "Eq a" and "?x :: Int -> Int" and "r\l" are all called *predicates* Predicates are represented inside GHC by PredType: \begin{code} -data PredType = Class Class [Type] +data PredType = ClassP Class [Type] | IParam Name Type \end{code}