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, 10 months ago)
  • compiler/typecheck/TcExpr.lhs

    From cccfd6ed3d191007cc0765fdd0d100d67a415f43 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 |   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