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, 2 years ago)

Proposed patch

  • compiler/typecheck/TcExpr.lhs

    From b686978ab04533b4cc8a8d0ade2a2d10430e3c69 Mon Sep 17 00:00:00 2001
    From: Takano Akio <[email protected]>
    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