From: Manuel M T Chakravarty Date: Fri, 29 Feb 2008 03:57:40 +0000 (+0000) Subject: Remove GADT refinements, part 3 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=288213d7c2c65fa68ca466c1a1a3378e24fa1151 Remove GADT refinements, part 3 --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 68bafde..665b898 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -656,7 +656,6 @@ mkRecordSelId tycon field_label -- T1 b' (c : [b]=[b']) (x:Maybe b') -- -> x `cast` Maybe (sym (right c)) - -- Generate the refinement for b'=b, -- and apply to (Maybe b'), to get (Maybe b) Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 6bcd3a3..db61c6d 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -603,15 +603,13 @@ pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co}) (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2)) (\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2)) pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon - <+> (braces (ppr (instType inst) <> implicWantedEqs) $$ - ifPprDebug implic_stuff) + <+> braces (ppr (instType inst) <> implicWantedEqs) where name = instName inst - (implic_stuff, implicWantedEqs) - | isImplicInst inst = (ppr (tci_reft inst), - text " &" <+> - ppr (filter isEqInst (tci_wanted inst))) - | otherwise = (empty, empty) + implicWantedEqs + | isImplicInst inst = text " &" <+> + ppr (filter isEqInst (tci_wanted inst)) + | otherwise = empty pprInstInFull inst@(EqInst {}) = pprInst inst pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)] diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index f0cb72a..90a5e88 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -27,7 +27,6 @@ import TcType import TcMType import TcBinds import TcSimplify -import TcGadt import TcPat import TcUnify import TcRnMonad diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index ac55f4b..ad45c7c 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -35,7 +35,6 @@ module TcEnv( tcLookupId, tcLookupTyVar, getScopedTyVarBinds, lclEnvElts, getInLocalScope, findGlobals, wrongThingErr, pprBinders, - refineEnvironment, tcExtendRecEnv, -- For knot-tying @@ -61,7 +60,6 @@ import IfaceEnv import TcRnMonad import TcMType import TcType -import TcGadt -- import TcSuspension import qualified Type import Var @@ -452,38 +450,6 @@ find_thing ignore_it tidy_env (ATyVar tv ty) = do find_thing _ _ thing = pprPanic "find_thing" (ppr thing) \end{code} -\begin{code} -refineEnvironment - :: Refinement - -> Bool -- whether type equations are involved - -> TcM a - -> TcM a --- I don't think I have to refine the set of global type variables in scope --- Reason: the refinement never increases that set -refineEnvironment reft otherEquations thing_inside - | isEmptyRefinement reft -- Common case - , not otherEquations - = thing_inside - | otherwise - = do { env <- getLclEnv - ; let le' = mapNameEnv refine (tcl_env env) - ; setLclEnv (env {tcl_env = le'}) thing_inside } - where - refine elt@(ATcId { tct_co = Rigid co, tct_type = ty }) - | Just (co', ty') <- refineType reft ty - = elt { tct_co = Rigid (WpCo co' <.> co), tct_type = ty' } - refine elt@(ATcId { tct_co = Wobbly}) --- Main new idea: make wobbly things invisible whenever there --- is a refinement of any sort --- | otherEquations - = elt { tct_co = WobblyInvisible} - refine (ATyVar tv ty) - | Just (_, ty') <- refineType reft ty - = ATyVar tv ty' -- Ignore the coercion that refineType returns - - refine elt = elt -- Common case -\end{code} - %************************************************************************ %* * \subsection{The global tyvars} diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index caab44a..b7262d6 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -25,7 +25,6 @@ import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr ) import HsSyn import TcRnMonad -import TcGadt import Inst import TcEnv import TcPat diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index a5dd001..61ee938 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -36,7 +36,6 @@ import VarSet import TcUnify import TcHsType import TysWiredIn -import TcGadt import Type import Coercion import StaticFlags @@ -670,7 +669,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; loc <- getInstLoc origin ; dicts <- newDictBndrs loc theta' - ; dict_binds <- tcSimplifyCheckPat loc [] ex_tvs' dicts lie_req + ; dict_binds <- tcSimplifyCheckPat loc ex_tvs' dicts lie_req ; let res_pat = ConPatOut { pat_con = L con_span data_con, pat_tvs = ex_tvs', diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 268ac0e..43b9d38 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -85,7 +85,6 @@ import DataCon import TcHsType import TcMType import TcMatches -import TcGadt import RnTypes import RnExpr import IfaceEnv diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 3868e0f..98bb936 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -53,7 +53,6 @@ import Packages import Type import Coercion import TcType -import TcGadt import InstEnv import FamInstEnv import IOEnv @@ -632,7 +631,7 @@ type Int, represented by Method 34 doubleId [Int] origin In addition to the basic Haskell variants of 'Inst's, they can now also -represent implication constraints 'forall tvs. (reft, given) => wanted' +represent implication constraints 'forall tvs. given => wanted' and equality constraints 'co :: ty1 ~ ty2'. NB: Equalities occur in two flavours: @@ -655,12 +654,9 @@ data Inst } | ImplicInst { -- An implication constraint - -- forall tvs. (reft, given) => wanted + -- forall tvs. given => wanted tci_name :: Name, tci_tyvars :: [TcTyVar], -- Quantified type variables - -- Includes coercion variables - -- mentioned in tci_reft - tci_reft :: Refinement, tci_given :: [Inst], -- Only Dicts and EqInsts -- (no Methods, LitInsts, ImplicInsts) tci_wanted :: [Inst], -- Only Dicts, EqInst, and ImplicInsts @@ -668,9 +664,7 @@ data Inst tci_loc :: InstLoc } - -- NB: the tci_given are not necessarily rigid, - -- although they will be if the tci_reft is non-trivial - -- NB: the tci_reft is already applied to tci_given and tci_wanted + -- NB: the tci_given are not necessarily rigid | Method { tci_id :: TcId, -- The Id for the Inst diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 4ba185f..3212e53 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -36,7 +36,6 @@ import TcRnMonad import Inst import TcEnv import InstEnv -import TcGadt import TcType import TcMType import TcIface @@ -921,16 +920,15 @@ tcSimplifyCheck loc qtvs givens wanteds ----------------------------------------------------------- -- tcSimplifyCheckPat is used for existential pattern match tcSimplifyCheckPat :: InstLoc - -> [CoVar] -> [TcTyVar] -- Quantify over these -> [Inst] -- Given -> [Inst] -- Wanted -> TcM TcDictBinds -- Bindings -tcSimplifyCheckPat loc co_vars qtvs givens wanteds +tcSimplifyCheckPat loc qtvs givens wanteds = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs ) do { traceTc (text "tcSimplifyCheckPat") ; (irreds, binds) <- gentleCheckLoop loc givens wanteds - ; implic_bind <- bindIrredsR loc qtvs co_vars givens irreds + ; implic_bind <- bindIrredsR loc qtvs givens irreds ; return (binds `unionBags` implic_bind) } ----------------------------------------------------------- @@ -938,13 +936,12 @@ bindIrreds :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds bindIrreds loc qtvs givens irreds - = bindIrredsR loc qtvs [] givens irreds + = bindIrredsR loc qtvs givens irreds -bindIrredsR :: InstLoc -> [TcTyVar] -> [CoVar] -> [Inst] -> [Inst] - -> TcM TcDictBinds +bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds -- Make a binding that binds 'irreds', by generating an implication -- constraint for them, *and* throwing the constraint into the LIE -bindIrredsR loc qtvs co_vars givens irreds +bindIrredsR loc qtvs givens irreds | null irreds = return emptyBag | otherwise @@ -965,8 +962,7 @@ bindIrredsR loc qtvs co_vars givens irreds ; return real_irreds } else return irreds - ; let all_tvs = qtvs ++ co_vars -- Abstract over all these - ; (implics, bind) <- makeImplicationBind loc all_tvs givens' irreds' + ; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds' -- This call does the real work -- If irreds' is empty, it does something sensible ; extendLIEs implics @@ -1000,7 +996,7 @@ makeImplicationBind loc all_tvs -- 'givens' must be a simple CoVar. This MUST be cleaned up. ; let name = mkInternalName uniq (mkVarOcc "ic") span - implic_inst = ImplicInst { tci_name = name, tci_reft = emptyRefinement, + implic_inst = ImplicInst { tci_name = name, tci_tyvars = all_tvs, tci_given = (eq_givens ++ dict_givens), tci_wanted = irreds, tci_loc = loc } @@ -2137,7 +2133,7 @@ Note that -- reduceImplication env orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc, - tci_tyvars = tvs, tci_reft = emptyRefinement, + tci_tyvars = tvs, tci_given = extra_givens, tci_wanted = wanteds }) = do { -- Solve the sub-problem ; let try_me inst = ReduceMe AddSCs -- Note [Freeness and implications] diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 2d1589c..8fd3d83 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -370,7 +370,7 @@ extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs }) add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) (ins_tyvar || cur_tyvar) ins_tyvar = not (any isJust mb_tcs) -\end{code} +\end{code} %************************************************************************ @@ -483,7 +483,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -- They shouldn't because we allocate separate uniques for them case tcUnifyTys bind_fn tpl_tys tys of Just _ -> find ms (item:us) rest - Nothing -> find ms us rest + Nothing -> find ms us rest --------------- bind_fn :: TyVar -> BindFlag