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

File 0001-Improve-No-data-constructor-has-all-these-fields-mes.2.patch, 3.6 KB (added by akio, 2 years ago)
  • compiler/typecheck/TcExpr.lhs

    From cccfd6ed3d191007cc0765fdd0d100d67a415f43 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 |   55 ++++++++++++++++++++++++++++++++++++++---
     1 file changed, 51 insertions(+), 4 deletions(-)
    
    diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
    index 8615293..31c1e06 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 
    15091512                         <> plural prs <> colon)
    15101513       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
    15111514
    1512 badFieldsUpd :: HsRecFields Name a -> SDoc
    1513 badFieldsUpd rbinds
     1515badFieldsUpd
     1516  :: HsRecFields Name a -- Field names that don't belong to a single datacon
     1517  -> [DataCon] -- Data cons of the type which the first field name belongs to
     1518  -> SDoc
     1519badFieldsUpd rbinds data_cons
    15141520  = hang (ptext (sLit "No constructor has all these fields:"))
    1515        2 (pprQuotedList (hsRecFields rbinds))
     1521       2 (pprQuotedList conflictingFields)
     1522  where
     1523    -- A (preferably small) set of fields such that no constructor contains
     1524    -- all of them.
     1525    conflictingFields = case nonMembers of
     1526        -- nonMember belongs to a different type.
     1527        (nonMember, _) : _ -> [aMember, nonMember]
     1528        [] -> let
     1529            -- All of rbinds belong to one type. In this case, repeatedly add
     1530            -- a field to the set until no constructor contains the set.
     1531
     1532            -- Each field, together with a list indicating which constructors
     1533            -- have all the fields so far.
     1534            growingSets :: [(Name, [Bool])]
     1535            growingSets = scanl1 combine membership
     1536            combine (_, setMem) (field, fldMem)
     1537              = (field, zipWith (&&) setMem fldMem)
     1538            in
     1539            -- Fields that don't change the membership status of the set
     1540            -- are redundant and can be dropped.
     1541            map (fst . head) $ groupBy ((==) `on` snd) growingSets
     1542
     1543    aMember = ASSERT( not (null members) ) fst (head members)
     1544    (members, nonMembers) = partition (or . snd) membership
     1545
     1546    -- For each field, which constructors contain the field?
     1547    membership :: [(Name, [Bool])]
     1548    membership = sortMembership $
     1549        map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
     1550          hsRecFields rbinds
     1551
     1552    fieldLabelSets :: [Set.Set Name]
     1553    fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons
     1554
     1555    -- Sort in order of increasing number of True, so that a smaller
     1556    -- conflicting set can be found.
     1557    sortMembership =
     1558      map snd .
     1559      sortBy (compare `on` fst) .
     1560      map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
     1561
     1562    countTrue = length . filter id
    15161563
    15171564naughtyRecordSel :: TcId -> SDoc
    15181565naughtyRecordSel sel_id