Ticket #7989: 0001-Improve-No-data-constructor-has-all-these-fields-mes.patch

File 0001-Improve-No-data-constructor-has-all-these-fields-mes.patch, 2.9 KB (added by akio, 10 months ago)

Proposed patch

  • compiler/typecheck/TcExpr.lhs

    From b686978ab04533b4cc8a8d0ade2a2d10430e3c69 Mon Sep 17 00:00:00 2001
    From: Takano Akio <aljee@hyper.cx>
    Date: Mon, 17 Jun 2013 18:42:09 +0900
    Subject: [PATCH] Improve "No data constructor has all these fields" message
     (#7989)
    
    ---
     compiler/typecheck/TcExpr.lhs |   34 ++++++++++++++++++++++++++++++----
     1 file changed, 30 insertions(+), 4 deletions(-)
    
    diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
    index f58c466..aeb5be7 100644
    a b import Outputable 
    5858import FastString 
    5959import Control.Monad 
    6060import Class(classTyCon) 
     61import Data.Function 
     62import Data.List 
     63import qualified Data.Set as Set 
    6164\end{code} 
    6265 
    6366%************************************************************************ 
    tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty 
    660663        -- Step 2 
    661664        -- Check that at least one constructor has all the named fields 
    662665        -- i.e. has an empty set of bad fields returned by badFields 
    663         ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds) 
     666        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds data_cons) 
    664667 
    665668        -- STEP 3    Note [Criteria for update] 
    666669        -- Check that each updated field is polymorphic; that is, its type 
    badFieldTypes prs 
    15101513                         <> plural prs <> colon) 
    15111514       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) 
    15121515 
    1513 badFieldsUpd :: HsRecFields Name a -> SDoc 
    1514 badFieldsUpd rbinds 
     1516badFieldsUpd 
     1517  :: HsRecFields Name a -- Field names that don't belong to a single datacon 
     1518  -> [DataCon] -- Data cons of the type which the first field name belongs to 
     1519  -> SDoc 
     1520badFieldsUpd rbinds data_cons 
    15151521  = hang (ptext (sLit "No constructor has all these fields:")) 
    1516        2 (pprQuotedList (hsRecFields rbinds)) 
     1522       2 (pprQuotedList conflictingFields) 
     1523  where 
     1524    -- A (preferably small) set of fields such that no constructor contains 
     1525    -- all of them. 
     1526    conflictingFields = case nonMembers of 
     1527        -- nonMember belongs to a different type. 
     1528        (nonMember, _) : _ -> [aMember, nonMember] 
     1529        [] -> 
     1530          -- All of rbinds belong to one type. In this case, repeatedly add 
     1531          -- a field to the set until no constructor contains the set. 
     1532          map (fst . head) $ groupBy ((==) `on` snd) $ scanl1 combine membership 
     1533 
     1534    combine (_, setMem) (field, fldMem) = (field, zipWith (&&) setMem fldMem) 
     1535    aMember = ASSERT( not (null members) ) fst (head members) 
     1536    (members, nonMembers) = partition (or . snd) membership 
     1537 
     1538    -- For each field, which constructors contain the field? 
     1539    membership :: [(Name, [Bool])] 
     1540    membership = map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ 
     1541        hsRecFields rbinds 
     1542    fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons 
    15171543 
    15181544naughtyRecordSel :: TcId -> SDoc 
    15191545naughtyRecordSel sel_id