[commit: ghc] overlapping-tyfams: Added check to find inaccessible equations in family instance groups. (01b5511)

[Richard Eisenberg]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : overlapping-tyfams

http://hackage.haskell.org/trac/ghc/changeset/01b5511e99a0bf403489730566faf98176172095

>---------------------------------------------------------------

commit 01b5511e99a0bf403489730566faf98176172095
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Thu Aug 16 16:22:13 2012 -0400

    Added check to find inaccessible equations in family instance groups.
    
    This check uses the isDominatedBy function in types/FamInstEnv, which
    is currently incomplete. Thus, it is possible some inaccessible
    equations will not be marked as such. However, all equations marked
    as inaccessible are, so good code can never produce an error.
    It's worth noting that bad code that does not produce an error is
    silly, but does not compromise the type system.

>---------------------------------------------------------------

 compiler/typecheck/TcInstDcls.lhs |   16 +++++++++++++++-
 compiler/types/FamInstEnv.lhs     |    2 ++
 2 files changed, 17 insertions(+), 1 deletions(-)

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 2e93b11..cd75239 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -596,6 +596,9 @@ tcTyFamInstDecl fam_tc decl
          -- ... and then do processing seperately per instance equation
        ; fam_insts <- mapM check_valid_mk_fam_inst quads
 
+         -- (4) check to see if earlier equations dominate a later one
+       ; foldlM_ check_inaccessible_fam_inst [] fam_insts
+
          -- now, build the FamInstGroup
        ; return $ mkSynFamInstGroup fam_tc fam_insts }
 
@@ -605,11 +608,17 @@ tcTyFamInstDecl fam_tc decl
               do { -- (2) check the well-formedness of the instance
                    checkValidFamInst t_typats t_rhs
 
-                   -- (3) construct representation tycon
+                   -- (3) construct coercion tycon
                  ; rep_tc_name <- newFamInstAxiomName loc (tyFamInstDeclName decl) t_typats
 
                  ; return $ mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs }
 
+          check_inaccessible_fam_inst :: [FamInst] -> FamInst -> TcM [FamInst]
+          check_inaccessible_fam_inst prev_insts cur_inst@(FamInst { fi_tys = tys })
+            = setSrcSpan (getSrcSpan cur_inst) $
+              do { when (tys `isDominatedBy` prev_insts) $
+                        addErrTc $ inaccessibleFamInst cur_inst
+                 ; return $ cur_inst : prev_insts }
 
 tcDataFamInstDecl :: TyCon -> DataFamInstDecl Name -> TcM FamInstGroup
   -- "newtype instance" and "data instance"
@@ -1489,4 +1498,9 @@ badFamInstDecl tc_name
   = vcat [ ptext (sLit "Illegal family instance for") <+>
            quotes (ppr tc_name)
          , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
+
+inaccessibleFamInst :: FamInst -> SDoc
+inaccessibleFamInst fi
+  = ptext (sLit "Inaccessible family instance equation:") $$ (ppr fi)
+
 \end{code}
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 982dfa2..90558a0 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -31,6 +31,8 @@ module FamInstEnv (
 	extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, 
 	identicalFamInstGroup, identicalFamInst, famInstEnvElts, familyInstances,
 
+        isDominatedBy,
+
         FamInstMatch(..),
         lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts',