summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/parser/Lex.lhs2
-rw-r--r--ghc/compiler/parser/Parser.y12
-rw-r--r--ghc/compiler/parser/RdrHsSyn.lhs1
-rw-r--r--ghc/compiler/rename/ParseIface.y8
-rw-r--r--ghc/compiler/typecheck/Inst.lhs34
-rw-r--r--ghc/compiler/typecheck/TcExpr.lhs14
-rw-r--r--ghc/compiler/typecheck/TcSimplify.lhs53
-rw-r--r--ghc/compiler/utils/Outputable.lhs8
8 files changed, 87 insertions, 45 deletions
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index aef425f41e..b2f04b04ff 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 5b839ec15e..bfb325789d 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 7fb54425be..41b9fdb0b4 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 a893d602c0..30fff39b7c 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 41bf80701d..ecc9a2f7f3 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 6ac44b1235..a9880a255a 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 3bd5792b02..f3a3c07a7b 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 5dd86b7ffd..42b1ba3a27 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
View Lorry Controller Status