Commit 7d699782 authored by Ryan Scott's avatar Ryan Scott

Use NonEmpty lists to represent lists of duplicate elements

Summary:
Three functions in `ListSetOps` which compute duplicate elements
represent lists of duplicates of `[a]`. This is a really bad way to go about
things, because these lists are guaranteed to always have at least one element
(the "representative" of the duplicates), and several places in the GHC API
call `head` (a partial function) on these lists of duplicates to retrieve the
representative.

This changes the representation of duplicates to `NonEmpty` lists instead,
which allow for many partial uses of `head` to be made total.

Fixes #13823.

Test Plan: ./validate

Reviewers: bgamari, austin, goldfire

Reviewed By: bgamari

Subscribers: goldfire, rwbarton, thomie

GHC Trac Issues: #13823

Differential Revision: https://phabricator.haskell.org/D3823
parent 3f05e5f6
......@@ -66,6 +66,8 @@ import DynFlags
import Control.Monad
import qualified Control.Monad.Fail as MonadFail
import MonadUtils
import Data.Foldable ( toList )
import Data.List.NonEmpty ( NonEmpty )
import Data.Maybe
import Pair
import qualified GHC.LanguageExtensions as LangExt
......@@ -2427,15 +2429,15 @@ pprLeftOrRight :: LeftOrRight -> MsgDoc
pprLeftOrRight CLeft = text "left"
pprLeftOrRight CRight = text "right"
dupVars :: [[Var]] -> MsgDoc
dupVars :: [NonEmpty Var] -> MsgDoc
dupVars vars
= hang (text "Duplicate variables brought into scope")
2 (ppr vars)
2 (ppr (map toList vars))
dupExtVars :: [[Name]] -> MsgDoc
dupExtVars :: [NonEmpty Name] -> MsgDoc
dupExtVars vars
= hang (text "Duplicate top-level variables with the same qualified name")
2 (ppr vars)
2 (ppr (map toList vars))
{-
************************************************************************
......
......@@ -58,7 +58,9 @@ import Maybes ( orElse )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List ( partition, sort )
import Data.Foldable ( toList )
import Data.List ( partition, sort )
import Data.List.NonEmpty ( NonEmpty(..) )
{-
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
......@@ -1091,7 +1093,7 @@ okHsSig ctxt (L _ sig)
(CompleteMatchSig {}, _) -> False
-------------------
findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]]
findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
-- not-in-scope binders, which gives bogus dup-sig errors
......@@ -1243,17 +1245,18 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
************************************************************************
-}
dupSigDeclErr :: [(Located RdrName, Sig GhcPs)] -> RnM ()
dupSigDeclErr pairs@((L loc name, sig) : _)
dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()
dupSigDeclErr pairs@((L loc name, sig) :| _)
= addErrAt loc $
vcat [ text "Duplicate" <+> what_it_is
<> text "s for" <+> quotes (ppr name)
, text "at" <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ]
, text "at" <+> vcat (map ppr $ sort
$ map (getLoc . fst)
$ toList pairs)
]
where
what_it_is = hsSigDoc sig
dupSigDeclErr [] = panic "dupSigDeclErr"
misplacedSigErr :: LSig GhcRn -> RnM ()
misplacedSigErr (L loc sig)
= addErrAt loc $
......
......@@ -57,6 +57,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
{-
************************************************************************
......@@ -970,7 +971,7 @@ rnParallelStmts ctxt return_op segs thing_inside
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
<+> quotes (ppr (head vs)))
<+> quotes (ppr (NE.head vs)))
lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupSyntaxName, but respects contexts
......
......@@ -68,6 +68,7 @@ import DataCon
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad ( when, liftM, ap, unless )
import qualified Data.List.NonEmpty as NE
import Data.Ratio
{-
......@@ -690,7 +691,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-- Data constructor not lexically in scope at all
-- See Note [Disambiguation and Template Haskell]
dup_flds :: [[RdrName]]
dup_flds :: [NE.NonEmpty RdrName]
-- Each list represents a RdrName that occurred more than once
-- (the list contains all occurrences)
-- Each list in dup_fields is non-empty
......@@ -769,7 +770,7 @@ rnHsRecUpdFields flds
, hsRecFieldArg = arg''
, hsRecPun = pun }), fvs') }
dup_flds :: [[RdrName]]
dup_flds :: [NE.NonEmpty RdrName]
-- Each list represents a RdrName that occurred more than once
-- (the list contains all occurrences)
-- Each list in dup_fields is non-empty
......@@ -803,10 +804,10 @@ badPun :: Located RdrName -> SDoc
badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
text "Use NamedFieldPuns to permit this"]
dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
dupFieldErr ctxt dups
= hsep [text "duplicate field name",
quotes (ppr (head dups)),
quotes (ppr (NE.head dups)),
text "in record", pprRFC ctxt]
pprRFC :: HsRecFieldContext -> SDoc
......
......@@ -63,7 +63,9 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Arrow ( first )
import Data.List ( sortBy, mapAccumL )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe ( isJust )
import qualified Data.Set as Set ( difference, fromList, toList, null )
......@@ -320,7 +322,7 @@ rnSrcWarnDecls _ []
rnSrcWarnDecls bndr_set decls'
= do { -- check for duplicates
; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
; mapM_ (\ dups -> let (L loc rdr :| (lrdr':_)) = dups
in addErrAt loc (dupWarnDecl lrdr' rdr))
warn_rdr_dups
; pairs_s <- mapM (addLocM rn_deprec) decls
......@@ -341,7 +343,7 @@ rnSrcWarnDecls bndr_set decls'
warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
decls
findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
-- look for duplicates among the OccNames;
......@@ -745,11 +747,11 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
-- Report unused binders on the LHS
-- See Note [Unused type variables in family instances]
; let groups :: [[Located RdrName]]
; let groups :: [NonEmpty (Located RdrName)]
groups = equivClasses cmpLocated $
freeKiTyVarsAllVars pat_kity_vars_with_dups
; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
[ tv | (tv:_:_) <- groups ]
[ tv | (tv :| (_:_)) <- groups ]
-- Add to the used variables
-- a) any variables that appear *more than once* on the LHS
-- e.g. F a Int a = Bool
......@@ -1530,16 +1532,15 @@ rnRoleAnnots tc_names role_annots
tycon
; return $ RoleAnnotDecl tycon' roles }
dupRoleAnnotErr :: [LRoleAnnotDecl GhcPs] -> RnM ()
dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr list
= addErrAt loc $
hang (text "Duplicate role annotations for" <+>
quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
2 (vcat $ map pp_role_annot sorted_list)
2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
where
sorted_list = sortBy cmp_annot list
(L loc first_decl : _) = sorted_list
sorted_list = NE.sortBy cmp_annot list
(L loc first_decl :| _) = sorted_list
pp_role_annot (L loc decl) = hang (ppr decl)
4 (text "-- written at" <+> ppr loc)
......
......@@ -62,8 +62,9 @@ import FastString
import Maybes
import qualified GHC.LanguageExtensions as LangExt
import Data.List ( nubBy, partition )
import Control.Monad ( unless, when )
import Data.List ( nubBy, partition )
import Data.List.NonEmpty ( NonEmpty(..) )
import Control.Monad ( unless, when )
#include "HsVersions.h"
......@@ -974,7 +975,7 @@ bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
addErrAt loc (vcat [ ki_ty_err_msg name
, pprHsDocContext doc ])
; when (name `elemNameSet` tv_names) $
dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}
dupNamesErr getLoc (L loc name :| [L (nameSrcSpan name) name]) }}
ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>
text "used as a kind variable before being bound" $$
......
......@@ -45,6 +45,7 @@ import FastString
import Control.Monad
import Data.List
import Constants ( mAX_TUPLE_SIZE )
import qualified Data.List.NonEmpty as NE
import qualified GHC.LanguageExtensions as LangExt
{-
......@@ -316,13 +317,13 @@ unknownSubordinateErr doc op -- Doc is "method of class" or
= quotes (ppr op) <+> text "is not a (visible)" <+> doc
dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
dupNamesErr get_loc names
= addErrAt big_loc $
vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),
vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
locations]
where
locs = map get_loc names
locs = map get_loc (NE.toList names)
big_loc = foldr1 combineSrcSpans locs
locations = text "Bound at:" <+> vcat (map ppr (sort locs))
......
......@@ -67,6 +67,7 @@ import qualified GHC.LanguageExtensions as LangExt
import ConLike
import Control.Monad
import Data.List.NonEmpty ( NonEmpty(..) )
#include "HsVersions.h"
......@@ -1160,7 +1161,7 @@ tcVectDecls decls
; return decls'
}
where
reportVectDups (first:_second:_more)
reportVectDups (first :| (_second:_more))
= addErrAt (getSrcSpan first) $
text "Duplicate vectorisation declarations for" <+> ppr first
reportVectDups _ = return ()
......
......@@ -58,6 +58,7 @@ import qualified GHC.LanguageExtensions as LangExt
import FV ( fvVarList, unionFV )
import Control.Monad ( when )
import Data.Foldable ( toList )
import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr )
import qualified Data.Set as Set
......@@ -697,7 +698,7 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
-- Group together errors from same location,
-- and report only the first (to avoid a cascade)
mkGroupReporter mk_err ctxt cts
= mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
= mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
eq_lhs_type :: Ct -> Ct -> Bool
eq_lhs_type ct1 ct2
......
......@@ -51,7 +51,9 @@ import ErrUtils ( emptyMessages )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List ( partition )
import Data.Foldable ( toList )
import Data.List ( partition )
import Data.List.NonEmpty ( NonEmpty(..) )
{-
*********************************************************************************
......@@ -2161,7 +2163,8 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
= []
| otherwise
= [ (tv, map fstOf3 group)
| group@((_,_,tv):_) <- unary_groups
| group'@((_,_,tv) :| _) <- unary_groups
, let group = toList group'
, defaultable_tyvar tv
, defaultable_classes (map sndOf3 group) ]
where
......@@ -2169,9 +2172,9 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
(unaries, non_unaries) = partitionWith find_unary (bagToList simples)
unary_groups = equivClasses cmp_tv unaries
unary_groups :: [[(Ct, Class, TcTyVar)]] -- (C tv) constraints
unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints
non_unaries :: [Ct] -- and *other* constraints
unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints
unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints
non_unaries :: [Ct] -- and *other* constraints
-- Finds unary type-class constraints
-- But take account of polykinded classes like Typeable,
......
......@@ -72,6 +72,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List
import Data.List.NonEmpty ( NonEmpty(..) )
{-
************************************************************************
......@@ -2368,7 +2369,7 @@ checkValidTyCon tc
-- result type against other candidates' types BOTH WAYS ROUND.
-- If they magically agrees, take the substitution and
-- apply them to the latter ones, and see if they match perfectly.
check_fields ((label, con1) : other_fields)
check_fields ((label, con1) :| other_fields)
-- These fields all have the same name, but are from
-- different constructors in the data type
= recoverM (return ()) $ mapM_ checkOne other_fields
......@@ -2386,7 +2387,6 @@ checkValidTyCon tc
where
(_, _, _, res2) = dataConSig con2
fty2 = dataConFieldType con2 lbl
check_fields [] = panic "checkValidTyCon/check_fields []"
checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
-> Type -> Type -> Type -> Type -> TcM ()
......
......@@ -62,6 +62,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List ( (\\) )
import qualified Data.List.NonEmpty as NE
{-
************************************************************************
......@@ -972,13 +973,13 @@ constraintSynErr env kind
, hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))
2 (parens constraintKindsMsg) )
dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc)
dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)
dupPredWarn env dups
= ( env
, text "Duplicate constraint" <> plural primaryDups <> text ":"
<+> pprWithCommas (ppr_tidy env) primaryDups )
where
primaryDups = map head dups
primaryDups = map NE.head dups
tyConArityErr :: TyCon -> [TcType] -> SDoc
-- For type-constructor arity errors, be careful to report
......
......@@ -27,6 +27,8 @@ import Outputable
import Util
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Set as S
getNth :: Outputable a => [a] -> Int -> a
......@@ -131,19 +133,19 @@ hasNoDups xs = f [] xs
equivClasses :: (a -> a -> Ordering) -- Comparison
-> [a]
-> [[a]]
-> [NonEmpty a]
equivClasses _ [] = []
equivClasses _ stuff@[_] = [stuff]
equivClasses cmp items = groupBy eq (sortBy cmp items)
equivClasses _ [] = []
equivClasses _ [stuff] = [stuff :| []]
equivClasses cmp items = NE.groupBy eq (sortBy cmp items)
where
eq a b = case cmp a b of { EQ -> True; _ -> False }
removeDups :: (a -> a -> Ordering) -- Comparison function
-> [a]
-> ([a], -- List with no duplicates
[[a]]) -- List of duplicate groups. One representative from
-- each group appears in the first result
-> ([a], -- List with no duplicates
[NonEmpty a]) -- List of duplicate groups. One representative
-- from each group appears in the first result
removeDups _ [] = ([], [])
removeDups _ [x] = ([x],[])
......@@ -151,12 +153,12 @@ removeDups cmp xs
= case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
(xs', dups) }
where
collect_dups _ [] = panic "ListSetOps: removeDups"
collect_dups dups_so_far [x] = (dups_so_far, x)
collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x)
collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)
collect_dups dups_so_far (x :| []) = (dups_so_far, x)
collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)
findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]
findDupsEq _ [] = []
findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs
| otherwise = (x:eq_xs) : findDupsEq eq neq_xs
| otherwise = (x :| eq_xs) : findDupsEq eq neq_xs
where (eq_xs, neq_xs) = partition (eq x) xs
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment