Commit c2b053f3 authored by lewie's avatar lewie
Browse files

[project @ 1999-12-03 18:17:29 by lewie]

Extend getTyVarsToGen to take the closure of the set of tyvars
with respect to functional dependencies.  Really simple programs
using functional dependencies work now.  Also fixed a small glitch
where trivial (empty) FunDeps were being tossed into the context willy nilly.
parent 4dd14773
......@@ -16,14 +16,14 @@ module Inst (
newDictFromOld, newDicts, newDictsAtLoc,
newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
tyVarsOfInst, instLoc, getDictClassTys, getFunDeps,
tyVarsOfInst, instLoc, getDictClassTys, getFunDeps, getFunDepsOfLIE,
lookupInst, lookupSimpleInst, LookupInstResult(..),
isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
instBindingRequired, instCanBeGeneralised,
zonkInst, zonkFunDeps, instToId, instToIdBndr,
zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
InstOrigin(..), InstLoc, pprInstLoc
) where
......@@ -39,7 +39,7 @@ import TcMonad
import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
zonkTcType, zonkTcTypes,
zonkTcTyVars, zonkTcType, zonkTcTypes,
zonkTcThetaType
)
import Bag
......@@ -76,6 +76,7 @@ import Unique ( fromRationalClassOpKey, rationalTyConKey,
fromIntClassOpKey, fromIntegerClassOpKey, Unique
)
import Maybes ( expectJust )
import Maybe ( catMaybes )
import Util ( thenCmp, zipWithEqual, mapAccumL )
import Outputable
\end{code}
......@@ -232,6 +233,8 @@ getDictClassTys (Dict u clas tys _) = (clas, tys)
getFunDeps (FunDep clas fds _) = Just (clas, fds)
getFunDeps _ = Nothing
getFunDepsOfLIE lie = catMaybes (map getFunDeps (bagToList lie))
tyVarsOfInst :: Inst -> TcTyVarSet
tyVarsOfInst (Dict _ _ tys _) = tyVarsOfTypes tys
tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
......@@ -338,8 +341,10 @@ instOverloadedFun orig (HsVar v) arg_tys theta tau
instFunDeps orig theta
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
let ifd (clas, tys) = FunDep clas (instantiateFdClassTys clas tys) loc in
returnNF_Tc (map ifd theta)
let ifd (clas, tys) =
let fds = instantiateFdClassTys clas tys in
if null fds then Nothing else Just (FunDep clas fds loc)
in returnNF_Tc (catMaybes (map ifd theta))
newMethodWithGivenTy orig id tys theta tau
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
......@@ -454,6 +459,13 @@ zonkFunDeps fds = mapNF_Tc zonkFd fds
= zonkTcTypes ts1 `thenNF_Tc` \ ts1' ->
zonkTcTypes ts2 `thenNF_Tc` \ ts2' ->
returnNF_Tc (ts1', ts2')
zonkTvFunDeps fds = mapNF_Tc zonkFd fds
where
zonkFd (tvs1, tvs2)
= zonkTcTyVars tvs1 `thenNF_Tc` \ tvs1' ->
zonkTcTyVars tvs2 `thenNF_Tc` \ tvs2' ->
returnNF_Tc (tvs1', tvs2')
\end{code}
......@@ -482,7 +494,7 @@ pprInst (Method u id tys _ _ loc)
show_uniq u]
pprInst (FunDep clas fds loc)
= ptext SLIT("fundep!")
= hsep [ppr clas, ppr fds]
tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
tidyInst env (LitInst u lit ty loc)
......
......@@ -20,7 +20,8 @@ import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
newDicts, tyVarsOfInst, instToId,
newDicts, tyVarsOfInst, instToId, getFunDepsOfLIE,
zonkFunDeps
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
......@@ -53,6 +54,7 @@ import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
isUnboxedType, unboxedTypeKind, boxedTypeKind
)
import FunDeps ( tyVarFunDep, oclose )
import Var ( TyVar, tyVarKind )
import VarSet
import Bag
......@@ -533,22 +535,27 @@ getTyVarsToGen is_unrestricted mono_id_tys lie
= tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
let
tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
in
if is_unrestricted
then
returnNF_Tc (emptyVarSet, tyvars_to_gen)
let fds = concatMap snd (getFunDepsOfLIE lie) in
zonkFunDeps fds `thenNF_Tc` \ fds' ->
let tvFundep = tyVarFunDep fds'
extended_tyvars = oclose tvFundep body_tyvars in
-- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
returnNF_Tc (emptyVarSet, extended_tyvars)
else
-- This recover and discard-errs is to avoid duplicate error
-- messages; this, after all, is an "extra" call to tcSimplify
recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen)) $
recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $
discardErrsTc $
tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
tcSimplify (text "getTVG") NotTopLevel body_tyvars lie `thenTc` \ (_, _, constrained_dicts) ->
let
-- ASSERT: dicts_sig is already zonked!
constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
in
returnTc (constrained_tyvars, reduced_tyvars_to_gen)
\end{code}
......
......@@ -11,7 +11,7 @@ import TcMonad
import TcType ( zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists )
import Inst ( Inst, LookupInstResult(..),
lookupInst, isDict, getDictClassTys, getFunDeps,
lookupInst, isDict, getDictClassTys, getFunDepsOfLIE,
zonkLIE {- for debugging -} )
import VarSet ( emptyVarSet )
import VarEnv ( emptyVarEnv )
......@@ -19,15 +19,12 @@ import FunDeps ( instantiateFdClassTys )
import Bag ( bagToList )
import Outputable
import List ( elemIndex )
import Maybe ( catMaybes )
\end{code}
Improvement goes here.
\begin{code}
tcImprove lie
= let cfdss = catMaybes (map getFunDeps (bagToList lie)) in
iterImprove cfdss
tcImprove lie = iterImprove (getFunDepsOfLIE lie)
iterImprove cfdss
= instImprove cfdss `thenTc` \ change1 ->
......
It's better to read it as: "if we know these, then we're going to know these"
\begin{code}
module FunDeps(oclose, instantiateFdClassTys, pprFundeps) where
module FunDeps(oclose, instantiateFdClassTys, tyVarFunDep, pprFundeps) where
#include "HsVersions.h"
import Class (classTvsFds)
import Type (tyVarsOfType)
import Outputable (interppSP, ptext, empty, hsep, punctuate, comma)
import UniqSet (elementOfUniqSet, addOneToUniqSet )
import UniqSet (elementOfUniqSet, addOneToUniqSet,
uniqSetToList, unionManyUniqSets)
import List (elemIndex)
oclose fds vs =
......@@ -44,6 +46,12 @@ lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
lookupInstTy tyvars ts u = ts !! i
where Just i = elemIndex u tyvars
tyVarFunDep fdtys =
map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys
where
getTyVars ty = tyVarsOfType ty
unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs))
pprFundeps [] = empty
pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
......
......@@ -209,6 +209,9 @@ instance Outputable (UniqFM a) where
ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
ppr (EmptyUFM) = empty
-}
-- and when not debugging the package itself...
instance Outputable a => Outputable (UniqFM a) where
ppr ufm = ppr (ufmToList ufm)
\end{code}
%************************************************************************
......
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