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
{-
-----------------------------------------------------------------------------
-$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.
import Panic
import GlaExts
+import FastString ( tailFS )
#include "HsVersions.h"
}
type :: { RdrNameHsType }
: btype '->' type { MonoFunTy $1 $3 }
- | IPVARID '::' type { MonoIParamTy (mkSrcUnqual ipName $1) $3 }
+ | ipvar '::' type { MonoIParamTy $1 $3 }
| btype { $1 }
btype :: { RdrNameHsType }
aexp1 :: { RdrNameHsExpr }
: qvar { HsVar $1 }
- | IPVARID { HsIPVar (mkSrcUnqual ipName $1) }
+ | ipvar { HsIPVar $1 }
| gcon { HsVar $1 }
| literal { HsLit $1 }
| '(' exp ')' { HsPar $2 }
| {- empty -} { [] }
dbind :: { (RdrName, RdrNameHsExpr) }
-dbind : IPVARID '=' exp { (mkSrcUnqual ipName $1, $3) }
+dbind : ipvar '=' exp { ($1, $3) }
-----------------------------------------------------------------------------
-- Variables, Constructors and Operators.
: qvarid { $1 }
| '(' qvarsym ')' { $2 }
+ipvar :: { RdrName }
+ : IPVARID { (mkSrcUnqual ipName (tailFS $1)) }
+
con :: { RdrName }
: conid { $1 }
| '(' consym ')' { $2 }
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
import Outputable
import GlaExts
+import FastString ( tailFS )
#if __HASKELL1__ > 4
import Ratio ( (%) )
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 -} { [ ] }
| '(#' 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
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 }
newIPDict, instOverloadedFun,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
+ getDictPred_maybe, getMethodTheta_maybe,
getFunDeps, getFunDepsOfLIE,
getIPs, getIPsOfLIE,
getAllFunDeps, getAllFunDepsOfLIE,
- partitionLIEbyMeth,
lookupInst, lookupSimpleInst, LookupInstResult(..),
fromIntClassOpKey, fromIntegerClassOpKey, Unique
)
import Maybes ( expectJust )
-import List ( partition )
import Maybe ( catMaybes )
import Util ( thenCmp, zipWithEqual, mapAccumL )
import Outputable
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)
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
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,
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,
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
module TcSimplify (
tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts,
tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
- bindInstsOfLocalFuns
+ bindInstsOfLocalFuns, partitionPredsOfLIE
) where
#include "HsVersions.h"
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 )
import Outputable
import Util
import List ( partition )
+import Maybes ( maybeToBool )
\end{code}
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}
%************************************************************************
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
projects / ghc-hetmet.git / commitdiff