Commit e7f04a0d authored by lewie's avatar lewie
Browse files

[project @ 2000-05-31 10:13:57 by lewie]

Cleanup pass on functional dependencies.  Most noticeably, make it so that
signatures involving classes with functional dependencies work.  Also,
Fundeps are now properly handled by the simplifier, resolving problems
where the fundeps were sometimes being discarded too early, and sometimes
hanging around too long.  Took out the early ambiguity testing in the
renamer, because that's too early (you don't know the fundeps yet).  Now,
the ambiguity test happens in the typechecker.
Functional Dependencies should now be up to snuff with Mark's paper,
however, the derived instances and superclass extensions found in hugs
are still not in there.
It would be nice if this were merged into 4.07.  I have diffs against
the 4.07 tree in case it's too thorny working around Simon's big commit.
parent d7fefe23
......@@ -53,6 +53,7 @@ module RdrHsSyn (
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
extractPatsTyVars,
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars,
mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
......@@ -153,6 +154,8 @@ extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
extract_ctxt ctxt acc = foldr extract_pred acc ctxt
......
......@@ -14,7 +14,8 @@ import HsPragmas
import HsTypes ( getTyVarName )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
extractRuleBndrsTyVars, extractHsTyRdrTyVars,
extractHsTysRdrTyVars, extractHsCtxtRdrTyVars
)
import RnHsSyn
import HsCore
......@@ -556,11 +557,12 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
let
mentioned_in_tau = extractHsTyRdrTyVars ty
forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
mentioned_in_tau = extractHsTyRdrTyVars ty
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
forall_tyvars = filter (not . (`elemFM` name_env)) mentioned
in
checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- Explicit quantification.
......@@ -569,26 +571,19 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- That's only a warning... unless the tyvar is constrained by a
-- context in which case it's an error
= let
mentioned_in_tau = extractHsTyRdrTyVars tau
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
(bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
-- bad = explicitly quantified and constrained, but not mentioned in tau
-- warn = explicitly quantified but not mentioned in ctxt or tau
forall_tyvar_names = map getTyVarName forall_tyvars
mentioned_in_tau = extractHsTyRdrTyVars tau
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
tys_of_pred (HsPClass clas tys) = tys
tys_of_pred (HsPIParam n ty) = [ty]
forall_tyvar_names = map getTyVarName forall_tyvars
-- explicitly quantified but not mentioned in ctxt or tau
warn_guys = filter (`notElem` mentioned) forall_tyvar_names
in
-- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
rnForAll doc forall_tyvars ctxt' tau
mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
rnForAll doc forall_tyvars ctxt tau
rnHsType doc (HsTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
......@@ -968,13 +963,6 @@ univErr doc constraint ty
$$
(ptext SLIT("In") <+> doc)
ambigErr doc constraint ty
= sep [ptext SLIT("Ambiguous constraint") <+> quotes (ppr 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 =>."))]
$$
(ptext SLIT("In") <+> doc)
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
......
......@@ -16,6 +16,8 @@ module Inst (
newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
newMethod, newMethodWithGivenTy, newOverloadedLit,
newIPDict, instOverloadedFun,
instantiateFdClassTys, instFunDeps, instFunDepsOfTheta,
newFunDepFromDict,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
getDictPred_maybe, getMethodTheta_maybe,
......@@ -80,7 +82,8 @@ import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
import TysWiredIn ( intDataCon, isIntTy,
floatDataCon, isFloatTy,
doubleDataCon, isDoubleTy,
integerTy, isIntegerTy
integerTy, isIntegerTy,
voidTy
)
import Unique ( fromRationalClassOpKey, rationalTyConKey,
fromIntClassOpKey, fromIntegerClassOpKey, Unique
......@@ -175,6 +178,7 @@ data Inst
InstLoc
| FunDep
Unique
Class -- the class from which this arises
[FunDep TcType]
InstLoc
......@@ -207,11 +211,11 @@ cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2
cmpInst (Method _ _ _ _ _ _) other = LT
cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
cmpInst (LitInst _ _ _ _) (FunDep _ _ _) = LT
cmpInst (LitInst _ _ _ _) (FunDep _ _ _ _) = LT
cmpInst (LitInst _ _ _ _) other = GT
cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
cmpInst (FunDep _ _ _) other = GT
cmpInst (FunDep _ clas1 fds1 _) (FunDep _ clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
cmpInst (FunDep _ _ _ _) other = GT
cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
......@@ -226,7 +230,7 @@ Selection
instLoc (Dict u pred loc) = loc
instLoc (Method u _ _ _ _ loc) = loc
instLoc (LitInst u lit ty loc) = loc
instLoc (FunDep _ _ loc) = loc
instLoc (FunDep _ _ _ loc) = loc
getDictPred_maybe (Dict _ p _) = Just p
getDictPred_maybe _ = Nothing
......@@ -236,7 +240,7 @@ getMethodTheta_maybe _ = Nothing
getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
getFunDeps (FunDep clas fds _) = Just (clas, fds)
getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
getFunDeps _ = Nothing
getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
......@@ -251,7 +255,7 @@ getIPs _ = []
getIPsOfLIE lie = concatMap getIPs (lieToList lie)
getAllFunDeps (FunDep clas fds _) = fds
getAllFunDeps (FunDep _ clas fds _) = fds
getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
......@@ -262,7 +266,7 @@ tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyV
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
tyVarsOfInst (FunDep _ fds _)
tyVarsOfInst (FunDep _ _ fds _)
= foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
where tyVarsOfFd (ts1, ts2) =
tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
......@@ -305,8 +309,8 @@ isStdClassTyVarDict other
= False
notFunDep :: Inst -> Bool
notFunDep (FunDep _ _ _) = False
notFunDep other = True
notFunDep (FunDep _ _ _ _) = False
notFunDep other = True
\end{code}
Two predicates which deal with the case where class constraints don't
......@@ -384,13 +388,19 @@ instOverloadedFun orig v arg_tys theta tau
returnNF_Tc (instToId inst, mkLIE (inst : fds))
instFunDeps orig theta
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
= tcGetUnique `thenNF_Tc` \ uniq ->
tcGetInstLoc orig `thenNF_Tc` \ loc ->
let ifd (Class clas tys) =
let fds = instantiateFdClassTys clas tys in
if null fds then Nothing else Just (FunDep clas fds loc)
if null fds then Nothing else Just (FunDep uniq clas fds loc)
ifd _ = Nothing
in returnNF_Tc (catMaybes (map ifd theta))
instFunDepsOfTheta theta
= let ifd (Class clas tys) = instantiateFdClassTys clas tys
ifd _ = []
in concat (map ifd theta)
newMethodWithGivenTy orig id tys theta tau
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
newMethodWith id tys theta tau loc
......@@ -447,6 +457,16 @@ newOverloadedLit orig lit ty -- The general case
returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
\end{code}
\begin{code}
newFunDepFromDict dict
= tcGetUnique `thenNF_Tc` \ uniq ->
let (clas, tys) = getDictClassTys dict
fds = instantiateFdClassTys clas tys
inst = FunDep uniq clas fds (instLoc dict)
in
if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
\end{code}
\begin{code}
newIPDict name ty loc
= tcGetUnique `thenNF_Tc` \ new_uniq ->
......@@ -470,8 +490,8 @@ instToIdBndr (Method u id tys theta tau (_,loc,_))
instToIdBndr (LitInst u list ty loc)
= mkSysLocal SLIT("lit") u ty
instToIdBndr (FunDep clas fds _)
= panic "FunDep escaped!!!"
instToIdBndr (FunDep u clas fds _)
= mkSysLocal SLIT("FunDep") u voidTy
ipToId n ty loc
= mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
......@@ -513,9 +533,9 @@ zonkInst (LitInst u lit ty loc)
= zonkTcType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (LitInst u lit new_ty loc)
zonkInst (FunDep clas fds loc)
zonkInst (FunDep u clas fds loc)
= zonkFunDeps fds `thenNF_Tc` \ fds' ->
returnNF_Tc (FunDep clas fds' loc)
returnNF_Tc (FunDep u clas fds' loc)
zonkPreds preds = mapNF_Tc zonkPred preds
zonkInsts insts = mapNF_Tc zonkInst insts
......@@ -562,7 +582,7 @@ pprInst m@(Method u id tys theta tau loc)
show_uniq u,
ppr (instToId m) -}]
pprInst (FunDep clas fds loc)
pprInst (FunDep _ clas fds loc)
= hsep [ppr clas, ppr fds]
tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
......@@ -593,7 +613,7 @@ tidyInst env (Method u id tys theta tau loc)
(env', tys') = tidyOpenTypes env tys
-- this case shouldn't arise... (we never print fundeps)
tidyInst env fd@(FunDep clas fds loc)
tidyInst env fd@(FunDep _ clas fds loc)
= (env, fd)
tidyInsts env insts = mapAccumL tidyInst env insts
......
......@@ -736,6 +736,7 @@ The error message here is somewhat unsatisfactory, but it'll do for
now (ToDo).
\begin{code}
checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM s (Maybe (TcThetaType, LIE))
checkSigMatch top_lvl binder_names mono_ids sigs
| main_bound_here
= -- First unify the main_id with IO t, for any old t
......@@ -770,7 +771,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs
sig1_dict_tys = mk_dict_tys theta1
n_sig1_dict_tys = length sig1_dict_tys
sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs]
sig_lie = mkLIE (concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs])
maybe_main = find_main top_lvl binder_names mono_ids
main_bound_here = maybeToBool maybe_main
......
......@@ -28,7 +28,9 @@ import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
newKindVar, tcInstSigVar,
zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType, zonkTcTyVar
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr,
instFunDeps, instFunDepsOfTheta )
import FunDeps ( tyVarFunDep, oclose )
import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
import Type ( Type, PredType(..), ThetaType, UsageAnn(..),
mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
......@@ -213,12 +215,15 @@ 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)
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
where ct_vars = tyVarsOfTypes tys
forall_tyvars = map varName in_scope_vars
tau_vars = tyVarsOfType tau
fds = instFunDepsOfTheta theta
tvFundep = tyVarFunDep fds
extended_tau_vars = oclose tvFundep tau_vars
ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
not (ct_var `elemUFM` extended_tau_vars)
ambiguous = foldUFM ((||) . ambig) False ct_vars
check _ = returnTc ()
in
mapTc check theta `thenTc_`
......@@ -383,7 +388,7 @@ data TcSigInfo
-- Does *not* have name = N
-- Has type tau
Inst -- Empty if theta is null, or
[Inst] -- Empty if theta is null, or
-- (method mono_id) otherwise
SrcLoc -- Of the signature
......@@ -438,8 +443,9 @@ mkTcSig poly_id src_loc
tyvar_tys'
theta' tau' `thenNF_Tc` \ inst ->
-- We make a Method even if it's not overloaded; no harm
instFunDeps SignatureOrigin theta' `thenNF_Tc` \ fds ->
returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToIdBndr inst) inst src_loc)
returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToIdBndr inst) (inst : fds) src_loc)
where
name = idName poly_id
\end{code}
......
......@@ -132,10 +132,10 @@ import TcHsSyn ( TcExpr, TcId,
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
tyVarsOfInst, tyVarsOfInsts,
isDict, isClassDict, isMethod, isStdClassTyVarDict,
isMethodFor, notFunDep,
isDict, isClassDict, isMethod, notFunDep,
isStdClassTyVarDict, isMethodFor,
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld,
newDictFromOld, newFunDepFromDict,
getDictClassTys, getIPs,
getDictPred_maybe, getMethodTheta_maybe,
instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
......@@ -165,6 +165,7 @@ import CmdLineOpts ( opt_GlasgowExts )
import Outputable
import Util
import List ( partition )
import Maybe ( fromJust )
import Maybes ( maybeToBool )
\end{code}
......@@ -231,17 +232,7 @@ tcSimplify str local_tvs wanted_lie
-- Finished
returnTc (mkLIE frees, binds, mkLIE irreds')
where
-- the idea behind filtering out the dependencies here is that
-- they've already served their purpose, and can be reconstructed
-- at a later point from the retained class predicates.
-- however, there *is* the possibility that a dependency
-- out-lives the predicate from which it arose.
-- I don't have any examples of this, but if they show up,
-- we'd want to consider the possibility of saving the
-- 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 (lieToList wanted_lie)
wanteds = lieToList wanted_lie
try_me inst
-- Does not constrain a local tyvar
......@@ -291,9 +282,7 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie
returnTc (mkLIE frees, binds)
where
givens = lieToList given_lie
-- see comment on wanteds in tcSimplify
-- JRL nope - it's too early to throw away fundeps here...
wanteds = {- filter notFunDep -} (lieToList wanted_lie)
wanteds = lieToList wanted_lie
given_dicts = filter isClassDict givens
try_me inst
......@@ -339,9 +328,6 @@ tcSimplifyToDicts wanted_lie
ASSERT( null frees )
returnTc (mkLIE irreds, binds)
where
-- see comment on wanteds in tcSimplify
-- 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
......@@ -520,6 +506,11 @@ reduceContext str try_me givens wanteds
= -- Zonking first
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
-- JRL - process fundeps last. We eliminate fundeps by seeing
-- what available classes generate them, so we need to process the
-- classes first. (would it be useful to make LIEs ordered in the first place?)
let (wantedOther, wantedFds) = partition notFunDep wanteds
wanteds' = wantedOther ++ wantedFds in
{-
pprTrace "reduceContext" (vcat [
......@@ -531,10 +522,10 @@ reduceContext str try_me givens wanteds
]) $
-}
-- Build the Avail mapping from "givens"
foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
-- Do the real work
reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
reduceList (0,[]) try_me wanteds' (avails, [], []) `thenNF_Tc` \ (avails, frees, irreds) ->
-- Extract the bindings from avails
let
......@@ -566,7 +557,7 @@ reduceContext str try_me givens wanteds
text "----------------------"
]) $
-}
returnTc (binds, frees, irreds)
returnNF_Tc (binds, frees, irreds)
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
......@@ -781,6 +772,7 @@ addAvail avails wanted avail
addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
-- Add all the superclasses of the Inst to Avails
-- JRL - also add in the functional dependencies
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
......@@ -788,10 +780,15 @@ addSuperClasses avails dict
= returnNF_Tc avails
| otherwise -- It is a dictionary
= foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
= foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
newFunDepFromDict dict `thenNF_Tc` \ fdInst_maybe ->
case fdInst_maybe of
Nothing -> returnNF_Tc avails'
Just fdInst ->
let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
addAvail avails fdInst fdAvail
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
......@@ -1083,8 +1080,7 @@ tcSimplifyTop wanted_lie
returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
where
-- see comment on wanteds in tcSimplify
wanteds = filter notFunDep (lieToList wanted_lie)
wanteds = lieToList wanted_lie
try_me inst = ReduceMe AddToIrreds
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment