From 461f1fb54915b564141ec07ce6f2ea284dc6cea8 Mon Sep 17 00:00:00 2001 From: lewie Date: Wed, 9 Feb 2000 18:32:10 +0000 Subject: [PATCH] [project @ 2000-02-09 18:32:09 by lewie] Misc. fixes to implicit parameters support. --- ghc/compiler/basicTypes/Name.lhs | 4 +++- ghc/compiler/hsSyn/HsExpr.lhs | 2 +- ghc/compiler/hsSyn/HsTypes.lhs | 4 +++- ghc/compiler/main/MkIface.lhs | 14 ++++++++++---- ghc/compiler/parser/Lex.lhs | 2 +- ghc/compiler/parser/ParseUtil.lhs | 16 ++++++++++++---- ghc/compiler/parser/Parser.y | 9 ++++++--- ghc/compiler/rename/ParseIface.y | 4 +++- ghc/compiler/typecheck/Inst.lhs | 22 +++++++++++++++------- ghc/compiler/typecheck/TcBinds.lhs | 2 +- ghc/compiler/typecheck/TcExpr.lhs | 8 +++++--- ghc/compiler/typecheck/TcImprove.lhs | 2 +- ghc/compiler/typecheck/TcMonoType.lhs | 2 +- ghc/compiler/typecheck/TcSimplify.lhs | 11 +++++------ ghc/compiler/types/PprType.lhs | 4 ++-- ghc/compiler/types/Type.lhs | 10 ++++++++-- 16 files changed, 77 insertions(+), 39 deletions(-) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 3b0cd48..721325d 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -137,7 +137,8 @@ mkIPName :: Unique -> OccName -> Name mkIPName uniq occ = Name { n_uniq = uniq, n_sort = Local, - n_occ = mkIPOcc occ, + n_occ = occ, + -- ZZ is this an appropriate provinence? n_prov = SystemProv } ------------------------- Wired in names ------------------------- @@ -240,6 +241,7 @@ all_toplev_ids_visible = opt_EnsureSplittableC -- Splitting requires visiblilty \end{code} + \begin{code} setNameProvenance :: Name -> Provenance -> Name -- setNameProvenance used to only change the provenance of diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index c530956..ba980ee 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -213,7 +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 (HsIPVar v) = {- char '?' <> -} ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsLitOut lit _) = ppr lit diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 0f70df5..c9637b4 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -52,6 +52,8 @@ data HsType name | MonoTupleTy [HsType name] -- Element types (length gives arity) Bool -- boxed? + | MonoIParamTy name (HsType name) + -- these next two are only used in interfaces | MonoDictTy name -- Class [HsType name] @@ -135,7 +137,7 @@ 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] + = hsep [{- char '?' <> -} ppr n, text "::", ppr ty] \end{code} \begin{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index e882a37..056880e 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -50,7 +50,7 @@ import Class ( Class, classExtraBigSig ) import FieldLabel ( fieldLabelName, fieldLabelType ) import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, classesToPreds, - Type, ThetaType + Type, ThetaType, PredType(..), ClassContext ) import PprType @@ -578,15 +578,21 @@ 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 :: ClassContext -> 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 [pprPred p | p <- theta])) +pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta])) -pprIfaceClasses :: [(Class,[Type])] -> SDoc +-- ZZ - not sure who uses this - i.e. whether IParams really show up or not +-- (it's not used to print normal value signatures) +pprIfacePred :: PredType -> SDoc +pprIfacePred (Class clas tys) = pprConstraint clas tys +pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty + +pprIfaceClasses :: ClassContext -> 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 8dae914..7d74bed 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -595,7 +595,7 @@ lexToken cont glaexts buf = cont (ITunknown "\NUL") (stepOn buf) '?'# | flag glaexts && is_lower (lookAhead# buf 1#) -> - lex_ip cont (setCurrentPos# buf 1#) + lex_ip cont (stepOn buf) 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 diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index b410fee..c396e3f 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -136,13 +136,21 @@ checkInstType t checkContext :: RdrNameHsType -> P RdrNameContext checkContext (MonoTupleTy ts True) - = mapP (\t -> checkAssertion t []) ts `thenP` \cs -> - returnP (map (uncurry HsPClass) cs) + = mapP (\t -> checkPred t []) ts `thenP` \ps -> + returnP ps checkContext (MonoTyVar t) -- empty contexts are allowed | t == unitTyCon_RDR = returnP [] checkContext t - = checkAssertion t [] `thenP` \(c,ts) -> - returnP [HsPClass c ts] + = checkPred t [] `thenP` \p -> + returnP [p] + +checkPred :: RdrNameHsType -> [RdrNameHsType] + -> P (HsPred RdrName) +checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) + = returnP (HsPClass t args) +checkPred (MonoTyApp l r) args = checkPred l (r:args) +checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty) +checkPred _ _ = parseError "Illegal class assertion" checkAssertion :: RdrNameHsType -> [RdrNameHsType] -> P (HsClassAssertion RdrName) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 759c2dc..a94edff 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.19 2000/01/28 20:52:39 lewie Exp $ +$Id: Parser.y,v 1.20 2000/02/09 18:32:10 lewie Exp $ Haskell grammar. @@ -35,6 +35,7 @@ import GlaExts {- ----------------------------------------------------------------------------- Conflicts: 14 shift/reduce + (note: it's currently 21 -- JRL, 31/1/2000) 8 for abiguity in 'if x then y else z + 1' (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) @@ -85,7 +86,6 @@ Conflicts: 14 shift/reduce 'then' { ITthen } 'type' { ITtype } 'where' { ITwhere } - 'with' { ITwith } '_scc_' { ITscc } 'forall' { ITforall } -- GHC extension keywords @@ -94,6 +94,7 @@ Conflicts: 14 shift/reduce 'label' { ITlabel } 'dynamic' { ITdynamic } 'unsafe' { ITunsafe } + 'with' { ITwith } 'stdcall' { ITstdcallconv } 'ccall' { ITccallconv } '_ccall_' { ITccall (False, False, False) } @@ -174,7 +175,8 @@ Conflicts: 14 shift/reduce QCONID { ITqconid $$ } QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } - IPVARID { ITipvarid $$ } + + IPVARID { ITipvarid $$ } -- GHC extension PRAGMA { ITpragma $$ } @@ -489,6 +491,7 @@ type :: { RdrNameHsType } btype :: { RdrNameHsType } : btype atype { MonoTyApp $1 $2 } + | IPVARID '::' type { MonoIParamTy (mkSrcUnqual ipName $1) $3 } | atype { $1 } atype :: { RdrNameHsType } diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 950fe54..2d3239a 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -145,7 +145,8 @@ import Ratio ( (%) ) QCONID { ITqconid $$ } QVARSYM { ITqvarsym $$ } QCONSYM { ITqconsym $$ } - IPVARID { ITipvarid $$ } + + IPVARID { ITipvarid $$ } -- GHC extension PRAGMA { ITpragma $$ } @@ -452,6 +453,7 @@ atype : qtc_name { MonoTyVar $1 } | '(#' types0 '#)' { MonoTupleTy $2 False{-unboxed-} } | '[' type ']' { MonoListTy $2 } | '{' qcls_name atypes '}' { MonoDictTy $2 $3 } + | '{' IPVARID '::' type '}' { MonoIParamTy (mkSysUnqual ipName $2) $4 } | '(' type ')' { $2 } -- This one is dealt with via qtc_name diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index ad7df46..9f8e343 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -25,10 +25,11 @@ module Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep, + isDict, isClassDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep, instBindingRequired, instCanBeGeneralised, - zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr, + zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps, + instToId, instToIdBndr, ipToId, InstOrigin(..), InstLoc, pprInstLoc ) where @@ -52,7 +53,8 @@ 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, nameUnique ) +import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc, + getOccName, nameUnique ) import PprType ( pprPred ) import InstEnv ( InstEnv, lookupInstEnv ) import SrcLoc ( SrcLoc ) @@ -310,8 +312,11 @@ Predicates ~~~~~~~~~~ \begin{code} isDict :: Inst -> Bool -isDict (Dict _ (Class _ _) _) = True +isDict (Dict _ _ _) = True isDict other = False +isClassDict :: Inst -> Bool +isClassDict (Dict _ (Class _ _) _) = True +isClassDict other = False isMethodFor :: TcIdSet -> Inst -> Bool isMethodFor ids (Method uniq id tys _ _ loc) @@ -485,9 +490,7 @@ instToIdBndr :: Inst -> TcId 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 + = ipToId n ty loc instToIdBndr (Method u id tys theta tau (_,loc,_)) = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc @@ -497,6 +500,9 @@ instToIdBndr (LitInst u list ty loc) instToIdBndr (FunDep clas fds _) = panic "FunDep escaped!!!" + +ipToId n ty loc + = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc \end{code} @@ -539,6 +545,8 @@ zonkInst (FunDep clas fds loc) = zonkFunDeps fds `thenNF_Tc` \ fds' -> returnNF_Tc (FunDep clas fds' loc) +zonkInsts insts = mapNF_Tc zonkInst insts + zonkFunDeps fds = mapNF_Tc zonkFd fds where zonkFd (ts1, ts2) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index ec5a592..d9dc3a2 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -291,7 +291,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- SIMPLIFY THE LIE tcExtendGlobalTyVars tyvars_not_to_gen ( let ips = getIPsOfLIE lie_req in - if null real_tyvars_to_gen_list && null ips then + if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then -- No polymorphism, and no IPs, so no need to simplify context returnTc (lie_req, EmptyMonoBinds, []) else diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 273d259..b125752 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -25,7 +25,7 @@ import Inst ( Inst, InstOrigin(..), OverloadedLit(..), lieToList, listToLIE, tyVarsOfLIE, zonkLIE, newOverloadedLit, newMethod, newIPDict, instOverloadedFun, newDicts, newClassDicts, - partitionLIEbyMeth, getIPsOfLIE + partitionLIEbyMeth, getIPsOfLIE, instToId, ipToId ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcInstId, @@ -200,10 +200,11 @@ tcMonoExpr (HsVar name) res_ty \begin{code} tcMonoExpr (HsIPVar name) res_ty + -- ZZ What's the `id' used for here... = 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) + returnNF_Tc (HsIPVar (instToId ip), unitLIE ip) \end{code} %************************************************************************ @@ -746,7 +747,8 @@ tcMonoExpr (HsWith expr binds) res_ty tcIPBinds ((name, expr) : binds) = newTyVarTy_OpenKind `thenTc` \ ty -> - let id = mkVanillaId name ty in + tcGetSrcLoc `thenTc` \ loc -> + let id = ipToId name ty loc in tcMonoExpr expr ty `thenTc` \ (expr', lie) -> zonkTcType ty `thenTc` \ ty' -> tcIPBinds binds `thenTc` \ (binds', types, lie2) -> diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs index 0cacae3..dfe35dd 100644 --- a/ghc/compiler/typecheck/TcImprove.lhs +++ b/ghc/compiler/typecheck/TcImprove.lhs @@ -12,7 +12,7 @@ import TcMonad import TcType ( zonkTcType, zonkTcTypes ) import TcUnify ( unifyTauTyLists ) import Inst ( Inst, LookupInstResult(..), - lookupInst, isDict, getFunDepsOfLIE, getIPsOfLIE, + lookupInst, 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 diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 4fe0e3e..ce5d681 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -198,13 +198,13 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty) -- f :: forall a. Num a => (# a->a, a->a #) -- And we want these to get through the type checker 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 ambig ct_var = (varName ct_var `elem` forall_tyvars) && not (ct_var `elemUFM` tau_vars) ambiguous = foldUFM ((||) . ambig) False ct_vars + check _ = returnTc () in mapTc check theta `thenTc_` returnTc (body_kind, mkSigmaTy tyvars theta tau) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 104fc9d..4de479c 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -132,7 +132,8 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), tyVarsOfInst, tyVarsOfInsts, - isDict, isStdClassTyVarDict, isMethodFor, notFunDep, + isDict, isClassDict, isStdClassTyVarDict, + isMethodFor, notFunDep, instToId, instBindingRequired, instCanBeGeneralised, newDictFromOld, getDictClassTys, getIPs, @@ -220,8 +221,6 @@ tcSimplify str 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_` @@ -288,7 +287,7 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie givens = lieToList given_lie -- see comment on wanteds in tcSimplify wanteds = filter notFunDep (lieToList wanted_lie) - given_dicts = filter isDict givens + given_dicts = filter isClassDict givens try_me inst -- Does not constrain a local tyvar @@ -722,7 +721,7 @@ addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s) -- Invariant: the Inst is already in Avails. addSuperClasses avails dict - | not (isDict dict) + | not (isClassDict dict) = returnNF_Tc avails | otherwise -- It is a dictionary @@ -1217,7 +1216,7 @@ addNoInstanceErr str givens dict ptext SLIT("Probable cause:") <+> vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict), ptext SLIT("in") <+> str], - if isDict dict && all_tyvars then empty else + if isClassDict dict && all_tyvars then empty else ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)] ) where diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 24294ba..db54a7d 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -69,7 +69,7 @@ pprParendKind = pprParendType pprPred :: PredType -> SDoc pprPred (Class clas tys) = pprConstraint clas tys -pprPred (IParam n ty) = ppr n <+> ppr ty +pprPred (IParam n ty) = hsep [ppr n, ptext SLIT("::"), ppr ty] pprConstraint :: Class -> [Type] -> SDoc pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys) @@ -189,7 +189,7 @@ ppr_ty env ctxt_prec ty@(ForAllTy _ _) <+> ptext SLIT("=>") 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_pred (IParam n ty) = hsep [{- char '?' <> -} ppr n, text "::", ppr_ty env tYCON_PREC ty] ppr_ty env ctxt_prec (FunTy ty1 ty2) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index a060f63..cba55fb 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -89,7 +89,7 @@ import Var ( TyVar, IdOrTyVar, UVar, import VarEnv import VarSet -import Name ( Name, NamedThing(..), mkLocalName, tidyOccName, +import Name ( Name, NamedThing(..), mkLocalName, tidyOccName ) import NameSet import Class ( classTyCon, Class ) @@ -864,7 +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 + go_note (IPNote n) = IPNote (tidyIPName n) tidyTypes env tys = map (tidyType env) tys \end{code} @@ -888,6 +888,12 @@ tidyTopType :: Type -> Type tidyTopType ty = tidyType emptyTidyEnv ty \end{code} +\begin{code} +tidyIPName :: Name -> Name +tidyIPName name + = mkLocalName (getUnique name) (getOccName name) noSrcLoc +\end{code} + %************************************************************************ %* * -- 1.7.10.4