From f0a01a1fc19bfa76aa36fa113942e1c57f3733f4 Mon Sep 17 00:00:00 2001 From: lewie Date: Thu, 2 Mar 2000 22:51:30 +0000 Subject: [PATCH] [project @ 2000-03-02 22:51:30 by lewie] Further refine and fix how `with' partitions the LIE. Also moved the partitioning function from Inst to TcSimplify. Fixed layout bug with `with'. Fixed another wibble w/ importing defs w/ implicit params. Make 4-tuples outputable (a convenience in debugging measure). --- ghc/compiler/parser/Lex.lhs | 2 +- ghc/compiler/parser/Parser.y | 12 +++++--- ghc/compiler/parser/RdrHsSyn.lhs | 1 + ghc/compiler/rename/ParseIface.y | 8 +++-- ghc/compiler/typecheck/Inst.lhs | 34 +++++---------------- ghc/compiler/typecheck/TcExpr.lhs | 14 ++++----- ghc/compiler/typecheck/TcSimplify.lhs | 53 +++++++++++++++++++++++++++++++-- ghc/compiler/utils/Outputable.lhs | 8 +++++ 8 files changed, 87 insertions(+), 45 deletions(-) diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index aef425f..b2f04b0 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -600,7 +600,7 @@ lexToken cont glaexts buf = cont (ITunknown "\NUL") (stepOn buf) '?'# | flag glaexts && is_lower (lookAhead# buf 1#) -> - lex_ip cont (stepOn buf) + lex_ip cont (incLexeme 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/Parser.y b/ghc/compiler/parser/Parser.y index 5b839ec..bfb3257 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.26 2000/02/28 21:59:32 lewie Exp $ +$Id: Parser.y,v 1.27 2000/03/02 22:51:30 lewie Exp $ Haskell grammar. @@ -28,6 +28,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) import Panic import GlaExts +import FastString ( tailFS ) #include "HsVersions.h" } @@ -514,7 +515,7 @@ ctype :: { RdrNameHsType } type :: { RdrNameHsType } : btype '->' type { MonoFunTy $1 $3 } - | IPVARID '::' type { MonoIParamTy (mkSrcUnqual ipName $1) $3 } + | ipvar '::' type { MonoIParamTy $1 $3 } | btype { $1 } btype :: { RdrNameHsType } @@ -716,7 +717,7 @@ aexp :: { RdrNameHsExpr } aexp1 :: { RdrNameHsExpr } : qvar { HsVar $1 } - | IPVARID { HsIPVar (mkSrcUnqual ipName $1) } + | ipvar { HsIPVar $1 } | gcon { HsVar $1 } | literal { HsLit $1 } | '(' exp ')' { HsPar $2 } @@ -863,7 +864,7 @@ dbinds :: { [(RdrName, RdrNameHsExpr)] } | {- empty -} { [] } dbind :: { (RdrName, RdrNameHsExpr) } -dbind : IPVARID '=' exp { (mkSrcUnqual ipName $1, $3) } +dbind : ipvar '=' exp { ($1, $3) } ----------------------------------------------------------------------------- -- Variables, Constructors and Operators. @@ -882,6 +883,9 @@ qvar :: { RdrName } : qvarid { $1 } | '(' qvarsym ')' { $2 } +ipvar :: { RdrName } + : IPVARID { (mkSrcUnqual ipName (tailFS $1)) } + con :: { RdrName } : conid { $1 } | '(' consym ')' { $2 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 7fb5442..41b9fdb 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -163,6 +163,7 @@ extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc extract_ty (MonoListTy ty) acc = extract_ty ty acc extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (MonoIParamTy n ty) acc = extract_ty ty acc extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc extract_ty (MonoUsgForAllTy uv ty) acc = extract_ty ty acc diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index a893d60..30fff39 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -36,6 +36,7 @@ import Maybes import Outputable import GlaExts +import FastString ( tailFS ) #if __HASKELL1__ > 4 import Ratio ( (%) ) @@ -454,7 +455,7 @@ context_list1 : class { [$1] } class :: { HsPred RdrName } class : qcls_name atypes { (HsPClass $1 $2) } - | IPVARID '::' type { (HsPIParam (mkSysUnqual ipName $1) $3) } + | ipvar_name '::' type { (HsPIParam $1 $3) } types0 :: { [RdrNameHsType] {- Zero or more -} } types0 : {- empty -} { [ ] } @@ -482,7 +483,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 } + | '{' ipvar_name '::' type '}' { MonoIParamTy $2 $4 } | '(' type ')' { $2 } -- This one is dealt with via qtc_name @@ -528,6 +529,9 @@ qvar_name :: { RdrName } qvar_name : var_name { $1 } | qvar_fs { mkSysQual varName $1 } +ipvar_name :: { RdrName } + : IPVARID { mkSysUnqual ipName (tailFS $1) } + var_names :: { [RdrName] } var_names : { [] } | var_name var_names { $1 : $2 } diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 41bf807..ecc9a2f 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -18,10 +18,10 @@ module Inst ( newIPDict, instOverloadedFun, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys, + getDictPred_maybe, getMethodTheta_maybe, getFunDeps, getFunDepsOfLIE, getIPs, getIPsOfLIE, getAllFunDeps, getAllFunDepsOfLIE, - partitionLIEbyMeth, lookupInst, lookupSimpleInst, LookupInstResult(..), @@ -84,7 +84,6 @@ import Unique ( fromRationalClassOpKey, rationalTyConKey, fromIntClassOpKey, fromIntegerClassOpKey, Unique ) import Maybes ( expectJust ) -import List ( partition ) import Maybe ( catMaybes ) import Util ( thenCmp, zipWithEqual, mapAccumL ) import Outputable @@ -250,6 +249,12 @@ instLoc (Method u _ _ _ _ loc) = loc instLoc (LitInst u lit ty loc) = loc instLoc (FunDep _ _ loc) = loc +getDictPred_maybe (Dict _ p _) = Just p +getDictPred_maybe _ = Nothing + +getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta +getMethodTheta_maybe _ = Nothing + getDictClassTys (Dict u (Class clas tys) _) = (clas, tys) getFunDeps (FunDep clas fds _) = Just (clas, fds) @@ -272,31 +277,6 @@ 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) d@(Dict _ p _) - = if pred p then - returnTc (consLIE d ips, lie) - else - returnTc (ips, consLIE d lie) - -partMethod pred (ips, lie) m@(Method u id tys theta tau loc@(_,sloc,_)) - = let (ips_, theta_) = partition pred theta in - if null ips_ then - returnTc (ips, consLIE m lie) - else if null theta_ then - returnTc (consLIE m ips, lie) - else - zonkPreds theta_ `thenTc` \ theta_' -> - newDictsAtLoc loc theta_' `thenTc` \ (new_dicts, _) -> - returnTc (consLIE m ips, - plusLIE (listToLIE new_dicts) lie) - -partMethod pred (ips, lie) inst@(LitInst u lit ty loc) - = returnTc (ips, consLIE inst lie) - tyVarsOfInst :: Inst -> TcTyVarSet tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6ac44b1..a9880a2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -22,10 +22,10 @@ import BasicTypes ( RecFlag(..) ) import Inst ( Inst, InstOrigin(..), OverloadedLit(..), LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs, - lieToList, listToLIE, tyVarsOfLIE, zonkLIE, + lieToList, listToLIE, newOverloadedLit, newMethod, newIPDict, instOverloadedFun, newDicts, newClassDicts, - partitionLIEbyMeth, getIPsOfLIE, instToId, ipToId + getIPsOfLIE, instToId, ipToId ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcInstId, @@ -37,7 +37,7 @@ import TcEnv ( tcInstId, import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt ) import TcPat ( badFieldCon ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) +import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE ) import TcType ( TcType, TcTauType, tcInstTyVars, tcInstTcType, tcSplitRhoTy, @@ -731,16 +731,14 @@ Implicit Parameter bindings. 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 "tcMonoExpr With") (tyVarsOfLIE ips') ips' - `thenTc` \ res@(_, dict_binds, _) -> + partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) -> + pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $ let expr'' = if nullMonoBinds dict_binds then expr' else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive) expr' in - tcCheckIPBinds binds' types ips' `thenTc_` + tcCheckIPBinds binds' types ips `thenTc_` returnTc (HsWith expr'' binds', lie' `plusLIE` lie2) where isBound p = case ipName_maybe p of diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 3bd5792..f3a3c07 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -118,7 +118,7 @@ and hence the default mechanism would resolve the "a". module TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, - bindInstsOfLocalFuns + bindInstsOfLocalFuns, partitionPredsOfLIE ) where #include "HsVersions.h" @@ -137,9 +137,11 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), instToId, instBindingRequired, instCanBeGeneralised, newDictFromOld, getDictClassTys, getIPs, + getDictPred_maybe, getMethodTheta_maybe, instLoc, pprInst, zonkInst, tidyInst, tidyInsts, Inst, LIE, pprInsts, pprInstsInFull, - mkLIE, emptyLIE, plusLIE, lieToList + mkLIE, emptyLIE, unitLIE, consLIE, plusLIE, + lieToList, listToLIE ) import TcEnv ( tcGetGlobalTyVars ) import TcType ( TcType, TcTyVarSet, typeToTcType ) @@ -163,6 +165,7 @@ import CmdLineOpts ( opt_GlasgowExts ) import Outputable import Util import List ( partition ) +import Maybes ( maybeToBool ) \end{code} @@ -336,13 +339,57 @@ tcSimplifyToDicts wanted_lie returnTc (mkLIE irreds, binds) where -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (lieToList wanted_lie) + -- ZZ waitaminute - doesn't appear that any funDeps should even be here... + -- wanteds = filter notFunDep (lieToList wanted_lie) + wanteds = lieToList wanted_lie -- Reduce methods and lits only; stop as soon as we get a dictionary try_me inst | isDict inst = DontReduce | otherwise = ReduceMe AddToIrreds \end{code} +The following function partitions a LIE by a predicate defined +over `Pred'icates (an unfortunate overloading of terminology!). +This means it sometimes has to split up `Methods', in which case +a binding is generated. + +It is used in `with' bindings to extract from the LIE the implicit +parameters being bound. + +\begin{code} +partitionPredsOfLIE pred lie + = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts + where insts = lieToList lie + +-- warning: the term `pred' is overloaded here! +partPreds pred (lie1, lie2, binds) inst + | maybeToBool maybe_pred + = if pred p then + returnTc (consLIE inst lie1, lie2, binds) + else + returnTc (lie1, consLIE inst lie2, binds) + where maybe_pred = getDictPred_maybe inst + Just p = maybe_pred + +-- the assumption is that those satisfying `pred' are being extracted, +-- so we leave the method untouched when nothing satisfies `pred' +partPreds pred (lie1, lie2, binds1) inst + | maybeToBool maybe_theta + = if any pred theta then + zonkInst inst `thenTc` \ inst' -> + tcSimplifyToDicts (unitLIE inst') `thenTc` \ (lie3, binds2) -> + partitionPredsOfLIE pred lie3 `thenTc` \ (lie1', lie2', EmptyMonoBinds) -> + returnTc (lie1 `plusLIE` lie1', + lie2 `plusLIE` lie2', + binds1 `AndMonoBinds` binds2) + else + returnTc (lie1, consLIE inst lie2, binds1) + where maybe_theta = getMethodTheta_maybe inst + Just theta = maybe_theta + +partPreds pred (lie1, lie2, binds) inst + = returnTc (lie1, consLIE inst lie2, binds) +\end{code} %************************************************************************ diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 5dd86b7..42b1ba3 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -305,6 +305,14 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher ppr y <> comma, ppr z ]) +instance (Outputable a, Outputable b, Outputable c, Outputable d) => + Outputable (a, b, c, d) where + ppr (x,y,z,w) = + parens (sep [ppr x <> comma, + ppr y <> comma, + ppr z <> comma, + ppr w]) + instance Outputable FastString where ppr fs = text (unpackFS fs) -- Prints an unadorned string, -- no double quotes or anything -- 1.7.10.4