[commit: ghc] overlapping-tyfams: Checkpoint. (09a8a7f)
Richard Eisenberg
eir at cis.upenn.edu
Fri Jun 21 15:16:19 CEST 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : overlapping-tyfams
https://github.com/ghc/ghc/commit/09a8a7fd96b44b20d168fbb167cdee20006ebb32
>---------------------------------------------------------------
commit 09a8a7fd96b44b20d168fbb167cdee20006ebb32
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Mon May 27 22:04:34 2013 +0100
Checkpoint.
>---------------------------------------------------------------
compiler/types/FamInstEnv.lhs | 67 +++++++++++++++++++++++++------------------
1 file changed, 39 insertions(+), 28 deletions(-)
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index beb47d4..4e77a61 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -52,6 +52,7 @@ import UniqFM
import Outputable
import Maybes
import Util
+import SrcLoc
import FastString
\end{code}
@@ -194,12 +195,12 @@ famInstSingleBranch :: FamInst Unbranched -> FamInstBranch
famInstSingleBranch (FamInst { fi_branches = FirstBranch branch }) = branch
toBranchedFamInst :: FamInst br -> FamInst Branched
-toBranchedFamInst (FamInst ax flav grp branches fam)
- = FamInst (toBranchedAxiom ax) flav grp (toBranchedList branches) fam
+toBranchedFamInst (FamInst ax flav grp space branches fam)
+ = FamInst (toBranchedAxiom ax) flav grp space (toBranchedList branches) fam
toUnbranchedFamInst :: FamInst br -> FamInst Unbranched
-toUnbranchedFamInst (FamInst ax flav grp branches fam)
- = FamInst (toUnbranchedAxiom ax) flav grp (toUnbranchedList branches) fam
+toUnbranchedFamInst (FamInst ax flav grp space branches fam)
+ = FamInst (toUnbranchedAxiom ax) flav grp space (toUnbranchedList branches) fam
famInstBranches :: FamInst br -> BranchList FamInstBranch br
famInstBranches = fi_branches
@@ -207,6 +208,9 @@ famInstBranches = fi_branches
famInstBranchLHS :: FamInstBranch -> [Type]
famInstBranchLHS = fib_lhs
+famInstBranchRHS :: FamInstBranch -> Type
+famInstBranchRHS = fib_rhs
+
famInstBranchRoughMatch :: FamInstBranch -> [Maybe Name]
famInstBranchRoughMatch = fib_tcs
@@ -249,8 +253,9 @@ pprFamInst (FamInst { fi_branches = brs, fi_flavor = SynFamilyInst
= hang (ptext (sLit "type instance") <+> ppr_space <+> ptext (sLit "where"))
2 (vcat [pprCoAxBranchHdr axiom i | i <- brListIndices brs])
where ppr_space
- | Nothing <- space = empty
- | Just (FamInstSpace { fis_tys = tys }) <- space
+ | NoFamInstSpace <- space = empty
+
+ | FamInstSpace { fis_tys = tys } <- space
= pprTypeApp (coAxiomTyCon axiom) tys
pprFamInst fi@(FamInst { fi_flavor = flavor
@@ -469,14 +474,14 @@ identicalFamInst (FamInst { fi_axiom = ax1, fi_space = sp1 })
lhs2 = coAxBranchLHS br2
rn_env = rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2
- identical_space Nothing Nothing = True
- identical_space Nothing (Just sp) = identical_space (Just sp) Nothing
- identical_space (Just (FamInstSpace { fis_tcs = tcs })) Nothing
+ identical_space NoFamInstSpace NoFamInstSpace = True
+ identical_space NoFamInstSpace sp = identical_space sp NoFamInstSpace
+ identical_space (FamInstSpace { fis_tcs = tcs }) NoFamInstSpace
= all isNothing tcs
- identical_space (Just (FamInstSpace { fis_tvs = tvs1
- , fis_tys = tys1 }))
- (Just (FamInstSpace { fis_tvs = tvs2
- , fis_tys = tys2 }))
+ identical_space (FamInstSpace { fis_tvs = tvs1
+ , fis_tys = tys1 })
+ (FamInstSpace { fis_tvs = tvs2
+ , fis_tys = tys2 })
= eqTypesX rn_env tys1 tys2
where rn_env = rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2
@@ -612,7 +617,7 @@ lookupFamInstEnv (pkg_ie, home_ie) fam_tc tys
= lookupFamInstEnv' pkg_ie fam_tc tys ++
lookupFamInstEnv' home_ie fam_tc tys
-lookupFamInstEnv' :: FamInstEnvs
+lookupFamInstEnv' :: FamInstEnv
-> TyCon -> [Type] -- What we are looking for
-> [FamInstMatch] -- Successful matches
lookupFamInstEnv' ie fam tys
@@ -636,7 +641,7 @@ lookupFamInstEnv' ie fam tys
find :: [Type] -> [FamInst Branched] -> [FamInstMatch]
find _ [] = []
find match_tys (inst@(FamInst { fi_branches = branches }) : rest)
- = case findBranch [] (fromBranchList branches) 0 of
+ = case findBranch (fromBranchList branches) 0 of
(Just match, StopSearching) -> [match]
(Just match, KeepSearching) -> match : find match_tys rest
(Nothing, StopSearching) -> []
@@ -654,7 +659,7 @@ find match_tys (inst@(FamInst { fi_branches = branches }) : rest)
| instanceCantMatch rough_tcs mb_tcs
= findBranch rest (ind+1)
| otherwise
- = ASSERT( tyVarsOfTypes match_tys `disjointVarSet` mkVarSet tpl_tvs )
+ = ASSERT( tyVarsOfTypes match_tys `disjointVarSet` tpl_tvs )
case tcMatchTys tpl_tvs tpl_tys match_tys of
Just subst
-> let match = FamInstMatch { fim_instance = inst
@@ -688,31 +693,33 @@ lookupFamInstEnvConflicts (pkg_ie, home_ie) fi
lookupFamInstEnvConflicts' :: FamInstEnv
-> FamInst br -- the putative new instance
-> [FamInst Branched] -- Conflicting instances
-lookupFamInstEnvConflicts' ie fi@(FamInst { fi_space = mb_space })
+lookupFamInstEnvConflicts' ie fi@(FamInst { fi_space = space, fi_branched = branched })
| isFamilyTyCon fam
, Just (FamIE insts) <- lookupUFM ie fam
- = case mb_space of
- Nothing -> insts
- Just (FamInstSpace { fis_tys = tys, fis_tcs = tcs }) ->
+ = case space of
+ NoFamInstSpace -> insts
+ FamInstSpace { fis_tys = tys, fis_tcs = tcs } ->
filter (conflictsWith tys tcs mb_rhs) insts
| otherwise = []
where
fam = famInstTyCon fi
- mb_rhs = if branched then Nothing
- else Just famInstBranchRHS $ famInstSingleBranch fi
+ mb_rhs
+ | Branched <- branched = Nothing
+ | otherwise = Just $ famInstBranchRHS $ famInstSingleBranch fi
conflictsWith :: [Type] -- type patterns of the new instance
-> [Maybe Name] -- rough match tycons of the new instance
-> Maybe Type -- if confluent overlap is possible, the rhs
-> FamInst Branched -- do we conflict with this instance?
-> Bool
-conflictsWith _ _ _ (FamInst { fi_space = Nothing })
+conflictsWith _ _ _ (FamInst { fi_space = NoFamInstSpace })
= True -- if the space is Nothing, it conflicts with all other instances
conflictsWith tys rough_tcs mb_rhs
fi@(FamInst { fi_branched = old_branched
- , fi_space = Just (FamInstSpace { fis_tys = space_tys
- , fis_tcs = space_tcs }) })
- | instanceCantMatch rough_tcs old_tcs
+ , fi_space = FamInstSpace { fis_tys = space_tys
+ , fis_tcs = space_tcs }
+ , fi_flavor = flavor })
+ | instanceCantMatch rough_tcs space_tcs
= False -- no conflict here if the top-level structures don't match
| otherwise
@@ -721,15 +728,19 @@ conflictsWith tys rough_tcs mb_rhs
-- Unification will break badly if the variables overlap
-- They shouldn't because we allocate separate uniques for them
Just subst ->
- isDataFamilyTyCon tc ||
+ isDataFlavor ||
isBranched old_branched ||
- rhs_conflict mb_rhs (famInstBranchRHS $ famInstSingleBranch fi) subst
+ rhs_conflict mb_rhs (famInstBranchRHS $ famInstSingleBranch $ toUnbranchedFamInst fi)
+ subst
-- we don't need to check if the new instance is branched, because
-- if it is, mb_rhs will be Nothing, and rhs_conflict will return True
Nothing -> False -- no match
where
+ isDataFlavor | DataFamilyInst {} <- flavor = True
+ | otherwise = False
+
-- checks whether two RHSs are distinct, under a unifying substitution
-- Note [Family instance overlap conflicts]
rhs_conflict :: Maybe Type -> Type -> TvSubst -> Bool
More information about the ghc-commits
mailing list