From 266fadd93461d4317967df08cd641e965cd8769a Mon Sep 17 00:00:00 2001 From: lewie Date: Fri, 28 Jan 2000 20:52:46 +0000 Subject: [PATCH 1/1] [project @ 2000-01-28 20:52:37 by lewie] First pass at implicit parameters. Honest, I didn't really go in *intending* to modify every file in the typechecker... ;-) The breadth of the change is partly due to generalizing contexts so that they are not hardwired to be (Class, [Type]) pairs. See types/Type.lhs for details (look for PredType). --- ghc/compiler/basicTypes/DataCon.lhs | 20 +-- ghc/compiler/basicTypes/MkId.lhs | 14 +- ghc/compiler/basicTypes/Name.lhs | 9 +- ghc/compiler/basicTypes/OccName.lhs | 19 ++- ghc/compiler/coreSyn/Subst.lhs | 16 ++- ghc/compiler/deSugar/DsExpr.lhs | 11 +- ghc/compiler/hsSyn/HsDecls.lhs | 26 ++-- ghc/compiler/hsSyn/HsExpr.lhs | 9 ++ ghc/compiler/hsSyn/HsTypes.lhs | 64 ++++++---- ghc/compiler/main/MkIface.lhs | 22 +++- ghc/compiler/parser/Lex.lhs | 16 ++- ghc/compiler/parser/ParseUtil.lhs | 9 +- ghc/compiler/parser/Parser.y | 24 +++- ghc/compiler/parser/RdrHsSyn.lhs | 11 +- ghc/compiler/parser/ctypes.c | 116 ++++++++--------- ghc/compiler/parser/ctypes.h | 6 +- ghc/compiler/prelude/TysWiredIn.lhs | 4 +- ghc/compiler/rename/ParseIface.y | 8 +- ghc/compiler/rename/RnEnv.lhs | 38 ++++-- ghc/compiler/rename/RnExpr.lhs | 25 ++++ ghc/compiler/rename/RnHsSyn.lhs | 13 +- ghc/compiler/rename/RnMonad.lhs | 12 +- ghc/compiler/rename/RnSource.lhs | 59 +++++---- ghc/compiler/specialise/Specialise.lhs | 4 +- ghc/compiler/typecheck/Inst.lhs | 212 ++++++++++++++++++++++--------- ghc/compiler/typecheck/TcBinds.lhs | 22 ++-- ghc/compiler/typecheck/TcClassDcl.lhs | 27 ++-- ghc/compiler/typecheck/TcDeriv.lhs | 8 +- ghc/compiler/typecheck/TcExpr.lhs | 89 ++++++++++--- ghc/compiler/typecheck/TcHsSyn.lhs | 14 ++ ghc/compiler/typecheck/TcImprove.lhs | 94 +++++++++----- ghc/compiler/typecheck/TcInstDcls.lhs | 42 +++--- ghc/compiler/typecheck/TcInstUtil.lhs | 4 +- ghc/compiler/typecheck/TcMonad.lhs | 5 +- ghc/compiler/typecheck/TcMonoType.lhs | 23 ++-- ghc/compiler/typecheck/TcPat.lhs | 12 +- ghc/compiler/typecheck/TcSimplify.lhs | 106 +++++++++------- ghc/compiler/typecheck/TcTyClsDecls.lhs | 7 +- ghc/compiler/typecheck/TcTyDecls.lhs | 16 ++- ghc/compiler/typecheck/TcType.lhs | 29 +++-- ghc/compiler/types/Class.lhs | 2 +- ghc/compiler/types/PprType.hi-boot | 3 +- ghc/compiler/types/PprType.hi-boot-5 | 3 +- ghc/compiler/types/PprType.lhs | 43 ++++--- ghc/compiler/types/Type.lhs | 96 +++++++++++--- ghc/compiler/types/TypeRep.lhs | 3 +- ghc/compiler/usageSP/UsageSPUtils.lhs | 2 + 47 files changed, 952 insertions(+), 465 deletions(-) diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 8d2c071..e1aa7d6 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -26,10 +26,10 @@ import {-# SOURCE #-} Subst( substTy, mkTyVarSubst ) import CmdLineOpts ( opt_DictsStrict ) import TysPrim -import Type ( Type, ThetaType, TauType, +import Type ( Type, ThetaType, TauType, ClassContext, mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys, mkDictTy, - splitAlgTyConApp_maybe + splitAlgTyConApp_maybe, classesToPreds ) import PprType import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon, @@ -84,10 +84,10 @@ data DataCon -- dcTyCon = T dcTyVars :: [TyVar], -- Type vars and context for the data type decl - dcTheta :: ThetaType, + dcTheta :: ClassContext, dcExTyVars :: [TyVar], -- Ditto for the context of the constructor, - dcExTheta :: ThetaType, -- the existentially quantified stuff + dcExTheta :: ClassContext, -- the existentially quantified stuff dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of @@ -204,8 +204,8 @@ instance Show DataCon where \begin{code} mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> ThetaType - -> [TyVar] -> ThetaType + -> [TyVar] -> ClassContext + -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> Id -> DataCon @@ -238,7 +238,7 @@ mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys t tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con ty = mkSigmaTy (tyvars ++ ex_tyvars) - ex_theta + (classesToPreds ex_theta) (mkFunTys rep_arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))) @@ -246,7 +246,7 @@ mk_dict_strict_mark (clas,tys) | opt_DictsStrict && -- Don't mark newtype things as strict! isDataTyCon (classTyCon clas) = MarkedStrict - | otherwise = NotMarkedStrict + | otherwise = NotMarkedStrict \end{code} \begin{code} @@ -287,8 +287,8 @@ dataConRepStrictness dc go (NotMarkedStrict : ss) = wwLazy : go ss go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss) -dataConSig :: DataCon -> ([TyVar], ThetaType, - [TyVar], ThetaType, +dataConSig :: DataCon -> ([TyVar], ClassContext, + [TyVar], ClassContext, [TauType], TyCon) dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index e7b3b38..87262ae 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -41,8 +41,8 @@ import TysWiredIn ( boolTy, charTy, mkListTy ) import PrelMods ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) -import Type ( Type, ThetaType, - mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, +import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys, + mkFunTys, mkFunTy, mkSigmaTy, classesToPreds, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes, splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, splitFunTys, splitForAllTys, unUsgTy, @@ -50,7 +50,7 @@ import Type ( Type, ThetaType, ) import Module ( Module ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) -import Subst ( mkTopTyVarSubst, substTheta ) +import Subst ( mkTopTyVarSubst, substClasses ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon ) import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar ) @@ -156,7 +156,7 @@ mkDataConId data_con where (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con id_ty = mkSigmaTy (tyvars ++ ex_tyvars) - (theta ++ ex_theta) + (classesToPreds (theta ++ ex_theta)) (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))) \end{code} @@ -460,16 +460,16 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Class -> [TyVar] -> [Type] - -> ThetaType + -> ClassContext -> Id mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta = mkVanillaId dfun_name dfun_ty where (class_tyvars, sc_theta, _, _) = classBigSig clas - sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta + sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta - dfun_theta = inst_decl_theta + dfun_theta = classesToPreds inst_decl_theta {- 1 dec 99: disable the Mark Jones optimisation for the sake of compatibility with Hugs. diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 46e0a01..3b0cd48 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -11,7 +11,7 @@ module Name ( -- The Name type Name, -- Abstract mkLocalName, mkImportedLocalName, mkSysLocalName, - mkTopName, + mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInIdName, mkWiredInTyConName, maybeWiredInIdName, maybeWiredInTyConName, @@ -133,6 +133,13 @@ mkTopName uniq mod fs n_occ = mkSrcVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)), n_prov = LocalDef noSrcLoc NotExported } +mkIPName :: Unique -> OccName -> Name +mkIPName uniq occ + = Name { n_uniq = uniq, + n_sort = Local, + n_occ = mkIPOcc occ, + n_prov = SystemProv } + ------------------------- Wired in names ------------------------- mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 1720506..2977362 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -7,8 +7,8 @@ \begin{code} module OccName ( -- The NameSpace type; abstact - NameSpace, tcName, clsName, tcClsName, dataName, varName, tvName, - uvName, nameSpaceString, + NameSpace, tcName, clsName, tcClsName, dataName, varName, ipName, + tvName, uvName, nameSpaceString, -- The OccName type OccName, -- Abstract, instance of Outputable @@ -16,10 +16,10 @@ module OccName ( mkSrcOccFS, mkSysOcc, mkSysOccFS, mkSrcVarOcc, mkKindOccFS, mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, - mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, + mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, + isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, setOccNameSpace, @@ -82,11 +82,12 @@ pprEncodedFS fs \begin{code} data NameSpace = VarName -- Variables + | IPName -- Implicit Parameters | DataName -- Data constructors | TvName -- Type variables | UvName -- Usage variables | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. + -- in the same name space for now. deriving( Eq, Ord ) -- Though type constructors and classes are in the same name space now, @@ -99,11 +100,13 @@ dataName = DataName tvName = TvName uvName = UvName varName = VarName +ipName = IPName nameSpaceString :: NameSpace -> String nameSpaceString DataName = "Data constructor" nameSpaceString VarName = "Variable" +nameSpaceString IPName = "Implicit Param" nameSpaceString TvName = "Type variable" nameSpaceString UvName = "Usage variable" nameSpaceString TcClsName = "Type constructor or class" @@ -234,6 +237,9 @@ isDataOcc oter = False -- Pretty inefficient! isSymOcc (OccName DataName s) = isLexConSym (decodeFS s) isSymOcc (OccName VarName s) = isLexSym (decodeFS s) + +isIPOcc (OccName IPName _) = True +isIPOcc _ = False \end{code} @@ -277,7 +283,7 @@ mk_deriv occ_sp sys_prefix str = mkSysOcc occ_sp (encode sys_prefix ++ str) \end{code} \begin{code} -mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc, +mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc :: OccName -> OccName @@ -288,6 +294,7 @@ mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon mkClassDataConOcc = mk_simple_deriv dataName ":D" -- mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 8f2d41f..cc473cd 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -23,7 +23,7 @@ module Subst ( -- Type stuff mkTyVarSubst, mkTopTyVarSubst, - substTy, substTheta, + substTy, substClasses, substTheta, -- Expression stuff substExpr, substIdInfo @@ -38,7 +38,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr, import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..), ) -- friend -import Type ( ThetaType, +import Type ( ThetaType, PredType(..), ClassContext, tyVarsOfType, tyVarsOfTypes, mkAppTy ) import VarSet @@ -262,10 +262,19 @@ 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 = [(clas, map (subst_ty subst) tys) | (clas, tys) <- 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) subst_ty subst ty = go ty @@ -277,6 +286,7 @@ subst_ty subst ty go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr + go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) go ty@(TyVarTy tv) = case (lookupSubst subst tv) of Nothing -> ty diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 36eae0f..7b1a96e 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -118,6 +118,7 @@ dsLet (MonoBind binds sigs is_rec) body dsExpr :: TypecheckedHsExpr -> DsM CoreExpr dsExpr e@(HsVar var) = returnDs (Var var) +dsExpr e@(HsIPVar var) = returnDs (Var var) \end{code} %************************************************************************ @@ -319,7 +320,15 @@ dsExpr (HsCase discrim matches src_loc) dsExpr (HsLet binds body) = dsExpr body `thenDs` \ body' -> dsLet binds body' - + +dsExpr (HsWith expr binds) + = dsExpr expr `thenDs` \ expr' -> + foldlDs dsIPBind expr' binds + where + dsIPBind body (n, e) + = dsExpr e `thenDs` \ e' -> + returnDs (Let (NonRec n e') body) + dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc) | maybeToBool maybe_list_comp = -- Special case for list comprehensions diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 9a39e1b..527ba15 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -113,14 +113,14 @@ instance (Outputable name, Outputable pat) \begin{code} data TyClDecl name pat = TyData NewOrData - (Context name) -- context - name -- type constructor - [HsTyVar name] -- type variables - [ConDecl name] -- data constructors (empty if abstract) - (Maybe [name]) -- derivings; Nothing => not specified - -- (i.e., derive default); Just [] => derive - -- *nothing*; Just => as you would - -- expect... + (HsContext name) -- context + name -- type constructor + [HsTyVar name] -- type variables + [ConDecl name] -- data constructors (empty if abstract) + (Maybe [name]) -- derivings; Nothing => not specified + -- (i.e., derive default); Just [] => derive + -- *nothing*; Just => as you would + -- expect... (DataPragmas name) SrcLoc @@ -129,7 +129,7 @@ data TyClDecl name pat (HsType name) -- synonym expansion SrcLoc - | ClassDecl (Context name) -- context... + | ClassDecl (HsContext name) -- context... name -- name of the class [HsTyVar name] -- the class type variables [([name], [name])] -- functional dependencies @@ -172,7 +172,7 @@ instance (Outputable name, Outputable pat) ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) = pp_tydecl - (pp_decl_head keyword (pprContext context) tycon tyvars) + (pp_decl_head keyword (pprHsContext context) tycon tyvars) (pp_condecls condecls) derivings where @@ -190,7 +190,7 @@ instance (Outputable name, Outputable pat) ppr methods, char '}'])] where - top_matter = hsep [ptext SLIT("class"), pprContext context, + top_matter = hsep [ptext SLIT("class"), pprHsContext context, ppr clas, hsep (map (ppr) tyvars), pprFundeps fds] ppr_sig sig = ppr sig <> semi @@ -239,7 +239,7 @@ data ConDecl name = ConDecl name -- Constructor name [HsTyVar name] -- Existentially quantified type variables - (Context name) -- ...and context + (HsContext name) -- ...and context -- If both are empty then there are no existentials (ConDetails name) @@ -269,7 +269,7 @@ data BangType name \begin{code} instance (Outputable name) => Outputable (ConDecl name) where ppr (ConDecl con tvs cxt con_details loc) - = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details] + = sep [pprForAll tvs, pprHsContext cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index ef2153f..c530956 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -35,6 +35,7 @@ import SrcLoc ( SrcLoc ) \begin{code} data HsExpr id pat = HsVar id -- variable + | HsIPVar id -- implicit parameter | HsLit HsLit -- literal | HsLitOut HsLit -- TRANSLATION Type -- (with its type) @@ -79,6 +80,9 @@ data HsExpr id pat | HsLet (HsBinds id pat) -- let(rec) (HsExpr id pat) + | HsWith (HsExpr id pat) -- implicit parameter binding + [(id, HsExpr id pat)] + | HsDo StmtCtxt [Stmt id pat] -- "do":one or more stmts SrcLoc @@ -209,6 +213,7 @@ pprExpr e = pprDeeper (ppr_expr e) pprBinds b = pprDeeper (ppr b) ppr_expr (HsVar v) = ppr v +ppr_expr (HsIPVar v) = char '?' <> ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsLitOut lit _) = ppr lit @@ -292,6 +297,9 @@ ppr_expr (HsLet binds expr) = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), hang (ptext SLIT("in")) 2 (ppr expr)] +ppr_expr (HsWith expr binds) + = hsep [ppr expr, ptext SLIT("with"), ppr binds] + ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts @@ -381,6 +389,7 @@ pprParendExpr expr HsLitOut l _ -> ppr l HsVar _ -> pp_as_was + HsIPVar _ -> pp_as_was ExplicitList _ -> pp_as_was ExplicitListOut _ _ -> pp_as_was ExplicitTuple _ _ -> pp_as_was diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index b6c91ea..0f70df5 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -6,13 +6,13 @@ \begin{code} module HsTypes ( HsType(..), MonoUsageAnn(..), HsTyVar(..), - Context, ClassAssertion + HsContext, HsClassAssertion, HsPred(..) , mkHsForAllTy, mkHsUsForAllTy , getTyVarName, replaceTyVarName , pprParendHsType - , pprForAll, pprContext, pprClassAssertion - , cmpHsType, cmpHsTypes, cmpContext + , pprForAll, pprHsContext, pprHsClassAssertion, pprHsPred + , cmpHsType, cmpHsTypes, cmpHsContext, cmpHsPred ) where #include "HsVersions.h" @@ -26,15 +26,17 @@ import Util ( thenCmp, cmpList ) This is the syntax for types as seen in type signatures. \begin{code} -type Context name = [ClassAssertion name] - -type ClassAssertion name = (name, [HsType name]) - -- The type is usually a type variable, but it - -- doesn't have to be when reading interface files +type HsContext name = [HsPred name] +type HsClassAssertion name = (name, [HsType name]) +-- The type is usually a type variable, but it +-- doesn't have to be when reading interface files +data HsPred name = + HsPClass name [HsType name] + | HsPIParam name (HsType name) data HsType name = HsForAllTy (Maybe [HsTyVar name]) -- Nothing for implicitly quantified signatures - (Context name) + (HsContext name) (HsType name) | MonoTyVar name -- Type variable @@ -121,13 +123,19 @@ instance (Outputable name) => Outputable (HsTyVar name) where -- pprForAll [] = empty pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".") -pprContext :: (Outputable name) => Context name -> SDoc -pprContext [] = empty -pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>") +pprHsContext :: (Outputable name) => HsContext name -> SDoc +pprHsContext [] = empty +pprHsContext context = parens (hsep (punctuate comma (map pprHsPred context))) <+> ptext SLIT("=>") + +pprHsClassAssertion :: (Outputable name) => HsClassAssertion name -> SDoc +pprHsClassAssertion (clas, tys) + = ppr clas <+> hsep (map pprParendHsType tys) -pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc -pprClassAssertion (clas, tys) +pprHsPred :: (Outputable name) => HsPred name -> SDoc +pprHsPred (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys) +pprHsPred (HsPIParam n ty) + = hsep [char '?' <> ppr n, text "::", ppr ty] \end{code} \begin{code} @@ -148,7 +156,7 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) = maybeParen (ctxt_prec >= pREC_FUN) $ - sep [pp_tvs, pprContext ctxt, pprHsType ty] + sep [pp_tvs, pprHsContext ctxt, pprHsType ty] where pp_tvs = case maybe_tvs of Just tvs -> pprForAll tvs @@ -213,17 +221,17 @@ in checking interfaces. Most any other use is likely to be {\em wrong}, so be careful! \begin{code} -cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering -cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering -cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering -cmpContext :: (a -> a -> Ordering) -> Context a -> Context a -> Ordering +cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering +cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering +cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering +cmpHsContext :: (a -> a -> Ordering) -> HsContext a -> HsContext a -> Ordering +cmpHsPred :: (a -> a -> Ordering) -> HsPred a -> HsPred a -> Ordering cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 cmpHsTyVar cmp (UserTyVar _) other = LT cmpHsTyVar cmp other1 other2 = GT - cmpHsTypes cmp [] [] = EQ cmpHsTypes cmp [] tys2 = LT cmpHsTypes cmp tys1 [] = GT @@ -231,7 +239,7 @@ cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsType cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2 `thenCmp` - cmpContext cmp c1 c2 `thenCmp` + cmpHsContext cmp c1 c2 `thenCmp` cmpHsType cmp t1 t2 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2) @@ -272,11 +280,15 @@ cmpHsType cmp ty1 ty2 -- tags must be different tag (HsForAllTy _ _ _) = ILIT(9) ------------------- -cmpContext cmp a b - = cmpList cmp_ctxt a b - where - cmp_ctxt (c1, tys1) (c2, tys2) - = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 +cmpHsContext cmp a b + = cmpList (cmpHsPred cmp) a b + +cmpHsPred cmp (HsPClass c1 tys1) (HsPClass c2 tys2) + = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 +cmpHsPred cmp (HsPIParam n1 ty1) (HsPIParam n2 ty2) + = cmp n1 n2 `thenCmp` cmpHsType cmp ty1 ty2 +cmpHsPred cmp (HsPClass _ _) (HsPIParam _ _) = LT +cmpHsPred cmp _ _ = GT cmpUsg cmp MonoUsOnce MonoUsOnce = EQ cmpUsg cmp MonoUsMany MonoUsMany = EQ diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 9901853..e882a37 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -48,7 +48,8 @@ import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, ) import Class ( Class, classExtraBigSig ) import FieldLabel ( fieldLabelName, fieldLabelType ) -import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, +import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, + deNoteType, classesToPreds, Type, ThetaType ) @@ -260,7 +261,8 @@ ifaceInstances if_hdl inst_infos -- instance Foo Tibble where ... -- and this instance decl wouldn't get imported into a module -- that mentioned T but not Tibble. - forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys)) + forall_ty = mkSigmaTy tvs (classesToPreds theta) + (deNoteType (mkDictTy clas tys)) renumbered_ty = tidyTopType forall_ty in hcat [ptext SLIT("instance "), pprType renumbered_ty, @@ -494,7 +496,7 @@ ifaceTyCon tycon ifaceTyCon tycon | isAlgTyCon tycon = hsep [ ptext keyword, - ppr_decl_context (tyConTheta tycon), + ppr_decl_class_context (tyConTheta tycon), ppr (getName tycon), pprTyVarBndrs (tyConTyVars tycon), ptext SLIT("="), @@ -528,7 +530,7 @@ ifaceTyCon tycon ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs) - <+> pprIfaceTheta ex_theta <+> ptext SLIT("=>") + <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>") ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty @@ -547,7 +549,7 @@ ifaceTyCon tycon ifaceClass clas = hsep [ptext SLIT("class"), - ppr_decl_context sc_theta, + ppr_decl_class_context sc_theta, ppr clas, -- Print the name pprTyVarBndrs clas_tyvars, pprFundeps clas_fds, @@ -576,9 +578,17 @@ ppr_decl_context :: ThetaType -> SDoc ppr_decl_context [] = empty ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>") +ppr_decl_class_context :: [(Class,[Type])] -> SDoc +ppr_decl_class_context [] = empty +ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>") + pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files pprIfaceTheta [] = empty -pprIfaceTheta theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) +pprIfaceTheta theta = braces (hsep (punctuate comma [pprPred p | p <- theta])) + +pprIfaceClasses :: [(Class,[Type])] -> SDoc +pprIfaceClasses [] = empty +pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) \end{code} %************************************************************************ diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index c86721c..8dae914 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -128,6 +128,7 @@ data Token | ITlabel | ITdynamic | ITunsafe + | ITwith | ITstdcallconv | ITccallconv @@ -208,6 +209,8 @@ data Token | ITqvarsym (FAST_STRING,FAST_STRING) | ITqconsym (FAST_STRING,FAST_STRING) + | ITipvarid FAST_STRING -- GHC extension: implicit param: ?x + | ITpragma StringBuffer | ITchar Char @@ -282,6 +285,7 @@ ghcExtensionKeywordsFM = listToUFM $ ( "label", ITlabel ), ( "dynamic", ITdynamic ), ( "unsafe", ITunsafe ), + ( "with", ITwith ), ( "stdcall", ITstdcallconv), ( "ccall", ITccallconv), ("_ccall_", ITccall (False, False, False)), @@ -590,6 +594,8 @@ lexToken cont glaexts buf = trace "lexIface: misplaced NUL?" $ cont (ITunknown "\NUL") (stepOn buf) + '?'# | flag glaexts && is_lower (lookAhead# buf 1#) -> + lex_ip cont (setCurrentPos# buf 1#) c | is_digit c -> lex_num cont glaexts 0 buf | is_symbol c -> lex_sym cont buf | is_upper c -> lex_con cont glaexts buf @@ -892,12 +898,18 @@ is_ident = is_ctype 1 is_symbol = is_ctype 2 is_any = is_ctype 4 is_space = is_ctype 8 -is_upper = is_ctype 16 -is_digit = is_ctype 32 +is_lower = is_ctype 16 +is_upper = is_ctype 32 +is_digit = is_ctype 64 ----------------------------------------------------------------------------- -- identifiers, symbols etc. +lex_ip cont buf = + case expandWhile# is_ident buf of + buf' -> cont (ITipvarid lexeme) buf' + where lexeme = lexemeToFastString buf' + lex_id cont glaexts buf = case expandWhile# is_ident buf of { buf1 -> diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index a679d3a..b410fee 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -137,15 +137,15 @@ checkInstType t checkContext :: RdrNameHsType -> P RdrNameContext checkContext (MonoTupleTy ts True) = mapP (\t -> checkAssertion t []) ts `thenP` \cs -> - returnP cs + returnP (map (uncurry HsPClass) cs) checkContext (MonoTyVar t) -- empty contexts are allowed | t == unitTyCon_RDR = returnP [] checkContext t - = checkAssertion t [] `thenP` \c -> - returnP [c] + = checkAssertion t [] `thenP` \(c,ts) -> + returnP [HsPClass c ts] checkAssertion :: RdrNameHsType -> [RdrNameHsType] - -> P (ClassAssertion RdrName) + -> P (HsClassAssertion RdrName) checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) = returnP (t,args) checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args) @@ -239,6 +239,7 @@ patterns). checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr checkExpr e = case e of HsVar _ -> returnP e + HsIPVar _ -> returnP e HsLit _ -> returnP e HsLam match -> checkMatch match `thenP` (returnP.HsLam) HsApp e1 e2 -> check2Exprs e1 e2 HsApp diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 87f6458..759c2dc 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.18 1999/12/01 17:01:36 simonmar Exp $ +$Id: Parser.y,v 1.19 2000/01/28 20:52:39 lewie Exp $ Haskell grammar. @@ -19,7 +19,7 @@ import Lex import ParseUtil import RdrName import PrelMods ( mAIN_Name ) -import OccName ( varName, dataName, tcClsName, tvName ) +import OccName ( varName, ipName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module import CallConv @@ -85,6 +85,7 @@ Conflicts: 14 shift/reduce 'then' { ITthen } 'type' { ITtype } 'where' { ITwhere } + 'with' { ITwith } '_scc_' { ITscc } 'forall' { ITforall } -- GHC extension keywords @@ -173,6 +174,7 @@ Conflicts: 14 shift/reduce QCONID { ITqconid $$ } QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } + IPVARID { ITipvarid $$ } PRAGMA { ITpragma $$ } @@ -633,6 +635,7 @@ gdrh :: { RdrNameGRHS } exp :: { RdrNameHsExpr } : infixexp '::' sigtype { ExprWithTySig $1 $3 } + | infixexp 'with' dbinding { HsWith $1 $3 } | infixexp { $1 } infixexp :: { RdrNameHsExpr } @@ -683,6 +686,7 @@ aexp :: { RdrNameHsExpr } aexp1 :: { RdrNameHsExpr } : qvar { HsVar $1 } + | IPVARID { HsIPVar (mkSrcUnqual ipName $1) } | gcon { HsVar $1 } | literal { HsLit $1 } | '(' exp ')' { HsPar $2 } @@ -816,6 +820,22 @@ fbind :: { (RdrName, RdrNameHsExpr, Bool) } : qvar '=' exp { ($1,$3,False) } ----------------------------------------------------------------------------- +-- Implicit Parameter Bindings + +dbinding :: { [(RdrName, RdrNameHsExpr)] } + : '{' dbinds '}' { $2 } + | layout_on dbinds close { $2 } + +dbinds :: { [(RdrName, RdrNameHsExpr)] } + : dbinds ';' dbind { $3 : $1 } + | dbinds ';' { $1 } + | dbind { [$1] } + | {- empty -} { [] } + +dbind :: { (RdrName, RdrNameHsExpr) } +dbind : IPVARID '=' exp { (mkSrcUnqual ipName $1, $3) } + +----------------------------------------------------------------------------- -- Variables, Constructors and Operators. gcon :: { RdrName } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 23801c7..32085d4 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -88,7 +88,7 @@ type RdrNameBangType = BangType RdrName type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName type RdrNameConDetails = ConDetails RdrName -type RdrNameContext = Context RdrName +type RdrNameContext = HsContext RdrName type RdrNameHsDecl = HsDecl RdrName RdrNamePat type RdrNameSpecDataSig = SpecDataSig RdrName type RdrNameDefaultDecl = DefaultDecl RdrName @@ -147,12 +147,13 @@ extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs)) go (RuleBndr _) acc = acc go (RuleBndrSig _ ty) acc = extract_ty ty acc -extractHsCtxtRdrNames :: Context RdrName -> [RdrName] +extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName] extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) -extract_ctxt ctxt acc = foldr extract_ass acc ctxt - where - extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys +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_tys tys acc = foldr extract_ty acc tys diff --git a/ghc/compiler/parser/ctypes.c b/ghc/compiler/parser/ctypes.c index cb09379..0e3daaf 100644 --- a/ghc/compiler/parser/ctypes.c +++ b/ghc/compiler/parser/ctypes.c @@ -103,34 +103,34 @@ const unsigned char char_types[] = C_Any | C_Symbol, /* \ */ C_Any, /* ] */ C_Any | C_Symbol, /* ^ */ - C_Any | C_Ident, /* _ */ + C_Any | C_Ident | C_Lower, /* _ */ C_Any, /* ` */ - C_Any | C_Ident, /* a */ - C_Any | C_Ident, /* b */ - C_Any | C_Ident, /* c */ - C_Any | C_Ident, /* d */ - C_Any | C_Ident, /* e */ - C_Any | C_Ident, /* f */ - C_Any | C_Ident, /* g */ - C_Any | C_Ident, /* h */ - C_Any | C_Ident, /* i */ - C_Any | C_Ident, /* j */ - C_Any | C_Ident, /* k */ - C_Any | C_Ident, /* l */ - C_Any | C_Ident, /* m */ - C_Any | C_Ident, /* n */ - C_Any | C_Ident, /* o */ - C_Any | C_Ident, /* p */ - C_Any | C_Ident, /* q */ - C_Any | C_Ident, /* r */ - C_Any | C_Ident, /* s */ - C_Any | C_Ident, /* t */ - C_Any | C_Ident, /* u */ - C_Any | C_Ident, /* v */ - C_Any | C_Ident, /* w */ - C_Any | C_Ident, /* x */ - C_Any | C_Ident, /* y */ - C_Any | C_Ident, /* z */ + C_Any | C_Ident | C_Lower, /* a */ + C_Any | C_Ident | C_Lower, /* b */ + C_Any | C_Ident | C_Lower, /* c */ + C_Any | C_Ident | C_Lower, /* d */ + C_Any | C_Ident | C_Lower, /* e */ + C_Any | C_Ident | C_Lower, /* f */ + C_Any | C_Ident | C_Lower, /* g */ + C_Any | C_Ident | C_Lower, /* h */ + C_Any | C_Ident | C_Lower, /* i */ + C_Any | C_Ident | C_Lower, /* j */ + C_Any | C_Ident | C_Lower, /* k */ + C_Any | C_Ident | C_Lower, /* l */ + C_Any | C_Ident | C_Lower, /* m */ + C_Any | C_Ident | C_Lower, /* n */ + C_Any | C_Ident | C_Lower, /* o */ + C_Any | C_Ident | C_Lower, /* p */ + C_Any | C_Ident | C_Lower, /* q */ + C_Any | C_Ident | C_Lower, /* r */ + C_Any | C_Ident | C_Lower, /* s */ + C_Any | C_Ident | C_Lower, /* t */ + C_Any | C_Ident | C_Lower, /* u */ + C_Any | C_Ident | C_Lower, /* v */ + C_Any | C_Ident | C_Lower, /* w */ + C_Any | C_Ident | C_Lower, /* x */ + C_Any | C_Ident | C_Lower, /* y */ + C_Any | C_Ident | C_Lower, /* z */ C_Any, /* { */ C_Any | C_Symbol, /* | */ C_Any, /* } */ @@ -223,7 +223,7 @@ const unsigned char char_types[] = C_Any | C_Ident | C_Upper, /* Ô */ C_Any | C_Ident | C_Upper, /* Õ */ C_Any | C_Ident | C_Upper, /* Ö */ - C_Any | C_Symbol, /* × */ + C_Any | C_Symbol | C_Lower, /* × */ C_Any | C_Ident | C_Upper, /* Ø */ C_Any | C_Ident | C_Upper, /* Ù */ C_Any | C_Ident | C_Upper, /* Ú */ @@ -232,36 +232,36 @@ const unsigned char char_types[] = C_Any | C_Ident | C_Upper, /* Ý */ C_Any | C_Ident | C_Upper, /* Þ */ C_Any | C_Ident, /* ß */ - C_Any | C_Ident, /* à */ - C_Any | C_Ident, /* á */ - C_Any | C_Ident, /* â */ - C_Any | C_Ident, /* ã */ - C_Any | C_Ident, /* ä */ - C_Any | C_Ident, /* å */ - C_Any | C_Ident, /* æ */ - C_Any | C_Ident, /* ç */ - C_Any | C_Ident, /* è */ - C_Any | C_Ident, /* é */ - C_Any | C_Ident, /* ê */ - C_Any | C_Ident, /* ë */ - C_Any | C_Ident, /* ì */ - C_Any | C_Ident, /* í */ - C_Any | C_Ident, /* î */ - C_Any | C_Ident, /* ï */ - C_Any | C_Ident, /* ð */ - C_Any | C_Ident, /* ñ */ - C_Any | C_Ident, /* ò */ - C_Any | C_Ident, /* ó */ - C_Any | C_Ident, /* ô */ - C_Any | C_Ident, /* õ */ - C_Any | C_Ident, /* ö */ + C_Any | C_Ident | C_Lower, /* à */ + C_Any | C_Ident | C_Lower, /* á */ + C_Any | C_Ident | C_Lower, /* â */ + C_Any | C_Ident | C_Lower, /* ã */ + C_Any | C_Ident | C_Lower, /* ä */ + C_Any | C_Ident | C_Lower, /* å */ + C_Any | C_Ident | C_Lower, /* æ */ + C_Any | C_Ident | C_Lower, /* ç */ + C_Any | C_Ident | C_Lower, /* è */ + C_Any | C_Ident | C_Lower, /* é */ + C_Any | C_Ident | C_Lower, /* ê */ + C_Any | C_Ident | C_Lower, /* ë */ + C_Any | C_Ident | C_Lower, /* ì */ + C_Any | C_Ident | C_Lower, /* í */ + C_Any | C_Ident | C_Lower, /* î */ + C_Any | C_Ident | C_Lower, /* ï */ + C_Any | C_Ident | C_Lower, /* ð */ + C_Any | C_Ident | C_Lower, /* ñ */ + C_Any | C_Ident | C_Lower, /* ò */ + C_Any | C_Ident | C_Lower, /* ó */ + C_Any | C_Ident | C_Lower, /* ô */ + C_Any | C_Ident | C_Lower, /* õ */ + C_Any | C_Ident | C_Lower, /* ö */ C_Any | C_Symbol, /* ÷ */ C_Any | C_Ident, /* ø */ - C_Any | C_Ident, /* ù */ - C_Any | C_Ident, /* ú */ - C_Any | C_Ident, /* û */ - C_Any | C_Ident, /* ü */ - C_Any | C_Ident, /* ý */ - C_Any | C_Ident, /* þ */ - C_Any | C_Ident, /* ÿ */ + C_Any | C_Ident | C_Lower, /* ù */ + C_Any | C_Ident | C_Lower, /* ú */ + C_Any | C_Ident | C_Lower, /* û */ + C_Any | C_Ident | C_Lower, /* ü */ + C_Any | C_Ident | C_Lower, /* ý */ + C_Any | C_Ident | C_Lower, /* þ */ + C_Any | C_Ident | C_Lower, /* ÿ */ }; diff --git a/ghc/compiler/parser/ctypes.h b/ghc/compiler/parser/ctypes.h index 03cf2ce..a67e162 100644 --- a/ghc/compiler/parser/ctypes.h +++ b/ghc/compiler/parser/ctypes.h @@ -8,8 +8,9 @@ #define C_Symbol 1<<1 #define C_Any 1<<2 #define C_Space 1<<3 -#define C_Upper 1<<4 -#define C_Digit 1<<5 +#define C_Lower 1<<4 +#define C_Upper 1<<5 +#define C_Digit 1<<6 #define _IsType(c,flags) (char_types[(int)(c)] & flags) @@ -17,6 +18,7 @@ #define IsIdent(c) (_IsType(c,C_Ident)) #define IsAny(c) (_IsType(c,C_Any)) #define IsSymbol(c) (_IsType(c,C_Symbol)) +#define IsLower(c) (_IsType(c,C_Lower)) #define IsUpper(c) (_IsType(c,C_Upper)) #define IsDigit(c) (_IsType(c,C_Digit)) diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 8f6e76b..f4542a6 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -93,7 +93,7 @@ import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, mkArrowKinds, boxedTypeKind, unboxedTypeKind, mkFunTy, mkFunTys, isUnLiftedType, splitTyConApp_maybe, splitAlgTyConApp_maybe, - ThetaType, TauType ) + TauType, ClassContext ) import PrimRep ( PrimRep(..) ) import Unique import CmdLineOpts ( opt_GlasgowExts ) @@ -136,7 +136,7 @@ pcSynTyCon key mod str kind arity tyvars expansion argvrcs -- this fun never us name = mkWiredInTyConName key mod str tycon pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING - -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon + -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon pcDataCon key mod str tyvars context arg_tys tycon = data_con where diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 7661607..950fe54 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -25,7 +25,7 @@ import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual ) import Name ( OccName, Provenance ) import OccName ( mkSysOccFS, - tcName, varName, dataName, clsName, tvName, uvName, + tcName, varName, ipName, dataName, clsName, tvName, uvName, EncodedFS ) import Module ( ModuleName, mkSysModuleFS ) @@ -145,6 +145,7 @@ import Ratio ( (%) ) QCONID { ITqconid $$ } QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } + IPVARID { ITipvarid $$ } PRAGMA { ITpragma $$ } @@ -421,8 +422,9 @@ context_list1 :: { RdrNameContext } context_list1 : class { [$1] } | class ',' context_list1 { $1 : $3 } -class :: { (RdrName, [RdrNameHsType]) } -class : qcls_name atypes { ($1, $2) } +class :: { HsPred RdrName } +class : qcls_name atypes { (HsPClass $1 $2) } + | IPVARID '::' type { (HsPIParam (mkSysUnqual ipName $1) $3) } types0 :: { [RdrNameHsType] {- Zero or more -} } types0 : {- empty -} { [ ] } diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6231217..b4bb690 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,7 +21,8 @@ import HsTypes ( getTyVarName, replaceTyVarName ) import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName, + mkLocalName, mkImportedLocalName, mkGlobalName, + mkIPName, isSystemName, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, occNameUserString, @@ -57,13 +58,13 @@ import Maybes ( mapMaybe ) \begin{code} newImportedGlobalName mod_name occ mod - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (mod_name, occ) in case lookupFM cache key of Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` returnRn name where (us', us1) = splitUniqSupply us @@ -73,8 +74,8 @@ newImportedGlobalName mod_name occ mod updateProvenances :: [Name] -> RnM d () updateProvenances names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - setNameSupplyRn (us, inst_ns, update cache names) + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + setNameSupplyRn (us, inst_ns, update cache names, ipcache) where update cache [] = cache update cache (name:names) = WARN( not (key `elemFM` cache), ppr name ) @@ -110,7 +111,7 @@ newLocalTopBinder :: Module -> OccName -> RnM d Name newLocalTopBinder mod occ rec_exp_fn loc = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (moduleName mod,occ) mk_prov name = LocalDef loc (rec_exp_fn name) @@ -134,7 +135,7 @@ newLocalTopBinder mod occ rec_exp_fn loc new_name = setNameProvenance name (mk_prov new_name) new_cache = addToFM cache key new_name in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` returnRn new_name -- Miss in the cache! @@ -145,8 +146,21 @@ newLocalTopBinder mod occ rec_exp_fn loc new_name = mkGlobalName uniq mod occ (mk_prov new_name) new_cache = addToFM cache key new_name in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` returnRn new_name + +getIPName rdr_name + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + case lookupFM ipcache key of + Just name -> returnRn name + Nothing -> setNameSupplyRn (us', inst_ns, cache, new_ipcache) `thenRn_` + returnRn name + where + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + name = mkIPName uniq key + new_ipcache = addToFM ipcache key name + where key = (rdrNameOcc rdr_name) \end{code} %********************************************************* @@ -214,7 +228,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope returnRn () ) `thenRn_` - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> getModeRn `thenRn` \ mode -> let n = length rdr_names_w_loc @@ -229,7 +243,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope -- Keep track of whether the name originally came from -- an interface file. in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` + setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_` let new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) @@ -254,13 +268,13 @@ bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) bindCoreLocalFVRn rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` + setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_` let new_name_env = extendRdrEnv name_env rdr_name name in diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index e7d98b9..a4c7e7d 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -282,6 +282,10 @@ rnExpr (HsVar v) -- The normal case returnRn (HsVar name, unitFV name) +rnExpr (HsIPVar v) + = getIPName v `thenRn` \ name -> + returnRn (HsIPVar name, emptyFVs) + rnExpr (HsLit lit) = litOccurrence lit `thenRn` \ fvs -> returnRn (HsLit lit, fvs) @@ -367,6 +371,11 @@ rnExpr (HsLet binds expr) rnExpr expr `thenRn` \ (expr',fvExpr) -> returnRn (HsLet binds' expr', fvExpr) +rnExpr (HsWith expr binds) + = rnExpr expr `thenRn` \ (expr',fvExpr) -> + rnIPBinds binds `thenRn` \ (binds',fvBinds) -> + returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds) + rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupImplicitOccRn monadClass_RDR `thenRn` \ monad -> @@ -491,6 +500,22 @@ rnRpats rpats %************************************************************************ %* * +\subsubsection{@rnIPBinds@s: in implicit parameter bindings} * +%* * +%************************************************************************ + +\begin{code} +rnIPBinds [] = returnRn ([], emptyFVs) +rnIPBinds ((n, expr) : binds) + = getIPName n `thenRn` \ name -> + rnExpr expr `thenRn` \ (expr',fvExpr) -> + rnIPBinds binds `thenRn` \ (binds',fvBinds) -> + returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds) + +\end{code} + +%************************************************************************ +%* * \subsubsection{@Stmt@s: in @do@ expressions} %* * %************************************************************************ diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index d4bcb2f..7e3cef7 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -24,7 +24,7 @@ import Outputable type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name -type RenamedContext = Context Name +type RenamedContext = HsContext Name type RenamedHsDecl = HsDecl Name RenamedPat type RenamedRuleDecl = RuleDecl Name RenamedPat type RenamedTyClDecl = TyClDecl Name RenamedPat @@ -94,8 +94,13 @@ extractHsTyNames_s :: [RenamedHsType] -> NameSet extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys extractHsCtxtTyNames :: RenamedContext -> NameSet -extractHsCtxtTyNames ctxt = foldr (unionNameSets . get) emptyNameSet ctxt - where - get (cls, tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys +extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNameSet ctxt + +-- You don't import or export implicit parameters, so don't mention +-- the IP names +extractHsPredTyNames (HsPClass cls tys) + = unitNameSet cls `unionNameSets` extractHsTyNames_s tys +extractHsPredTyNames (HsPIParam n ty) + = extractHsTyNames ty \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 0d1ffae..bcc220b 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -214,6 +214,8 @@ type RnNameSupply , FiniteMap (ModuleName, OccName) Name -- Ensures that one (module,occname) pair gets one unique + , FiniteMap OccName Name + -- Ensures that one implicit parameter name gets one unique ) @@ -370,7 +372,7 @@ initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc initRn mod us dirs loc do_rn = do himaps <- mkModuleHiMaps dirs - names_var <- newIORef (us, emptyFM, builtins) + names_var <- newIORef (us, emptyFM, builtins, emptyFM) errs_var <- newIORef (emptyBag,emptyBag) iface_var <- newIORef emptyIfaces let @@ -635,23 +637,23 @@ setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down -- See comments with RnNameSupply above. newInstUniq :: String -> RnM d Int newInstUniq key (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache) -> + = readIORef names_var >>= \ (us, mapInst, cache, ipcache) -> let uniq = case lookupFM mapInst key of Just x -> x+1 Nothing -> 0 mapInst' = addToFM mapInst key uniq in - writeIORef names_var (us, mapInst', cache) >> + writeIORef names_var (us, mapInst', cache, ipcache) >> return uniq getUniqRn :: RnM d Unique getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache) -> + = readIORef names_var >>= \ (us, mapInst, cache, ipcache) -> let (us1,us') = splitUniqSupply us in - writeIORef names_var (us', mapInst, cache) >> + writeIORef names_var (us', mapInst, cache, ipcache) >> return (uniqFromSupply us1) \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index cbcd3dd..26e6dee 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -11,7 +11,7 @@ module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) w import RnExpr import HsSyn import HsPragmas -import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes ) +import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes ) import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars @@ -20,7 +20,7 @@ import RnHsSyn import HsCore import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) -import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, +import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName, lookupImplicitOccRn, bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn, bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, @@ -560,9 +560,11 @@ rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- context in which case it's an error = let mentioned_in_tau = extractHsTyRdrTyVars tau - mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt, - ty <- tys, + mentioned_in_ctxt = nub [tv | p <- ctxt, + ty <- tys_of_pred p, tv <- extractHsTyRdrTyVars ty] + tys_of_pred (HsPClass clas tys) = tys + tys_of_pred (HsPIParam n ty) = [ty] dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names -- dubious = explicitly quantified but not mentioned in tau type @@ -586,20 +588,20 @@ rnHsPolyType doc other_ty = rnHsType doc other_ty -- of the tau-type part, this guarantees that every constraint mentions -- at least one of the free tyvars in ty checkConstraints doc forall_tyvars tau_vars ctxt ty - = mapRn check ctxt `thenRn` \ maybe_ctxt' -> + = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' -> returnRn (catMaybes maybe_ctxt') -- Remove problem ones, to avoid duplicate error message. - where - check ct@(_,tys) - | not_univ = failWithRn Nothing (univErr doc ct ty) - | otherwise = returnRn (Just ct) - where - ct_vars = extractHsTysRdrTyVars tys - - not_univ = -- At least one of the tyvars in each constraint must - -- be universally quantified. This restriction isn't in Hugs - not (any (`elem` forall_tyvars) ct_vars) +checkPred doc forall_tyvars ty p@(HsPClass clas tys) + | not_univ = failWithRn Nothing (univErr doc p ty) + | otherwise = returnRn (Just p) + where + ct_vars = extractHsTysRdrTyVars tys + not_univ = -- At least one of the tyvars in each constraint must + -- be universally quantified. This restriction isn't in Hugs + not (any (`elem` forall_tyvars) ct_vars) +checkPred doc forall_tyvars ty p@(HsPIParam _ _) + = returnRn (Just p) rnForAll doc forall_tyvars ctxt ty = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars -> @@ -676,23 +678,24 @@ rnHsTypes doc tys = mapFvRn (rnHsType doc) tys rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars) rnContext doc ctxt - = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) -> + = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) -> let - (_, dup_asserts) = removeDups cmp_assert theta + (_, dup_asserts) = removeDups (cmpHsPred compare) theta in -- Check for duplicate assertions -- If this isn't an error, then it ought to be: mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` returnRn (theta, plusFVs fvs_s) - where - rn_ctxt (clas, tys) - = lookupOccRn clas `thenRn` \ clas_name -> - rnHsTypes doc tys `thenRn` \ (tys', fvs) -> - returnRn ((clas_name, tys'), fvs `addOneFV` clas_name) - cmp_assert (c1,tys1) (c2,tys2) - = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2) +rnPred doc (HsPClass clas tys) + = lookupOccRn clas `thenRn` \ clas_name -> + rnHsTypes doc tys `thenRn` \ (tys', fvs) -> + returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name) +rnPred doc (HsPIParam n ty) + = getIPName n `thenRn` \ name -> + rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (HsPIParam name ty', fvs) \end{code} \begin{code} @@ -902,9 +905,9 @@ classTyVarNotInOpTyErr clas_tyvar sig dupClassAssertWarn ctxt (assertion : dups) = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (pprClassAssertion assertion), + quotes (pprHsPred assertion), ptext SLIT("in the context:")], - nest 4 (pprContext ctxt <+> ptext SLIT("..."))] + nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] @@ -937,7 +940,7 @@ forAllErr doc ty tyvar univErr doc constraint ty = sep [ptext SLIT("All of the type variable(s) in the constraint") - <+> quotes (pprClassAssertion constraint) + <+> quotes (pprHsPred constraint) <+> ptext SLIT("are already in scope"), nest 4 (ptext SLIT("At least one must be universally quantified here")) ] @@ -945,7 +948,7 @@ univErr doc constraint ty (ptext SLIT("In") <+> doc) ambigErr doc constraint ty - = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprClassAssertion constraint), + = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint), nest 4 (ptext SLIT("in the type:") <+> ppr ty), nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))] $$ diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index d6f59f1..5edea2f 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -18,7 +18,7 @@ import VarSet import VarEnv import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN, - tyVarsOfType, tyVarsOfTypes, applyTys, + tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys, mkForAllTys, boxedTypeKind ) import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList, @@ -972,7 +972,7 @@ mkCallUDs f args } where (tyvars, theta, tau) = splitSigmaTy (idType f) - constrained_tyvars = foldr (unionVarSet . tyVarsOfTypes . snd) emptyVarSet theta + constrained_tyvars = tyVarsOfTheta theta n_tyvars = length tyvars n_dicts = length theta diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 12f1743..ad7df46 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -6,17 +6,22 @@ \begin{code} module Inst ( LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, - plusLIEs, mkLIE, isEmptyLIE, + plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, Inst, OverloadedLit(..), pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, InstanceMapper, - newDictFromOld, newDicts, newDictsAtLoc, - newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun, + newDictFromOld, newDicts, newClassDicts, newDictsAtLoc, + newMethod, newMethodWithGivenTy, newOverloadedLit, + newIPDict, instOverloadedFun, - tyVarsOfInst, instLoc, getDictClassTys, getFunDeps, getFunDepsOfLIE, + tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys, + getFunDeps, getFunDepsOfLIE, + getIPs, getIPsOfLIE, + getAllFunDeps, getAllFunDepsOfLIE, + partitionLIEbyMeth, lookupInst, lookupSimpleInst, LookupInstResult(..), @@ -47,18 +52,19 @@ import Class ( classInstEnv, Class ) import FunDeps ( instantiateFdClassTys ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) -import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName ) -import PprType ( pprConstraint ) +import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName, nameUnique ) +import PprType ( pprPred ) import InstEnv ( InstEnv, lookupInstEnv ) import SrcLoc ( SrcLoc ) -import Type ( Type, ThetaType, - mkTyVarTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy, - splitRhoTy, tyVarsOfType, tyVarsOfTypes, +import Type ( Type, PredType(..), ThetaType, + mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy, + splitForAllTys, splitSigmaTy, + splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, mkSynTy, tidyOpenType, tidyOpenTypes ) import InstEnv ( InstEnv ) import Subst ( emptyInScopeSet, mkSubst, - substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst + substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst ) import TyCon ( TyCon ) import Var ( TyVar ) @@ -76,6 +82,7 @@ import Unique ( fromRationalClassOpKey, rationalTyConKey, fromIntClassOpKey, fromIntegerClassOpKey, Unique ) import Maybes ( expectJust ) +import List ( partition ) import Maybe ( catMaybes ) import Util ( thenCmp, zipWithEqual, mapAccumL ) import Outputable @@ -97,6 +104,8 @@ mkLIE insts = listToBag insts plusLIE lie1 lie2 = lie1 `unionBags` lie2 consLIE inst lie = inst `consBag` lie plusLIEs lies = unionManyBags lies +lieToList = bagToList +listToLIE = listToBag zonkLIE :: LIE -> NF_TcM s LIE zonkLIE lie = mapBagNF_Tc zonkInst lie @@ -129,8 +138,7 @@ type Int, represented by data Inst = Dict Unique - Class -- The type of the dict is (c ts), where - [TcType] -- c is the class and ts the types; + TcPredType InstLoc | Method @@ -182,19 +190,24 @@ maps to do their stuff. \begin{code} instance Ord Inst where compare = cmpInst +instance Ord PredType where + compare = cmpPred instance Eq Inst where (==) i1 i2 = case i1 `cmpInst` i2 of EQ -> True other -> False +instance Eq PredType where + (==) p1 p2 = case p1 `cmpPred` p2 of + EQ -> True + other -> False -cmpInst (Dict _ clas1 tys1 _) (Dict _ clas2 tys2 _) - = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2) -cmpInst (Dict _ _ _ _) other +cmpInst (Dict _ pred1 _) (Dict _ pred2 _) + = (pred1 `cmpPred` pred2) +cmpInst (Dict _ _ _) other = LT - -cmpInst (Method _ _ _ _ _ _) (Dict _ _ _ _) +cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) @@ -213,6 +226,13 @@ cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) cmpInst (FunDep _ _ _) other = GT +cmpPred (Class c1 tys1) (Class c2 tys2) + = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2) +cmpPred (IParam n1 ty1) (IParam n2 ty2) + = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2) +cmpPred (Class _ _) (IParam _ _) = LT +cmpPred _ _ = GT + cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT @@ -223,20 +243,52 @@ cmpOverLit (OverloadedFractional _) (OverloadedIntegral _) = GT Selection ~~~~~~~~~ \begin{code} -instLoc (Dict u clas tys loc) = loc +instLoc (Dict u pred loc) = loc instLoc (Method u _ _ _ _ loc) = loc instLoc (LitInst u lit ty loc) = loc instLoc (FunDep _ _ loc) = loc -getDictClassTys (Dict u clas tys _) = (clas, tys) +getDictClassTys (Dict u (Class clas tys) _) = (clas, tys) getFunDeps (FunDep clas fds _) = Just (clas, fds) getFunDeps _ = Nothing -getFunDepsOfLIE lie = catMaybes (map getFunDeps (bagToList lie)) +getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie)) + +getIPsOfPred (IParam n ty) = [(n, ty)] +getIPsOfPred _ = [] +getIPsOfTheta theta = concatMap getIPsOfPred theta + +getIPs (Dict u (IParam n ty) loc) = [(n, ty)] +getIPs (Method u id _ theta t loc) = getIPsOfTheta theta +getIPs _ = [] + +getIPsOfLIE lie = concatMap getIPs (lieToList lie) + +getAllFunDeps (FunDep clas fds _) = fds +getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst) + +getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie)) + +partitionLIEbyMeth pred lie + = foldlTc (partMethod pred) (emptyLIE, emptyLIE) insts + where insts = lieToList lie + +partMethod pred (ips, lie) m@(Method u id tys theta tau loc) + = if null ips_ then + returnTc (ips, consLIE m lie) + else if null theta_ then + returnTc (consLIE m ips, lie) + else + newMethodWith id tys theta_ tau loc `thenTc` \ new_m2 -> + let id_m1 = instToIdBndr new_m2 + new_m1 = Method u id_m1 {- tys -} [] ips_ tau loc in + -- newMethodWith id_m1 tys ips_ tau loc `thenTc` \ new_m1 -> + returnTc (consLIE new_m1 ips, consLIE new_m2 lie) + where (ips_, theta_) = partition pred theta tyVarsOfInst :: Inst -> TcTyVarSet -tyVarsOfInst (Dict _ _ tys _) = tyVarsOfTypes tys +tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id -- The id might have free type variables; in the case of -- locally-overloaded class methods, for example @@ -244,14 +296,21 @@ tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty tyVarsOfInst (FunDep _ fds _) = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds) where tyVarsOfFd (ts1, ts2) = - tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts1 + tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2 + +tyVarsOfInsts insts + = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts) + +tyVarsOfLIE lie + = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts) + where insts = lieToList lie \end{code} Predicates ~~~~~~~~~~ \begin{code} isDict :: Inst -> Bool -isDict (Dict _ _ _ _) = True +isDict (Dict _ (Class _ _) _) = True isDict other = False isMethodFor :: TcIdSet -> Inst -> Bool @@ -261,11 +320,13 @@ isMethodFor ids inst = False isTyVarDict :: Inst -> Bool -isTyVarDict (Dict _ _ tys _) = all isTyVarTy tys -isTyVarDict other = False +isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys +isTyVarDict other = False -isStdClassTyVarDict (Dict _ clas [ty] _) = isStandardClass clas && isTyVarTy ty -isStdClassTyVarDict other = False +isStdClassTyVarDict (Dict _ (Class clas [ty]) _) + = isStandardClass clas && isTyVarTy ty +isStdClassTyVarDict other + = False notFunDep :: Inst -> Bool notFunDep (FunDep _ _ _) = False @@ -279,12 +340,13 @@ must be witnessed by an actual binding; the second tells whether an \begin{code} instBindingRequired :: Inst -> Bool -instBindingRequired (Dict _ clas _ _) = not (isNoDictClass clas) -instBindingRequired other = True +instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas) +instBindingRequired (Dict _ (IParam _ _) _) = False +instBindingRequired other = True instCanBeGeneralised :: Inst -> Bool -instCanBeGeneralised (Dict _ clas _ _) = not (isCcallishClass clas) -instCanBeGeneralised other = True +instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas) +instCanBeGeneralised other = True \end{code} @@ -300,6 +362,12 @@ newDicts orig theta newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) -> returnNF_Tc (listToBag dicts, ids) +newClassDicts :: InstOrigin + -> [(Class,[TcType])] + -> NF_TcM s (LIE, [TcId]) +newClassDicts orig theta + = newDicts orig (map (uncurry Class) theta) + -- Local function, similar to newDicts, -- but with slightly different interface newDictsAtLoc :: InstLoc @@ -308,15 +376,15 @@ newDictsAtLoc :: InstLoc newDictsAtLoc loc theta = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let - mk_dict u (clas, tys) = Dict u clas tys loc + mk_dict u pred = Dict u pred loc dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta in returnNF_Tc (dicts, map instToId dicts) newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst -newDictFromOld (Dict _ _ _ loc) clas tys +newDictFromOld (Dict _ _ loc) clas tys = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (Dict uniq clas tys loc) + returnNF_Tc (Dict uniq (Class clas tys) loc) newMethod :: InstOrigin @@ -337,22 +405,22 @@ instOverloadedFun orig (HsVar v) arg_tys theta tau = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst -> instFunDeps orig theta `thenNF_Tc` \ fds -> returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds)) - --returnNF_Tc (HsVar (instToId inst), unitLIE inst) instFunDeps orig theta = tcGetInstLoc orig `thenNF_Tc` \ loc -> - let ifd (clas, tys) = + let ifd (Class clas tys) = let fds = instantiateFdClassTys clas tys in if null fds then Nothing else Just (FunDep clas fds loc) + ifd _ = Nothing in returnNF_Tc (catMaybes (map ifd theta)) newMethodWithGivenTy orig id tys theta tau = tcGetInstLoc orig `thenNF_Tc` \ loc -> - tcGetUnique `thenNF_Tc` \ new_uniq -> - let - meth_inst = Method new_uniq id tys theta tau loc - in - returnNF_Tc meth_inst + newMethodWith id tys theta tau loc + +newMethodWith id tys theta tau loc + = tcGetUnique `thenNF_Tc` \ new_uniq -> + returnNF_Tc (Method new_uniq id tys theta tau loc) newMethodAtLoc :: InstLoc -> Id -> [TcType] @@ -402,18 +470,28 @@ newOverloadedLit orig lit ty -- The general case returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst) \end{code} +\begin{code} +newIPDict name ty loc + = tcGetUnique `thenNF_Tc` \ new_uniq -> + let d = Dict new_uniq (IParam name ty) loc in + returnNF_Tc d +\end{code} \begin{code} instToId :: Inst -> TcId instToId inst = instToIdBndr inst instToIdBndr :: Inst -> TcId -instToIdBndr (Dict u clas ty (_,loc,_)) +instToIdBndr (Dict u (Class clas ty) (_,loc,_)) = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc +instToIdBndr (Dict u (IParam n ty) (_,loc,_)) +-- = mkUserLocal (mkIPOcc (getOccName n)) u (mkPredTy (IParam n ty)) loc + = mkUserLocal (getOccName n) (nameUnique n) (mkPredTy (IParam n ty)) loc +-- = mkVanillaId n ty instToIdBndr (Method u id tys theta tau (_,loc,_)) = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc - + instToIdBndr (LitInst u list ty loc) = mkSysLocal SLIT("lit") u ty @@ -429,10 +507,18 @@ but doesn't do the same for the Id in a Method. There's no need, and it's a lot of extra work. \begin{code} +zonkPred :: TcPredType -> NF_TcM s 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 s Inst -zonkInst (Dict u clas tys loc) - = zonkTcTypes tys `thenNF_Tc` \ new_tys -> - returnNF_Tc (Dict u clas new_tys loc) +zonkInst (Dict u pred loc) + = zonkPred pred `thenNF_Tc` \ new_pred -> + returnNF_Tc (Dict u new_pred loc) zonkInst (Method u id tys theta tau loc) = zonkId id `thenNF_Tc` \ new_id -> @@ -486,7 +572,7 @@ pprInst (LitInst u lit ty loc) ppr ty, show_uniq u] -pprInst (Dict u clas tys loc) = pprConstraint clas tys <+> show_uniq u +pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u pprInst (Method u id tys _ _ loc) = hsep [ppr id, ptext SLIT("at"), @@ -496,16 +582,26 @@ pprInst (Method u id tys _ _ loc) pprInst (FunDep clas fds loc) = hsep [ppr clas, ppr fds] +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 + 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 env (Dict u clas tys loc) - = (env', Dict u clas tys' loc) +tidyInst env (Dict u pred loc) + = (env', Dict u pred' loc) where - (env', tys') = tidyOpenTypes env tys + (env', pred') = tidyPred env pred tidyInst env (Method u id tys theta tau loc) = (env', Method u id tys' theta tau loc) @@ -559,7 +655,7 @@ lookupInst :: Inst -- Dictionaries -lookupInst dict@(Dict _ clas tys loc) +lookupInst dict@(Dict _ (Class clas tys) loc) = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of Just (tenv, dfun_id) @@ -582,8 +678,9 @@ lookupInst dict@(Dict _ clas tys loc) rhs = mkHsDictApp ty_app dict_ids in returnNF_Tc (GenInst dicts rhs) - + Nothing -> returnNF_Tc NoInstance +lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance -- Methods @@ -642,9 +739,9 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty loc) doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy double_lit = HsCon doubleDataCon [] [doubleprim_lit] --- there are no `instances' of functional dependencies +-- there are no `instances' of functional dependencies or implicit params -lookupInst (FunDep _ _ _) = returnNF_Tc NoInstance +lookupInst _ = returnNF_Tc NoInstance \end{code} @@ -656,15 +753,16 @@ ambiguous dictionaries. \begin{code} lookupSimpleInst :: InstEnv -> Class - -> [Type] -- Look up (c,t) - -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s + -> [Type] -- Look up (c,t) + -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s lookupSimpleInst class_inst_env clas tys = case lookupInstEnv (ppr clas) class_inst_env tys of Nothing -> returnNF_Tc Nothing Just (tenv, dfun) - -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta)) + -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta')) where (_, theta, _) = splitSigmaTy (idType dfun) + theta' = map (\(Class clas tys) -> (clas,tys)) theta \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index f0679f3..ec5a592 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -20,8 +20,8 @@ import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) import TcMonad import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..), - newDicts, tyVarsOfInst, instToId, getFunDepsOfLIE, - zonkFunDeps + newDicts, tyVarsOfInst, instToId, + getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps ) import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, newLocalId, @@ -46,12 +46,12 @@ import PrelInfo ( main_NAME, ioTyCon_NAME ) import Id ( Id, mkVanillaId, setInlinePragma ) import Var ( idType, idName ) -import IdInfo ( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) ) +import IdInfo ( setInlinePragInfo, InlinePragInfo(..) ) import Name ( Name, getName, getOccName, getSrcLoc ) import NameSet import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, - mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, + mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, isUnboxedType, unboxedTypeKind, boxedTypeKind ) import FunDeps ( tyVarFunDep, oclose ) @@ -290,8 +290,9 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- SIMPLIFY THE LIE tcExtendGlobalTyVars tyvars_not_to_gen ( - if null real_tyvars_to_gen_list then - -- No polymorphism, so no need to simplify context + let ips = getIPsOfLIE lie_req in + if null real_tyvars_to_gen_list && null ips then + -- No polymorphism, and no IPs, so no need to simplify context returnTc (lie_req, EmptyMonoBinds, []) else case maybe_sig_theta of @@ -300,7 +301,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- NB: no signatures => no polymorphic recursion, so no -- need to use lie_avail (which will be empty anyway) tcSimplify (text "tcBinds1" <+> ppr binder_names) - top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) -> + real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) -> returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound)) Just (sig_theta, lie_avail) -> @@ -408,6 +409,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- BUILD RESULTS returnTc ( + -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $ AbsBinds real_tyvars_to_gen_list dicts_bound exports @@ -539,7 +541,7 @@ getTyVarsToGen is_unrestricted mono_id_tys lie in if is_unrestricted then - let fds = concatMap snd (getFunDepsOfLIE lie) in + let fds = getAllFunDepsOfLIE lie in zonkFunDeps fds `thenNF_Tc` \ fds' -> let tvFundep = tyVarFunDep fds' extended_tyvars = oclose tvFundep body_tyvars in @@ -551,7 +553,7 @@ getTyVarsToGen is_unrestricted mono_id_tys lie recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $ discardErrsTc $ - tcSimplify (text "getTVG") NotTopLevel body_tyvars lie `thenTc` \ (_, _, constrained_dicts) -> + tcSimplify (text "getTVG") body_tyvars lie `thenTc` \ (_, _, constrained_dicts) -> let -- ASSERT: dicts_sig is already zonked! constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts @@ -792,7 +794,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs = tcAddSrcLoc src_loc $ checkTc (null theta) (mainContextsErr id) - mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta] + mk_dict_tys theta = map mkPredTy theta sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"), nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)] diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index a623b73..bd07d22 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -12,8 +12,9 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), InPat(..), HsBinds(..), GRHSs(..), - HsExpr(..), HsLit(..), HsType(..), pprClassAssertion, - unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName, + HsExpr(..), HsLit(..), HsType(..), HsPred(..), + pprHsClassAssertion, unguardedRHS, + andMonoBinds, andMonoBindList, getTyVarName, isClassDecl, isClassOpSig, isPragSig, collectMonoBinders ) import HsPragmas ( ClassPragmas(..) ) @@ -50,8 +51,9 @@ import IdInfo import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) ) import NameSet ( emptyNameSet ) import Outputable -import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, - mkSigmaTy, mkForAllTys, Type, ThetaType, +import Type ( Type, ThetaType, ClassContext, + mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, + mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds, boxedTypeKind, mkArrowKind ) import Var ( tyVarKind, TyVar ) @@ -219,7 +221,7 @@ tc_fd_tyvar v = tcClassContext :: Name -> Class -> [TyVar] -> RenamedContext -- class context -> [Name] -- Names for superclass selectors - -> TcM s (ThetaType, -- the superclass context + -> TcM s (ClassContext, -- the superclass context [Type], -- types of the superclass dictionaries [Id]) -- superclass selector Ids @@ -238,11 +240,12 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names tcContext context `thenTc` \ sc_theta -> let - sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta] + sc_theta' = classesOfPreds sc_theta + sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta'] sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys in -- Done - returnTc (sc_theta, sc_tys, sc_sel_ids) + returnTc (sc_theta', sc_tys, sc_sel_ids) where rec_tyvar_tys = mkTyVarTys rec_tyvars @@ -253,8 +256,8 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names ty = mkForAllTys rec_tyvars $ mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty - check_constraint (c, tys) = checkTc (all is_tyvar tys) - (superClassErr class_name (c, tys)) + check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys) + (superClassErr class_name (c, tys)) is_tyvar (MonoTyVar _) = True is_tyvar other = False @@ -282,7 +285,7 @@ tcClassSig rec_env rec_clas rec_clas_tyvars tcHsTopType op_ty `thenTc` \ local_ty -> let global_ty = mkSigmaTy rec_clas_tyvars - [(rec_clas, mkTyVarTys rec_clas_tyvars)] + [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)] local_ty -- Build the selector id and default method id @@ -463,7 +466,7 @@ tcDefaultMethodBinds clas default_binds sigs tc_dm op_item@(_, dm_id, _) = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) -> let - theta = [(clas,inst_tys)] + theta = [(mkClassPred clas inst_tys)] in newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) -> let @@ -642,7 +645,7 @@ classArityErr class_name = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name) superClassErr class_name sc - = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc) + = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc) <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name) defltMethCtxt class_name diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index acc6e77..156a180 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -49,7 +49,7 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, ) import Type ( TauType, mkTyVarTys, mkTyConApp, mkSigmaTy, mkDictTy, isUnboxedType, - splitAlgTyConApp + splitAlgTyConApp, classesToPreds ) import TysWiredIn ( voidTy ) import Var ( TyVar ) @@ -254,9 +254,10 @@ tcDeriving modname fixs rn_name_supply inst_decl_infos_in = vcat (map pp_info inst_infos) $$ ppr extra_binds where pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _) - = ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty])) + = ppr (mkSigmaTy tvs inst_decl_theta' (mkDictTy clas [ty])) $$ ppr mbinds + where inst_decl_theta' = classesToPreds inst_decl_theta \end{code} @@ -471,7 +472,8 @@ add_solns inst_infos_in eqns solns = mkVanillaId (getName tycon) dummy_dfun_ty -- The name is getSrcLoc'd in an error message - dummy_dfun_ty = mkSigmaTy tyvars theta voidTy + theta' = classesToPreds theta + dummy_dfun_ty = mkSigmaTy tyvars theta' voidTy -- All we need from the dfun is its "theta" part, used during -- equation simplification (tcSimplifyThetas). The final -- dfun_id will have the superclass dictionaries as arguments too, diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 7e5f033..273d259 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -10,7 +10,7 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), HsBinds(..), Stmt(..), StmtCtxt(..), - mkMonoBind + mkMonoBind, nullMonoBinds ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) import TcHsSyn ( TcExpr, TcRecordBinds, @@ -21,8 +21,12 @@ import TcMonad import BasicTypes ( RecFlag(..) ) import Inst ( Inst, InstOrigin(..), OverloadedLit(..), - LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit, - newMethod, instOverloadedFun, newDicts ) + LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs, + lieToList, listToLIE, tyVarsOfLIE, zonkLIE, + newOverloadedLit, newMethod, newIPDict, + instOverloadedFun, newDicts, newClassDicts, + partitionLIEbyMeth, getIPsOfLIE + ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcInstId, tcLookupValue, tcLookupClassByKey, @@ -33,7 +37,7 @@ import TcEnv ( tcInstId, import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt ) import TcPat ( badFieldCon ) -import TcSimplify ( tcSimplifyAndCheck ) +import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) import TcType ( TcType, TcTauType, tcInstTyVars, tcInstTcType, tcSplitRhoTy, @@ -44,13 +48,14 @@ import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType ) import Id ( idType, recordSelectorFieldLabel, isRecordSelector, - Id + Id, mkVanillaId ) import DataCon ( dataConFieldLabels, dataConSig, dataConId, dataConStrictMarks, StrictnessMark(..) ) -import Name ( Name ) +import Name ( Name, getName ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, + ipName_maybe, splitFunTy_maybe, splitFunTys, isNotUsgTy, mkTyConApp, splitForAllTys, splitRhoTy, @@ -59,9 +64,9 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, boxedTypeKind, mkArrowKind, tidyOpenType ) -import Subst ( mkTopTyVarSubst, substTheta ) +import Subst ( mkTopTyVarSubst, substClasses ) import UsageSPUtils ( unannotTy ) -import VarSet ( elemVarSet, mkVarSet ) +import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet ) import TyCon ( tyConDataCons ) import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy @@ -177,7 +182,7 @@ tcPolyExpr arg expected_arg_ty \begin{code} tcMonoExpr :: RenamedHsExpr -- Expession to type check - -> TcTauType -- Expected type (could be a type variable) + -> TcTauType -- Expected type (could be a type variable) -> TcM s (TcExpr, LIE) tcMonoExpr (HsVar name) res_ty @@ -193,6 +198,14 @@ tcMonoExpr (HsVar name) res_ty returnTc (expr', lie) \end{code} +\begin{code} +tcMonoExpr (HsIPVar name) res_ty + = let id = mkVanillaId name res_ty in + tcGetInstLoc (OccurrenceOf id) `thenNF_Tc` \ loc -> + newIPDict name res_ty loc `thenNF_Tc` \ ip -> + returnNF_Tc (HsIPVar id, unitLIE ip) +\end{code} + %************************************************************************ %* * \subsection{Literals} @@ -217,8 +230,8 @@ tcMonoExpr (HsLit (HsFrac f)) res_ty tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> - newDicts (LitLitOrigin (_UNPK_ s)) - [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) -> + newClassDicts (LitLitOrigin (_UNPK_ s)) + [(cCallableClass,[res_ty])] `thenNF_Tc` \ (dicts, _) -> returnTc (HsLitOut lit res_ty, dicts) \end{code} @@ -347,8 +360,8 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) - = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) - [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) -> + = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) + [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) -> returnNF_Tc arg_dicts -- Actually a singleton bag result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -} @@ -375,7 +388,7 @@ tcMonoExpr (CCall 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 -> - newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) -> + newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) -> returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty]) (CCall lbl args' may_gc is_asm result_ty), -- do the wrapping in the newtype constructor here @@ -617,9 +630,9 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let (tyvars, theta, _, _, _, _) = dataConSig (head data_cons) inst_env = mkTopTyVarSubst tyvars result_inst_tys - theta' = substTheta inst_env theta + theta' = substClasses inst_env theta in - newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) -> + newClassDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) -> -- Phew! returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds', @@ -711,6 +724,50 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty returnTc (expr, lie) \end{code} +Implicit Parameter bindings. + +\begin{code} +tcMonoExpr (HsWith expr binds) res_ty + = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) -> + tcIPBinds binds `thenTc` \ (binds', types, lie2) -> + partitionLIEbyMeth isBound lie `thenTc` \ (ips, lie') -> + zonkLIE ips `thenTc` \ ips' -> + tcSimplify (text "With!") (tyVarsOfLIE ips') ips' `thenTc` \ res@(_, dict_binds, _) -> + let expr'' = if nullMonoBinds dict_binds + then expr' + else HsLet (MonoBind dict_binds [] NonRecursive) expr' in + tcCheckIPBinds binds' types ips' `thenTc_` + returnTc (HsWith expr'' binds', lie') + where isBound p + = case ipName_maybe p of + Just n -> n `elem` names + Nothing -> False + names = map fst binds + +tcIPBinds ((name, expr) : binds) + = newTyVarTy_OpenKind `thenTc` \ ty -> + let id = mkVanillaId name ty in + tcMonoExpr expr ty `thenTc` \ (expr', lie) -> + zonkTcType ty `thenTc` \ ty' -> + tcIPBinds binds `thenTc` \ (binds', types, lie2) -> + returnTc ((id, expr') : binds', ty : types, lie `plusLIE` lie2) +tcIPBinds [] = returnTc ([], [], emptyLIE) + +tcCheckIPBinds binds types ips + = foldrTc tcCheckIPBind (getIPsOfLIE ips) (zip binds types) + +-- ZZ how do we use the loc? +tcCheckIPBind bt@((v, _), t1) ((n, t2) : ips) | getName v == n + = unifyTauTy t1 t2 `thenTc_` + tcCheckIPBind bt ips `thenTc` \ ips' -> + returnTc ips' +tcCheckIPBind bt (ip : ips) + = tcCheckIPBind bt ips `thenTc` \ ips' -> + returnTc (ip : ips') +tcCheckIPBind bt [] + = returnTc [] +\end{code} + Typecheck expression which in most cases will be an Id. \begin{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index e3b11ca..e2ba970 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -346,6 +346,10 @@ zonkExpr (HsVar id) = zonkIdOcc id `thenNF_Tc` \ id' -> returnNF_Tc (HsVar id') +zonkExpr (HsIPVar id) + = zonkIdOcc id `thenNF_Tc` \ id' -> + returnNF_Tc (HsIPVar id') + zonkExpr (HsLit _) = panic "zonkExpr:HsLit" zonkExpr (HsLitOut lit ty) @@ -397,6 +401,16 @@ zonkExpr (HsLet binds expr) zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) +zonkExpr (HsWith expr binds) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkIPBinds binds `thenNF_Tc` \ new_binds -> + returnNF_Tc (HsWith new_expr new_binds) + where + zonkIPBinds = mapNF_Tc zonkIPBind + zonkIPBind (n, e) = + zonkExpr e `thenNF_Tc` \ e' -> + returnNF_Tc (n, e') + zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo" zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs index b9e543e..0cacae3 100644 --- a/ghc/compiler/typecheck/TcImprove.lhs +++ b/ghc/compiler/typecheck/TcImprove.lhs @@ -3,28 +3,26 @@ module TcImprove ( tcImprove ) where #include "HsVersions.h" -import Type ( tyVarsOfTypes ) -import Class ( classInstEnv, classExtraBigSig ) -import Unify ( matchTys ) +import Name ( Name ) +import Type ( Type, tyVarsOfTypes ) +import Class ( className, classInstEnv, classExtraBigSig ) +import Unify ( unifyTyListsX, matchTys ) import Subst ( mkSubst, substTy ) import TcMonad import TcType ( zonkTcType, zonkTcTypes ) import TcUnify ( unifyTauTyLists ) import Inst ( Inst, LookupInstResult(..), - lookupInst, isDict, getDictClassTys, getFunDepsOfLIE, + lookupInst, isDict, getFunDepsOfLIE, getIPsOfLIE, zonkLIE, zonkFunDeps {- for debugging -} ) import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and -- 4.02 doesn't "see" it soon enough -import VarSet ( emptyVarSet ) +import VarSet ( VarSet, emptyVarSet, unionVarSet ) import VarEnv ( emptyVarEnv ) import FunDeps ( instantiateFdClassTys ) -import Bag ( bagToList ) import Outputable -import List ( elemIndex ) +import List ( elemIndex, nub ) \end{code} -Improvement goes here. - \begin{code} tcImprove lie = if null cfdss then @@ -32,16 +30,31 @@ tcImprove lie = else -- zonkCfdss cfdss `thenTc` \ cfdss' -> -- pprTrace "tcI" (ppr cfdss') $ - iterImprove cfdss - where cfdss = getFunDepsOfLIE lie - + iterImprove nfdss + where + cfdss = getFunDepsOfLIE lie + clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss + classes = nub (map fst cfdss) + inst_nfdss = concatMap getInstNfdssOf classes + ips = getIPsOfLIE lie + ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips + nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss + +getInstNfdssOf clas = nfdss + where + nm = className clas + ins = classInstEnv clas + mk_nfds (free, ts, i) = (free, nm, instantiateFdClassTys clas ts) + nfdss = map mk_nfds ins + +iterImprove :: [(VarSet, Name, [([Type],[Type])])] -> TcM s () iterImprove [] = returnTc () iterImprove cfdss = -- zonkCfdss cfdss `thenTc` \ cfdss' -> -- pprTrace "iterI" (ppr cfdss') $ - instImprove cfdss `thenTc` \ change1 -> + -- instImprove cfdss `thenTc` \ change1 -> selfImprove pairImprove cfdss `thenTc` \ change2 -> - if change1 || change2 then + if {- change1 || -} change2 then iterImprove cfdss else returnTc () @@ -53,6 +66,7 @@ zonkCfdss ((c, fds) : cfdss) returnTc ((c, fds') : cfdss') zonkCfdss [] = returnTc [] +{- instImprove (cfds@(clas, fds) : cfdss) = instImprove1 cfds ins `thenTc` \ changed -> instImprove cfdss `thenTc` \ rest_changed -> @@ -67,40 +81,51 @@ instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins) returnTc (changed || rest_changed) where fds2 = instantiateFdClassTys clas ts instImprove1 _ _ = returnTc False - +-} + +-- ZZ this will do a lot of redundant checking wrt instances +-- it would do to make this operate over two lists, the first +-- with only clas_nfds and ip_nfds, and the second with everything +-- control would otherwise mimic the current loop, so that the +-- caller could control whether the redundant inst improvements +-- were avoided +-- you could then also use this to check for consistency of new instances selfImprove f [] = returnTc False -selfImprove f (cfds : cfdss) - = mapTc (f cfds) cfdss `thenTc` \ changes -> +selfImprove f (nfds : nfdss) + = mapTc (f nfds) nfdss `thenTc` \ changes -> anyTc changes `thenTc` \ changed -> - selfImprove f cfdss `thenTc` \ rest_changed -> + selfImprove f nfdss `thenTc` \ rest_changed -> returnTc (changed || rest_changed) -pairImprove (clas1, fds1) (clas2, fds2) - = if clas1 == clas2 then - checkFds fds1 emptyVarSet fds2 +pairImprove (free1, n1, fds1) (free2, n2, fds2) + = if n1 == n2 then + checkFds (free1 `unionVarSet` free2) fds1 fds2 else returnTc False -checkFds [] free [] = returnTc False -checkFds (fd1 : fd1s) free (fd2 : fd2s) = - checkFd fd1 free fd2 `thenTc` \ change -> - checkFds fd1s free fd2s `thenTc` \ changes -> +checkFds free [] [] = returnTc False +checkFds free (fd1 : fd1s) (fd2 : fd2s) = + checkFd free fd1 fd2 `thenTc` \ change -> + checkFds free fd1s fd2s `thenTc` \ changes -> returnTc (change || changes) --checkFds _ _ = returnTc False -checkFd (t_x, t_y) free (s_x, s_y) +checkFd free (t_x, t_y) (s_x, s_y) -- we need to zonk each time because unification -- may happen at any time - = zonkMatchTys t_x free s_x `thenTc` \ msubst -> + = zonkUnifyTys free t_x s_x `thenTc` \ msubst -> case msubst of Just subst -> - let s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y in - zonkEqTys t_y s_y' `thenTc` \ eq -> + let t_y' = map (substTy (mkSubst emptyVarEnv subst)) t_y + s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y + in + zonkEqTys t_y' s_y' `thenTc` \ eq -> if eq then -- they're the same, nothing changes... returnTc False else - unifyTauTyLists t_y s_y' `thenTc_` + -- ZZ what happens if two instance vars unify? + unifyTauTyLists t_y' s_y' `thenTc_` -- if we get here, something must have unified returnTc True Nothing -> @@ -119,6 +144,15 @@ zonkMatchTys ts1 free ts2 Just (subst, []) -> -- pprTrace "zMT match!" empty $ returnTc (Just subst) Nothing -> returnTc Nothing + +zonkUnifyTys free ts1 ts2 + = mapTc zonkTcType ts1 `thenTc` \ ts1' -> + mapTc zonkTcType ts2 `thenTc` \ ts2' -> + -- pprTrace "zMT" (ppr (ts1', free, ts2')) $ + case unifyTyListsX free ts2' ts1' of + Just subst {- (subst, []) -} -> -- pprTrace "zMT match!" empty $ + returnTc (Just subst) + Nothing -> returnTc Nothing \end{code} Utilities: diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index fb74078..ba94e58 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -23,7 +23,8 @@ import TcClassDcl ( tcMethodBind, checkFromThisClass ) import TcMonad import RnMonad ( RnNameSupply, Fixities ) import Inst ( Inst, InstOrigin(..), - newDicts, LIE, emptyLIE, plusLIE, plusLIEs ) + newDicts, newClassDicts, + LIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcInstId @@ -51,11 +52,12 @@ import SrcLoc ( SrcLoc ) import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings ) import Type ( Type, isUnLiftedType, mkTyVarTys, splitSigmaTy, isTyVarTy, - splitTyConApp_maybe, splitDictTy_maybe, unUsgTy, - splitAlgTyConApp_maybe, - tyVarsOfTypes + splitTyConApp_maybe, splitDictTy_maybe, + getClassTys_maybe, splitAlgTyConApp_maybe, + classesToPreds, classesOfPreds, + unUsgTy, tyVarsOfTypes ) -import Subst ( mkTopTyVarSubst, substTheta ) +import Subst ( mkTopTyVarSubst, substClasses ) import VarSet ( mkVarSet, varSetElems ) import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy ) @@ -175,9 +177,10 @@ tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc) tcHsTopType poly_ty `thenTc` \ poly_ty' -> let (tyvars, theta, dict_ty) = splitSigmaTy poly_ty' - (clas, inst_tys) = case splitDictTy_maybe dict_ty of - Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty) - Just pair -> pair + constr = classesOfPreds theta + (clas, inst_tys) = case splitDictTy_maybe dict_ty of + Just ct -> ct + Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty) in -- Check for respectable instance type, and context @@ -187,19 +190,19 @@ tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc) -- instance CCallable [Char] (if isLocallyDefined dfun_name then scrutiniseInstanceHead clas inst_tys `thenNF_Tc_` - mapNF_Tc scrutiniseInstanceConstraint theta + mapNF_Tc scrutiniseInstanceConstraint constr else returnNF_Tc [] ) `thenNF_Tc_` -- Make the dfun id let - dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta + dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr -- Add info from interface file final_dfun_id = tcAddImportedIdInfo unf_env dfun_id in - returnTc (unitBag (InstInfo clas tyvars inst_tys theta + returnTc (unitBag (InstInfo clas tyvars inst_tys constr final_dfun_id binds src_loc uprags)) \end{code} @@ -329,17 +332,17 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys dm_ids = [dm_id | (_, dm_id, _) <- op_items] -- Instantiate the theta found in the original instance decl - inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) - inst_decl_theta + inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) + inst_decl_theta -- Instantiate the super-class context with inst_tys - sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta + sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta in -- Create dictionary Ids from the specified instance contexts. - newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> + newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) -> - newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> - newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> + newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> -- Check that all the method bindings come from this class checkFromThisClass clas op_items monobinds `thenNF_Tc_` @@ -348,8 +351,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys tcExtendGlobalValEnv dm_ids ( -- Default-method Ids may be mentioned in synthesised RHSs - mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta' - monobinds uprags True) + mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' + (classesToPreds inst_decl_theta') + monobinds uprags True) op_items )) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 830140a..e3221a8 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -27,7 +27,7 @@ import InstEnv ( InstEnv, emptyInstEnv, addToInstEnv ) import Maybes ( MaybeErr(..), mkLookupFunDef ) import Name ( getSrcLoc, nameModule, isLocallyDefined ) import SrcLoc ( SrcLoc ) -import Type ( ThetaType, Type ) +import Type ( ThetaType, Type, ClassContext ) import PprType ( pprConstraint ) import Class ( classTyCon ) import DataCon ( DataCon ) @@ -45,7 +45,7 @@ data InstInfo Class -- Class, k [TyVar] -- Type variables, tvs [Type] -- The types at which the class is being instantiated - ThetaType -- inst_decl_theta: the original context, c, from the + ClassContext -- inst_decl_theta: the original context, c, from the -- instance declaration. It constrains (some of) -- the TyVars above Id -- The dfun id diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 2deadb0..1b442af 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,7 +1,7 @@ \begin{code} module TcMonad( TcType, - TcTauType, TcThetaType, TcRhoType, + TcTauType, TcPredType, TcThetaType, TcRhoType, TcTyVar, TcTyVarSet, TcKind, @@ -47,7 +47,7 @@ import {-# SOURCE #-} TcEnv ( TcEnv ) import HsSyn ( HsLit ) import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr ) -import Type ( Type, Kind, ThetaType, RhoType, TauType, +import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType, ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg ) import CmdLineOpts ( opt_PprStyle_Debug ) @@ -91,6 +91,7 @@ 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 TcPredType = PredType type TcThetaType = ThetaType type TcRhoType = RhoType type TcTauType = TauType diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index bd94924..4fe0e3e 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -14,7 +14,7 @@ module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsT #include "HsVersions.h" import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..), - Sig(..), pprClassAssertion, pprParendHsType ) + Sig(..), HsPred(..), pprHsPred, pprParendHsType ) import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig ) import TcHsSyn ( TcId ) @@ -30,7 +30,7 @@ import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, ) import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr ) import TcUnify ( unifyKind, unifyKinds, unifyTypeKind ) -import Type ( Type, ThetaType, UsageAnn(..), +import Type ( Type, PredType(..), ThetaType, UsageAnn(..), mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, mkUsForAllTy, zipFunTys, mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, @@ -162,7 +162,7 @@ tc_type_kind (MonoTyApp ty1 ty2) = tc_app ty1 [ty2] tc_type_kind (MonoDictTy class_name tys) - = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) -> + = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) -> returnTc (boxedTypeKind, mkDictTy clas arg_tys) tc_type_kind (MonoUsgTy usg ty) @@ -197,8 +197,8 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty) -- give overloaded functions like -- f :: forall a. Num a => (# a->a, a->a #) -- And we want these to get through the type checker - check ct@(c,tys) | ambiguous = failWithTc (ambigErr ct tau) - | otherwise = returnTc () + check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau) + | otherwise = returnTc () where ct_vars = tyVarsOfTypes tys forall_tyvars = map varName in_scope_vars tau_vars = tyVarsOfType tau @@ -287,12 +287,13 @@ tcContext context mapTc tcClassAssertion context where - check_naughty (class_name, _) + check_naughty (HsPClass class_name _) = checkTc (not (getUnique class_name `elem` cCallishClassKeys)) (naughtyCCallContextErr class_name) + check_naughty (HsPIParam _ _) = returnTc () -tcClassAssertion assn@(class_name, tys) - = tcAddErrCtxt (appKindCtxt (pprClassAssertion assn)) $ +tcClassAssertion assn@(HsPClass class_name tys) + = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $ mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> tcLookupTy class_name `thenTc` \ (kind, ~(Just arity), thing) -> case thing of @@ -302,10 +303,14 @@ tcClassAssertion assn@(class_name, tys) -- Check with kind mis-match checkTc (arity == n_tys) err `thenTc_` unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) `thenTc_` - returnTc (clas, arg_tys) + returnTc (Class clas arg_tys) where n_tys = length tys err = arityErr "Class" class_name arity n_tys +tcClassAssertion assn@(HsPIParam name ty) + = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $ + tc_type_kind ty `thenTc` \ (arg_kind, arg_ty) -> + returnTc (IParam name arg_ty) \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 1ece1c8..77a7acb 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -17,7 +17,7 @@ import TcHsSyn ( TcPat, TcId ) import TcMonad import Inst ( Inst, OverloadedLit(..), InstOrigin(..), emptyLIE, plusLIE, LIE, - newMethod, newOverloadedLit, newDicts + newMethod, newOverloadedLit, newDicts, newClassDicts ) import Name ( Name, getOccName, getSrcLoc ) import FieldLabel ( fieldLabelName ) @@ -36,8 +36,8 @@ import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity ) import Id ( Id, idType, isDataConId_maybe ) -import Type ( Type, isTauTy, mkTyConApp, boxedTypeKind ) -import Subst ( substTy, substTheta ) +import Type ( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) +import Subst ( substTy, substClasses ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) @@ -290,7 +290,7 @@ tcPat tc_bndr (LitPatIn lit@(HsLitLit s)) pat_ty -- cf tcExpr on LitLits = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> newDicts (LitLitOrigin (_UNPK_ s)) - [(cCallableClass, [pat_ty])] `thenNF_Tc` \ (dicts, _) -> + [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) -> returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE) \end{code} @@ -407,14 +407,14 @@ tcConstructor pat con_name pat_ty in tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) -> let - ex_theta' = substTheta tenv ex_theta + ex_theta' = substClasses 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 - newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) -> + newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, 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 d80e609..104fc9d 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -131,28 +131,28 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - tyVarsOfInst, + tyVarsOfInst, tyVarsOfInsts, isDict, isStdClassTyVarDict, isMethodFor, notFunDep, instToId, instBindingRequired, instCanBeGeneralised, newDictFromOld, - getDictClassTys, + getDictClassTys, getIPs, instLoc, pprInst, zonkInst, tidyInst, tidyInsts, - Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE, - plusLIE + Inst, LIE, pprInsts, pprInstsInFull, + mkLIE, emptyLIE, plusLIE, lieToList ) import TcEnv ( tcGetGlobalTyVars ) import TcType ( TcType, TcTyVarSet, typeToTcType ) import TcUnify ( unifyTauTy ) import Id ( idType ) -import Bag ( bagToList ) import Class ( Class, classBigSig, classInstEnv ) import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) -import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar, +import Type ( Type, ThetaType, TauType, ClassContext, + mkTyVarTy, getTyVar, isTyVarTy, splitSigmaTy, tyVarsOfTypes ) import InstEnv ( InstEnv ) -import Subst ( mkTopTyVarSubst, substTheta ) +import Subst ( mkTopTyVarSubst, substClasses ) import PprType ( pprConstraint ) import TysWiredIn ( unitTy ) import VarSet @@ -181,7 +181,6 @@ float them out if poss, after inlinings are sorted out. \begin{code} tcSimplify :: SDoc - -> TopLevelFlag -> TcTyVarSet -- ``Local'' type variables -- ASSERT: this tyvar set is already zonked -> LIE -- Wanted @@ -189,11 +188,13 @@ tcSimplify TcDictBinds, -- Bindings LIE) -- Remaining wanteds; no dups -tcSimplify str top_lvl local_tvs wanted_lie +tcSimplify str local_tvs wanted_lie +{- | isEmptyVarSet local_tvs = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE) | otherwise +-} = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> -- Check for non-generalisable insts @@ -219,6 +220,8 @@ tcSimplify str top_lvl local_tvs wanted_lie (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs in + -- pprTrace "tcS" (ppr (frees, irreds')) $ + -- pprTrace "tcS bad" (ppr bad_guys) $ addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_` @@ -235,11 +238,12 @@ tcSimplify str top_lvl local_tvs wanted_lie -- dependencies as hidden constraints (i.e. they'd only -- show up in interface files) -- or maybe they'd be useful -- as first class predicates... - wanteds = filter notFunDep (bagToList wanted_lie) + wanteds = filter notFunDep (lieToList wanted_lie) try_me inst -- Does not constrain a local tyvar | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + && null (getIPs inst) = -- if is_top_level then -- FreeIfTautological -- Special case for inference on -- -- top-level defns @@ -281,9 +285,9 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie -- Done returnTc (mkLIE frees, binds) where - givens = bagToList given_lie + givens = lieToList given_lie -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (bagToList wanted_lie) + wanteds = filter notFunDep (lieToList wanted_lie) given_dicts = filter isDict givens try_me inst @@ -329,7 +333,7 @@ tcSimplifyToDicts wanted_lie returnTc (mkLIE irreds, binds) where -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (bagToList wanted_lie) + wanteds = filter notFunDep (lieToList wanted_lie) -- Reduce methods and lits only; stop as soon as we get a dictionary try_me inst | isDict inst = DontReduce @@ -428,10 +432,10 @@ data RHS -- Invariant: these Insts are already in the finite mapping -pprAvails avails = vcat (map pp (eltsFM avails)) - where - pp (Avail main_id rhs ids) - = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs +pprAvails avails = vcat (map pprAvail (eltsFM avails)) + +pprAvail (Avail main_id rhs ids) + = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs pprRhs NoRhs = text "" pprRhs (Rhs rhs b) = ppr rhs @@ -703,7 +707,10 @@ addGiven avails given -- This assertion isn't necessarily true. It's permitted -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...) -- and when typechecking instance decls we generate redundant "givens" too. - addAvail avails given avail + -- addAvail avails given avail + addAvail avails given avail `thenNF_Tc` \av -> + zonkInst given `thenNF_Tc` \given' -> + returnNF_Tc av where avail = Avail (instToId given) NoRhs [] @@ -724,7 +731,7 @@ addSuperClasses avails dict (clas, tys) = getDictClassTys dict (tyvars, sc_theta, sc_sels, _) = classBigSig clas - sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta + sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta add_sc avails ((super_clas, super_tys), sc_sel) = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict -> @@ -775,8 +782,8 @@ instance declarations. \begin{code} tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv - -> ThetaType -- Wanted - -> TcM s ThetaType -- Needed + -> ClassContext -- Wanted + -> TcM s ClassContext -- Needed tcSimplifyThetas inst_mapper wanteds = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds -> @@ -803,8 +810,8 @@ used with \tr{default} declarations. We are only interested in whether it worked or not. \begin{code} -tcSimplifyCheckThetas :: ThetaType -- Given - -> ThetaType -- Wanted +tcSimplifyCheckThetas :: ClassContext -- Given + -> ClassContext -- Wanted -> TcM s () tcSimplifyCheckThetas givens wanteds @@ -818,14 +825,14 @@ tcSimplifyCheckThetas givens wanteds \begin{code} -type AvailsSimple = FiniteMap (Class, [TauType]) Bool +type AvailsSimple = FiniteMap (Class,[Type]) Bool -- True => irreducible -- False => given, or can be derived from a given or from an irreducible reduceSimple :: (Class -> InstEnv) - -> ThetaType -- Given - -> ThetaType -- Wanted - -> NF_TcM s ThetaType -- Irreducible + -> ClassContext -- Given + -> ClassContext -- Wanted + -> NF_TcM s ClassContext -- Irreducible reduceSimple inst_mapper givens wanteds = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> @@ -833,10 +840,10 @@ reduceSimple inst_mapper givens wanteds where givens_fm = foldl addNonIrred emptyFM givens -reduce_simple :: (Int,ThetaType) -- Stack +reduce_simple :: (Int,ClassContext) -- Stack -> (Class -> InstEnv) -> AvailsSimple - -> ThetaType + -> ClassContext -> NF_TcM s AvailsSimple reduce_simple (n,stack) inst_mapper avails wanteds @@ -857,29 +864,30 @@ reduce_simple_help stack inst_mapper givens wanted@(clas,tys) Nothing -> returnNF_Tc (addIrred givens wanted) Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta -addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple -addIrred givens ct +addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple +addIrred givens ct@(clas,tys) = addSCs (addToFM givens ct True) ct -addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple -addNonIrred givens ct +addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple +addNonIrred givens ct@(clas,tys) = addSCs (addToFM givens ct False) ct addSCs givens ct@(clas,tys) = foldl add givens sc_theta where (tyvars, sc_theta_tmpl, _, _) = classBigSig clas - sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl + sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl - add givens ct = case lookupFM givens ct of - Nothing -> -- Add it and its superclasses - addSCs (addToFM givens ct False) ct + add givens ct@(clas, tys) + = case lookupFM givens ct of + Nothing -> -- Add it and its superclasses + addSCs (addToFM givens ct False) ct - Just True -> -- Set its flag to False; superclasses already done - addToFM givens ct False + Just True -> -- Set its flag to False; superclasses already done + addToFM givens ct False - Just False -> -- Already done - givens + Just False -> -- Already done + givens \end{code} @@ -933,7 +941,7 @@ bindInstsOfLocalFuns init_lie local_ids -- No sense in repeatedly zonking lots of -- constant constraints so filter them out here (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set) - (bagToList init_lie) + (lieToList init_lie) try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds | otherwise = Free \end{code} @@ -1014,12 +1022,13 @@ tcSimplifyTop wanted_lie returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig) where -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (bagToList wanted_lie) + wanteds = filter notFunDep (lieToList wanted_lie) try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 - complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d + complain d | not (null (getIPs d)) = addTopIPErr d + | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d | otherwise = addAmbigErr tyVarsOfInst d get_tv d = case getDictClassTys d of @@ -1184,6 +1193,13 @@ addRuleLhsErr dict where (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict +addTopIPErr dict + = addInstErrTcM (instLoc dict) + (tidy_env, + ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict)) + where + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict + -- Used for top-level irreducibles addTopInstanceErr dict = addInstErrTcM (instLoc dict) @@ -1201,7 +1217,7 @@ addNoInstanceErr str givens dict ptext SLIT("Probable cause:") <+> vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict), ptext SLIT("in") <+> str], - if all_tyvars then empty else + if isDict dict && all_tyvars then empty else ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)] ) where diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 3535313..d722a9c 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -13,7 +13,7 @@ module TcTyClsDecls ( import HsSyn ( HsDecl(..), TyClDecl(..), HsType(..), HsTyVar, ConDecl(..), ConDetails(..), BangType(..), - Sig(..), + Sig(..), HsPred(..), tyClDeclName, isClassDecl, isSynDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name ) @@ -272,7 +272,7 @@ Edges in Type/Class decls mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique]) mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _) - = Just (decl, getUnique name, map (getUnique . fst) ctxt) + = Just (decl, getUnique name, map (getUnique . get_clas) ctxt) mk_cls_edges other_decl = Nothing @@ -293,7 +293,8 @@ mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _) ---------------------------------------------------- -get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt) +get_ctxt ctxt = unionManyUniqSets (map (set_name . get_clas) ctxt) +get_clas (HsPClass clas _) = clas ---------------------------------------------------- get_deriv Nothing = emptyUniqSet diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index ed94366..1a3c2c3 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -24,7 +24,7 @@ import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope, tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType, tcContext, tcHsTopTypeKind ) -import TcType ( zonkTcTyVarToTyVar, zonkTcThetaType ) +import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints ) import TcEnv ( tcLookupTy, TcTyThing(..) ) import TcMonad import TcUnify ( unifyKind ) @@ -48,7 +48,7 @@ import Type ( getTyVar, tyVarsOfTypes, mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, mkTyVarTy, mkArrowKind, mkArrowKinds, boxedTypeKind, - isUnboxedType, Type, ThetaType + isUnboxedType, Type, ThetaType, classesOfPreds ) import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) @@ -128,7 +128,8 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ -- Typecheck the pieces tcContext context `thenTc` \ ctxt -> - mapTc (tcConDecl rec_tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> + let ctxt' = classesOfPreds ctxt in + mapTc (tcConDecl rec_tycon tyvars ctxt') con_decls `thenTc` \ data_cons -> tc_derivs derivings `thenTc` \ derived_classes -> let @@ -141,7 +142,7 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name) tycon_name - tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs + tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs data_cons derived_classes Nothing -- Not a dictionary @@ -164,13 +165,14 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ %************************************************************************ \begin{code} -tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s DataCon +tcConDecl :: TyCon -> [TyVar] -> [(Class,[Type])] -> RenamedConDecl -> TcM s DataCon tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc) = tcAddSrcLoc src_loc $ tcExtendTyVarScope ex_tvs $ \ ex_tyvars -> tcContext ex_ctxt `thenTc` \ ex_theta -> - tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details + let ex_ctxt' = classesOfPreds ex_theta in + tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_ctxt' details tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details = case details of @@ -223,7 +225,7 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details -- immutable type variables. (The top-level tyvars are -- already fixed, by the preceding kind-inference pass.) mapNF_Tc zonkTcTyVarToTyVar ex_tyvars `thenNF_Tc` \ ex_tyvars' -> - zonkTcThetaType ex_theta `thenNF_Tc` \ ex_theta' -> + zonkTcClassConstraints ex_theta `thenNF_Tc` \ ex_theta' -> let data_con = mkDataCon name arg_stricts fields tyvars (thinContext arg_tys ctxt) diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 4f33951..dd48b71 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -40,7 +40,7 @@ module TcType ( -------------------------------- zonkTcTyVar, zonkTcTyVars, zonkTcTyVarBndr, - zonkTcType, zonkTcTypes, zonkTcThetaType, + zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcKindToKind @@ -55,9 +55,9 @@ import PprType ( pprType ) import TypeRep ( Type(..), Kind, TyNote(..), typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity ) -- friend -import Type ( ThetaType, +import Type ( ThetaType, PredType(..), mkAppTy, mkTyConApp, - splitDictTy_maybe, splitForAllTys, isNotUsgTy, + splitPredTy_maybe, splitForAllTys, isNotUsgTy, isTyVarTy, mkTyVarTy, mkTyVarTys, ) import Subst ( Subst, mkTopTyVarSubst, substTy ) @@ -108,7 +108,7 @@ tcSplitRhoTy t where -- A type variable is never instantiated to a dictionary type, -- so we don't need to do a tcReadVar on the "arg". - go syn_t (FunTy arg res) ts = case splitDictTy_maybe arg of + go syn_t (FunTy arg res) ts = case splitPredTy_maybe arg of Just pair -> go res res (pair:ts) Nothing -> returnNF_Tc (reverse ts, syn_t) go syn_t (NoteTy _ t) ts = go syn_t t ts @@ -331,11 +331,21 @@ zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty zonkTcTypes :: [TcType] -> NF_TcM s [TcType] zonkTcTypes tys = mapNF_Tc zonkTcType tys +zonkTcClassConstraints cts = mapNF_Tc zonk cts + where zonk (clas, tys) + = zonkTcTypes tys `thenNF_Tc` \ new_tys -> + returnNF_Tc (clas, new_tys) + zonkTcThetaType :: TcThetaType -> NF_TcM s TcThetaType -zonkTcThetaType theta = mapNF_Tc zonk theta - where - zonk (c,ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts -> - returnNF_Tc (c, new_ts) +zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta + +zonkTcPredType :: TcPredType -> NF_TcM s TcPredType +zonkTcPredType (Class c ts) = + zonkTcTypes ts `thenNF_Tc` \ new_ts -> + returnNF_Tc (Class c new_ts) +zonkTcPredType (IParam n t) = + zonkTcType t `thenNF_Tc` \ new_t -> + returnNF_Tc (IParam n new_t) zonkTcKind :: TcKind -> NF_TcM s TcKind zonkTcKind = zonkTcType @@ -444,6 +454,9 @@ zonkType unbound_var_fn ty go (NoteTy (UsgForAll uv) ty2)= go ty2 `thenNF_Tc` \ ty2' -> returnNF_Tc (NoteTy (UsgForAll uv) ty2') + go (NoteTy (IPNote nm) ty2) = go ty2 `thenNF_Tc` \ ty2' -> + returnNF_Tc (NoteTy (IPNote nm) ty2') + go (FunTy arg res) = go arg `thenNF_Tc` \ arg' -> go res `thenNF_Tc` \ res' -> returnNF_Tc (FunTy arg' res') diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 4083f56..035a12c 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -8,7 +8,7 @@ module Class ( Class, ClassOpItem, mkClass, classTyVars, - classKey, classSelIds, classTyCon, + classKey, className, classSelIds, classTyCon, classBigSig, classExtraBigSig, classInstEnv, classTvsFds ) where diff --git a/ghc/compiler/types/PprType.hi-boot b/ghc/compiler/types/PprType.hi-boot index 0d8436e..ee67e73 100644 --- a/ghc/compiler/types/PprType.hi-boot +++ b/ghc/compiler/types/PprType.hi-boot @@ -1,6 +1,7 @@ _interface_ PprType 1 _exports_ -PprType pprType; +PprType pprType pprPred; _declarations_ 1 pprType _:_ TypeRep.Type -> Outputable.SDoc ;; +1 pprPred _:_ Type.PredType -> Outputable.SDoc ;; diff --git a/ghc/compiler/types/PprType.hi-boot-5 b/ghc/compiler/types/PprType.hi-boot-5 index b08f9b8..75ea5c9 100644 --- a/ghc/compiler/types/PprType.hi-boot-5 +++ b/ghc/compiler/types/PprType.hi-boot-5 @@ -1,4 +1,5 @@ __interface PprType 1 0 where -__export PprType pprType ; +__export PprType pprType pprPred ; 1 pprType :: TypeRep.Type -> Outputable.SDoc ; +1 pprPred :: Type.PredType -> Outputable.SDoc ; diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 116f12e..24294ba 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,7 +7,7 @@ module PprType( pprKind, pprParendKind, pprType, pprParendType, - pprConstraint, pprTheta, + pprConstraint, pprPred, pprTheta, pprTyVarBndr, pprTyVarBndrs, -- Junk @@ -21,8 +21,8 @@ module PprType( import TypeRep ( Type(..), TyNote(..), Kind, UsageAnn(..), boxedTypeKind, ) -- friend -import Type ( ThetaType, - splitDictTy_maybe, +import Type ( PredType(..), ThetaType, + splitPredTy_maybe, splitForAllTys, splitSigmaTy, splitRhoTy, isDictTy, splitTyConApp_maybe, splitFunTy_maybe, splitUsForAllTys @@ -35,7 +35,7 @@ import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon, tyConArity, tyConUnique ) -import Class ( Class ) +import Class ( Class, className ) -- others: import Maybes ( maybeToBool ) @@ -67,13 +67,15 @@ pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType +pprPred :: PredType -> SDoc +pprPred (Class clas tys) = pprConstraint clas tys +pprPred (IParam n ty) = ppr n <+> ppr ty + pprConstraint :: Class -> [Type] -> SDoc pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys) pprTheta :: ThetaType -> SDoc -pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta))) - where - ppr_dict (c,tys) = pprConstraint c tys +pprTheta theta = parens (hsep (punctuate comma (map pprPred theta))) instance Outputable Type where ppr ty = pprType ty @@ -140,8 +142,8 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) -- DICTIONARY CASE, prints {C a} -- This means that instance decls come out looking right in interfaces -- and that in turn means they get "gated" correctly when being slurped in - | maybeToBool maybe_dict - = braces (ppr_dict env tYCON_PREC ctys) + | maybeToBool maybe_pred + = braces (ppr_pred env pred) -- NO-ARGUMENT CASE (=> no parens) | null tys @@ -155,8 +157,8 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) tycon_uniq = tyConUnique tycon n_tys = length tys (ty1:_) = tys - Just ctys = maybe_dict - maybe_dict = splitDictTy_maybe ty -- Checks class and arity + Just pred = maybe_pred + maybe_pred = splitPredTy_maybe ty -- Checks class and arity tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys)) tys_w_spaces = sep (map (ppr_ty env tYCON_PREC) tys) @@ -183,11 +185,12 @@ ppr_ty env ctxt_prec ty@(ForAllTy _ _) pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars) ppr_theta [] = empty - ppr_theta theta = parens (hsep (punctuate comma (map ppr_dict theta))) + ppr_theta theta = parens (hsep (punctuate comma (map ppr_pred theta))) <+> ptext SLIT("=>") - ppr_dict (clas,tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys) - + ppr_pred (Class clas tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys) + ppr_pred (IParam n ty) = hsep [char '?' <> ppr n, text "::", + ppr_ty env tYCON_PREC ty] ppr_ty env ctxt_prec (FunTy ty1 ty2) = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest ty2)) @@ -221,11 +224,21 @@ ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty) = maybeParen ctxt_prec tYCON_PREC $ ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty +ppr_ty env ctxt_prec (NoteTy (IPNote nm) ty) + = braces (ppr_pred env (IParam nm ty)) + ppr_theta env [] = empty -ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta))) +ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_pred env) theta))) + +ppr_pred env (Class clas tys) = ppr clas <+> + hsep (map (ppr_ty env tYCON_PREC) tys) +ppr_pred env (IParam n ty) = hsep [char '?' <> ppr n, text "::", + ppr_ty env tYCON_PREC ty] +{- ppr_dict env ctxt (clas, tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys) +-} \end{code} \begin{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index ccd8af7..a060f63 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -34,7 +34,7 @@ module Type ( mkTyConApp, mkTyConTy, splitTyConApp_maybe, splitAlgTyConApp_maybe, splitAlgTyConApp, - mkDictTy, splitDictTy_maybe, isDictTy, + mkDictTy, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy, mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe, @@ -44,9 +44,10 @@ module Type ( mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, isForAllTy, applyTy, applyTys, mkPiType, - TauType, RhoType, SigmaType, ThetaType, - isTauTy, - mkRhoTy, splitRhoTy, + TauType, RhoType, SigmaType, PredType(..), ThetaType, + ClassPred, ClassContext, mkClassPred, + getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds, + isTauTy, mkRhoTy, splitRhoTy, mkSigmaTy, splitSigmaTy, -- Lifting and boxity @@ -54,8 +55,8 @@ module Type ( typePrimRep, -- Free variables - tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, - addFreeTyVars, + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, + namesOfType, typeKind, addFreeTyVars, -- Tidying up for printing tidyType, tidyTypes, @@ -78,7 +79,7 @@ import TypeRep -- Other imports: import {-# SOURCE #-} DataCon( DataCon, dataConType ) -import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages +import {-# SOURCE #-} PprType( pprType, pprPred ) -- Only called in debug messages import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy ) -- friends: @@ -88,7 +89,7 @@ import Var ( TyVar, IdOrTyVar, UVar, import VarEnv import VarSet -import Name ( NamedThing(..), mkLocalName, tidyOccName, +import Name ( Name, NamedThing(..), mkLocalName, tidyOccName, ) import NameSet import Class ( classTyCon, Class ) @@ -329,6 +330,11 @@ tell from the type constructor whether it's a dictionary or not. mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = TyConApp (classTyCon clas) tys +mkPredTy :: PredType -> Type +mkPredTy (Class clas tys) = TyConApp (classTyCon clas) tys +mkPredTy (IParam n ty) = NoteTy (IPNote n) ty + +{- splitDictTy_maybe :: Type -> Maybe (Class, [Type]) splitDictTy_maybe (TyConApp tc tys) | maybeToBool maybe_class @@ -339,6 +345,26 @@ splitDictTy_maybe (TyConApp tc tys) splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty splitDictTy_maybe other = Nothing +-} + +splitPredTy_maybe :: Type -> Maybe PredType +splitPredTy_maybe (TyConApp tc tys) + | maybeToBool maybe_class + && tyConArity tc == length tys = Just (Class clas tys) + where + maybe_class = tyConClass_maybe tc + Just clas = maybe_class + +splitPredTy_maybe (NoteTy (IPNote n) ty) + = Just (IParam n ty) +splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty +splitPredTy_maybe other = Nothing + +splitDictTy_maybe :: Type -> Maybe (Class, [Type]) +splitDictTy_maybe ty + = case splitPredTy_maybe ty of + Just p -> getClassTys_maybe p + Nothing -> Nothing isDictTy :: Type -> Bool -- This version is slightly more efficient than (maybeToBool . splitDictTy) @@ -628,16 +654,46 @@ argument, however, must still be unannotated. %************************************************************************ %* * \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. %* * %************************************************************************ \begin{code} type RhoType = Type type TauType = Type -type ThetaType = [(Class, [Type])] +data PredType = Class Class [Type] + | IParam Name Type +type ThetaType = [PredType] +type ClassPred = (Class, [Type]) +type ClassContext = [ClassPred] type SigmaType = Type \end{code} +\begin{code} +instance Outputable PredType where + ppr = pprPred +\end{code} + +\begin{code} +mkClassPred clas tys = Class clas tys + +getClassTys_maybe :: PredType -> Maybe ClassPred +getClassTys_maybe (Class clas tys) = Just (clas, tys) +getClassTys_maybe _ = Nothing + +ipName_maybe :: PredType -> Maybe Name +ipName_maybe (IParam n _) = Just n +ipName_maybe _ = Nothing + +classesToPreds cts = map (uncurry Class) cts + +classesOfPreds theta = concatMap cvt theta + where cvt (Class clas tys) = [(clas, tys)] + cvt (IParam _ _ ) = [] +\end{code} + @isTauTy@ tests for nested for-alls. \begin{code} @@ -651,14 +707,14 @@ isTauTy other = False \end{code} \begin{code} -mkRhoTy :: [(Class, [Type])] -> Type -> Type -mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta +mkRhoTy :: [PredType] -> Type -> Type +mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta -splitRhoTy :: Type -> ([(Class, [Type])], Type) +splitRhoTy :: Type -> ([PredType], Type) splitRhoTy ty = split ty ty [] where - split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of - Just pair -> split res res (pair:ts) + split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of + Just p -> split res res (p:ts) Nothing -> (reverse ts, orig_ty) split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts split orig_ty ty ts = (reverse ts, orig_ty) @@ -669,7 +725,7 @@ splitRhoTy ty = split ty ty [] \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) -splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type) +splitSigmaTy :: Type -> ([TyVar], [PredType], Type) splitSigmaTy ty = (tyvars, theta, tau) where @@ -715,6 +771,7 @@ tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1 tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty +tyVarsOfType (NoteTy (IPNote _) ty) = tyVarsOfType ty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar @@ -722,6 +779,13 @@ tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyva 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 + +tyVarsOfTheta :: ThetaType -> TyVarSet +tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet + -- Add a Note with the free tyvars to the top of the type -- (but under a usage if there is one) addFreeTyVars :: Type -> Type @@ -800,6 +864,7 @@ tidyType env@(tidy_env, subst) ty go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars go_note note@(UsgNote _) = note -- Usage annotation is already tidy go_note note@(UsgForAll _) = note -- Uvar binder is already tidy + go_note note@(IPNote _) = note -- IP is already tidy tidyTypes env tys = map (tidyType env) tys \end{code} @@ -901,5 +966,6 @@ seqNote :: TyNote -> () seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () seqNote (UsgNote usg) = usg `seq` () +seqNote (IPNote nm) = nm `seq` () \end{code} diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index d4902ad..b5e04a1 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -29,7 +29,7 @@ import Var ( TyVar, UVar ) import VarEnv import VarSet -import Name ( Provenance(..), ExportFlag(..), +import Name ( Name, Provenance(..), ExportFlag(..), mkWiredInTyConName, mkGlobalName, mkKindOccFS, tcName, ) import TyCon ( TyCon, KindCon, @@ -133,6 +133,7 @@ data TyNote | FTVNote TyVarSet -- The free type variables of the noted expression | UsgNote UsageAnn -- The usage annotation at this node | UsgForAll UVar -- Annotation variable binder + | IPNote Name -- It's an implicit parameter data UsageAnn = UsOnce -- Used at most once diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index d421d1b..fd91ec2 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -464,6 +464,8 @@ unannotTy (NoteTy (UsgForAll uv) ty) = unannotTy ty unannotTy (NoteTy (UsgNote _ ) ty) = unannotTy ty unannotTy (NoteTy (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty) unannotTy (NoteTy note@(FTVNote _ ) ty) = NoteTy note (unannotTy ty) +-- IP notes need to be preserved +unannotTy ty@(NoteTy (IPNote _) _) = ty unannotTy ty@(TyVarTy _) = ty unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2) unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys) -- 1.7.10.4