diff options
author | M Farkas-Dyck <strake888@proton.me> | 2022-10-22 15:04:11 -0800 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-11-23 21:59:03 -0500 |
commit | 040bfdc359fcc5415ab8836b38982c07c31ea6a2 (patch) | |
tree | 0787c8d7b473e6fca98231ce975209081c132573 /compiler | |
parent | 99aca26b652603bc62953157a48e419f737d352d (diff) | |
download | haskell-040bfdc359fcc5415ab8836b38982c07c31ea6a2.tar.gz |
Scrub some no-warning pragmas.
Diffstat (limited to 'compiler')
59 files changed, 143 insertions, 270 deletions
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 5e59c30884..9e1780d475 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -207,6 +207,7 @@ import GHC.Utils.Panic.Plain import qualified Data.ByteString.Char8 as BS +import Data.Foldable import Data.List ( elemIndex, intersperse ) alpha_tyvar :: [TyVar] @@ -1611,7 +1612,7 @@ sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] where -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType prim_rep_fun [rr_ty_list] - = map slotPrimRep (ubxSumRepType prim_repss) + = map slotPrimRep (toList (ubxSumRepType prim_repss)) where rr_tys = extractPromotedList rr_ty_list doc = text "sumRepDataCon" <+> ppr rr_tys @@ -1734,27 +1735,9 @@ unliftedRepTy = mkTyConTy unliftedRepTyCon vecCountTyConName :: Name vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon --- See Note [Wiring in RuntimeRep] -vecCountDataConNames :: [Name] -vecCountDataConNames = zipWith3Lazy mk_runtime_rep_dc_name - [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" - , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] - vecCountDataConKeys - vecCountDataCons - vecElemTyConName :: Name vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon --- See Note [Wiring in RuntimeRep] -vecElemDataConNames :: [Name] -vecElemDataConNames = zipWith3Lazy mk_runtime_rep_dc_name - [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" - , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" - , fsLit "Word32ElemRep", fsLit "Word64ElemRep" - , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] - vecElemDataConKeys - vecElemDataCons - vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon , mkTyConTy vecElemTyCon ] @@ -1777,12 +1760,13 @@ vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons -- See Note [Wiring in RuntimeRep] vecCountDataCons :: [DataCon] -vecCountDataCons = zipWithLazy mk_vec_count_dc - [ 2, 4, 8, 16, 32, 64 ] - vecCountDataConNames +vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys where - mk_vec_count_dc n name - = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + mk_vec_count_dc logN key = con + where + n = 2^(logN :: Int) + name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con + con = pcSpecialDataCon name [] vecCountTyCon (VecCount n) -- See Note [Wiring in RuntimeRep] vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, @@ -1795,14 +1779,19 @@ vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons -- See Note [Wiring in RuntimeRep] vecElemDataCons :: [DataCon] -vecElemDataCons = zipWithLazy mk_vec_elem_dc - [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep - , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep - , FloatElemRep, DoubleElemRep ] - vecElemDataConNames +vecElemDataCons = zipWith3 mk_vec_elem_dc + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep" + , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep + , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep + , FloatElemRep, DoubleElemRep ] + vecElemDataConKeys where - mk_vec_elem_dc elem name - = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) + mk_vec_elem_dc nameFs elemRep key = con + where + name = mk_runtime_rep_dc_name nameFs key con + con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep) -- See Note [Wiring in RuntimeRep] int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, diff --git a/compiler/GHC/Cmm/ContFlowOpt.hs b/compiler/GHC/Cmm/ContFlowOpt.hs index 59ed1e760b..9fc364868a 100644 --- a/compiler/GHC/Cmm/ContFlowOpt.hs +++ b/compiler/GHC/Cmm/ContFlowOpt.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ContFlowOpt ( cmmCfgOpts , cmmCfgOptsProc diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 47930b2e99..0e381e31c4 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -9,9 +9,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- CmmNode type for representation using Hoopl graphs. module GHC.Cmm.Node ( @@ -33,6 +30,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Data.FastString +import GHC.Data.Pair import GHC.Types.ForeignCall import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout @@ -725,7 +723,7 @@ mapExpM _ (CmmComment _) = Nothing mapExpM _ (CmmTick _) = Nothing mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e -mapExpM f (CmmStore addr e align) = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, e] +mapExpM f (CmmStore addr e align) = (\ (Pair addr' e') -> CmmStore addr' e' align) `fmap` traverse f (Pair addr e) mapExpM _ (CmmBranch _) = Nothing mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index ccf542aff0..7e6c542c5e 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -2,8 +2,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Cmm.ProcPoint ( ProcPointSet, Status(..) , callProcPoints, minimalProcPointSet diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index d4da4dc51b..adb71e11a8 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -15,8 +15,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Native code generator -- -- The native-code generator has machine-independent and diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 38d447b491..61fc14e815 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -7,9 +7,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core ( -- * Main data types diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 9bc4297af2..31d01d3893 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index df2a5c31c9..b12478cbab 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -7,7 +7,6 @@ -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Arity and eta expansion module GHC.Core.Opt.Arity diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index f8a129de85..2f7718709a 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -4,11 +4,6 @@ \section{Common subexpression} -} - - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where import GHC.Prelude @@ -32,6 +27,7 @@ import GHC.Types.Tickish import GHC.Core.Map.Expr import GHC.Utils.Misc ( filterOut, equalLength ) import GHC.Utils.Panic +import Data.Functor.Identity ( Identity (..) ) import Data.List ( mapAccumL ) {- @@ -412,7 +408,7 @@ cseBind toplevel env (Rec [(in_id, rhs)]) = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) where - (env1, [out_id]) = addRecBinders env [in_id] + (env1, Identity out_id) = addRecBinders env (Identity in_id) rhs' = cseExpr env1 rhs rhs'' = stripTicksE tickishFloatable rhs' ticks = stripTicksT tickishFloatable rhs' @@ -916,7 +912,8 @@ addBinders cse vs = (cse { cs_subst = sub' }, vs') where (sub', vs') = substBndrs (cs_subst cse) vs -addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substRecBndrs (cs_subst cse) vs +addRecBinders :: Traversable f => CSEnv -> f Id -> (CSEnv, f Id) +addRecBinders = \ cse vs -> + let (sub', vs') = substRecBndrs (cs_subst cse) vs + in (cse { cs_subst = sub' }, vs') +{-# INLINE addRecBinders #-} diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 0f87a8aeb6..6f520cfcfd 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -6,8 +6,6 @@ {-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Core.Opt.Monad ( -- * Types used in core-to-core passes FloatOutSwitches(..), diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index f0e36f6fc9..f8ed00c119 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where import GHC.Prelude diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 4f87e5ad8e..3d52c655f6 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -6,8 +6,6 @@ Utility functions on @Core@ syntax -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Subst ( -- * Main data types Subst(..), -- Implementation exported for supercompiler's Renaming.hs only @@ -65,6 +63,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL) {- @@ -343,15 +342,18 @@ substBndr subst bndr | otherwise = substIdBndr (text "var-bndr") subst subst bndr -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right -substBndrs :: Subst -> [Var] -> (Subst, [Var]) -substBndrs subst bndrs = mapAccumL substBndr subst bndrs +substBndrs :: Traversable f => Subst -> f Var -> (Subst, f Var) +substBndrs = mapAccumL substBndr +{-# INLINE substBndrs #-} -- | Substitute in a mutually recursive group of 'Id's -substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +substRecBndrs :: Traversable f => Subst -> f Id -> (Subst, f Id) substRecBndrs subst bndrs = (new_subst, new_bndrs) where -- Here's the reason we need to pass rec_subst to subst_id (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs +{-# SPECIALIZE substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) #-} +{-# SPECIALIZE substRecBndrs :: Subst -> Identity Id -> (Subst, Identity Id) #-} substIdBndr :: SDoc -> Subst -- ^ Substitution to use for the IdInfo diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 1ca425fcf2..2a4c538ab1 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -8,7 +8,6 @@ The code for *top-level* bindings is in GHC.Iface.Tidy. -} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Tidy ( tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs ) where diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 115dd3531f..ebf87dae94 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -6,7 +6,6 @@ Type and Coercion - friends' interface {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index a1f6489374..bfd7e4c7cc 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Tidying types and coercions for printing in error messages. diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 70a707b17b..fdd5edbba2 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Main functions for manipulating types and type-related things module GHC.Core.Type ( diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 462a52ea45..53d8040c9c 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -5,7 +5,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index d296f2b0a6..8e48036673 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -16,9 +16,6 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Abstract syntax of global declarations. -- -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index b24531f790..48cf7c6955 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -14,7 +14,6 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {- diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index a761440fc7..4794f11075 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -2,8 +2,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 7d1eeb3268..21cab8439d 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -848,29 +846,52 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs , Just con <- isDataConId_maybe funId = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] - | Nothing <- mb_lhs_app - = Left (DsRuleLhsTooComplicated orig_lhs lhs2) - - | not (null unbound) -- Check for things unbound on LHS - -- See Note [Unused spec binders] - = -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs_fvs:" <+> ppr lhs_fvs - -- , text "rhs_fvs:" <+> ppr rhs_fvs - -- , text "unbound:" <+> ppr unbound - -- ]) $ - Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) - - | otherwise - = -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs1:" <+> ppr lhs1 - -- , text "extra_bndrs:" <+> ppr extra_bndrs - -- , text "fn_id:" <+> ppr fn_id - -- , text "args:" <+> ppr args - -- , text "args fvs:" <+> ppr (exprsFreeVarsList args) - -- ]) $ - Right (trimmed_bndrs ++ extra_bndrs, fn_id, args) + | otherwise = case decompose fun2 args2 of + Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2) + Just (fn_id, args) + | not (null unbound) -> + -- Check for things unbound on LHS + -- See Note [Unused spec binders] + -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs_fvs:" <+> ppr lhs_fvs + -- , text "rhs_fvs:" <+> ppr rhs_fvs + -- , text "unbound:" <+> ppr unbound + -- ]) $ + Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) + | otherwise -> + -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "extra_bndrs:" <+> ppr extra_bndrs + -- , text "fn_id:" <+> ppr fn_id + -- , text "args:" <+> ppr args + -- , text "args fvs:" <+> ppr (exprsFreeVarsList args) + -- ]) $ + Right (trimmed_bndrs ++ extra_bndrs, fn_id, args) + + where -- See Note [Variables unbound on the LHS] + lhs_fvs = exprsFreeVars args + all_fvs = lhs_fvs `unionVarSet` rhs_fvs + trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs + unbound = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs + -- Needed on RHS but not bound on LHS + + -- Add extra tyvar binders: Note [Free tyvars on rule LHS] + -- and extra dict binders: Note [Free dictionaries on rule LHS] + extra_bndrs = scopedSort extra_tvs ++ extra_dicts + where + extra_tvs = [ v | v <- extra_vars, isTyVar v ] + extra_dicts = + [ mkLocalId (localiseName (idName d)) ManyTy (idType d) + | d <- extra_vars, isDictId d ] + extra_vars = + [ v + | v <- exprsFreeVarsList args + , not (v `elemVarSet` orig_bndr_set) + , not (v == fn_id) ] + -- fn_id: do not quantify over the function itself, which may + -- itself be a dictionary (in pathological cases, #10251) where simpl_opts = initSimpleOpts dflags @@ -880,29 +901,6 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS] (fun2,args2) = collectArgs lhs2 - mb_lhs_app = decompose fun2 args2 - Just (fn_id, args) = mb_lhs_app - - -- See Note [Variables unbound on the LHS] - lhs_fvs = exprsFreeVars args - all_fvs = lhs_fvs `unionVarSet` rhs_fvs - trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs - unbound = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs - -- Needed on RHS but not bound on LHS - - -- Add extra tyvar binders: Note [Free tyvars on rule LHS] - -- and extra dict binders: Note [Free dictionaries on rule LHS] - extra_bndrs = scopedSort extra_tvs ++ extra_dicts - where - extra_tvs = [ v | v <- extra_vars, isTyVar v ] - extra_dicts = [ mkLocalId (localiseName (idName d)) ManyTy (idType d) - | d <- extra_vars, isDictId d ] - extra_vars = [ v | v <- exprsFreeVarsList args - , not (v `elemVarSet` orig_bndr_set) - , not (v == fn_id) ] - -- fn_id: do not quantify over the function itself, which may - -- itself be a dictionary (in pathological cases, #10251) - decompose (Var fn_id) args | not (fn_id `elemVarSet` orig_bndr_set) = Just (fn_id, args) @@ -1253,8 +1251,7 @@ dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr dsEvTypeable ty ev = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable ; let kind = typeKind ty - Just typeable_data_con - = tyConSingleDataCon_maybe tyCl -- "Data constructor" + typeable_data_con = tyConSingleDataCon tyCl -- "Data constructor" -- for Typeable ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 9f81f6b0b3..92ab68c5b8 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 8257fea3bb..89be7cca40 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998 diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index cc9d282356..0cf83d378c 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 9c3716fe97..a14b3959ea 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -1,7 +1,3 @@ - - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | This module implements interface renaming, which is -- used to rewrite interface files on the fly when we -- are doing indefinite typechecking and need instantiations diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 02ef74efef..e957c600e1 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -10,8 +10,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- -- (c) The University of Glasgow 2002-2006 -- diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 7f3edf841c..349fc770b6 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 4d22a994e9..ba39a2040c 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -77,7 +78,7 @@ import qualified GHC.LanguageExtensions as LangExt import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.List (unzip4, minimumBy) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import Data.Maybe (isJust, isNothing) import Control.Arrow (first) import Data.Ord @@ -1089,15 +1090,13 @@ rnStmtsWithFreeVars ctxt _ [] thing_inside ; (thing, fvs) <- thing_inside [] ; return (([], thing), fvs) } -rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside -- Deal with mdo +rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody (nonEmpty -> Just stmts) thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ -> - do { last_stmt' <- checkLastStmt mDoExpr last_stmt + <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA (NE.init stmts))) $ \ _ -> + do { last_stmt' <- checkLastStmt mDoExpr (NE.last stmts) ; rnStmt mDoExpr rnBody last_stmt' thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } - where - Just (all_but_last, last_stmt) = snocView stmts rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside | null lstmts diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 74058503ca..b0bb1cbd68 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -4,7 +4,6 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index da2d5b0d57..c4cb5d8d01 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -11,9 +11,6 @@ Extracting imported and top-level names in scope {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Rename.Names ( rnImports, getLocalNonValBinders, newRecordSelector, extendGlobalRdrEnvRn, @@ -919,8 +916,15 @@ getLocalNonValBinders fixity_env -- foreign decls and pattern synonyms for an ordinary module -- type sigs in case of a hs-boot file only ; is_boot <- tcIsHsBootOrSig - ; let val_bndrs | is_boot = hs_boot_sig_bndrs - | otherwise = for_hs_bndrs + ; let val_bndrs + | is_boot = case binds of + ValBinds _ _val_binds val_sigs -> + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + [ L (l2l decl_loc) (unLoc n) + | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] + _ -> panic "Non-ValBinds in hs-boot group" + | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs ; let avails = concat nti_availss ++ val_avails @@ -941,16 +945,9 @@ getLocalNonValBinders fixity_env ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) ; return (envs, new_bndrs) } } where - ValBinds _ _val_binds val_sigs = binds - for_hs_bndrs :: [LocatedN RdrName] for_hs_bndrs = hsForeignDeclsBinders foreign_decls - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders - hs_boot_sig_bndrs = [ L (l2l decl_loc) (unLoc n) - | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] - -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name new_simple :: LocatedN RdrName -> RnM AvailInfo diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 7d8b54fa95..c73b1edcad 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -7,9 +7,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -78,6 +75,8 @@ import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad ( when, ap, guard, unless ) +import Data.Foldable +import Data.Functor.Identity ( Identity (..) ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio @@ -405,9 +404,10 @@ There are various entry points to renaming patterns, depending on -- * local namemaker -- * unused and duplicate checking -- * no fixities -rnPats :: HsMatchContext GhcRn -- for error messages - -> [LPat GhcPs] - -> ([LPat GhcRn] -> RnM (a, FreeVars)) +rnPats :: Traversable f + => HsMatchContext GhcRn -- for error messages + -> f (LPat GhcPs) + -> (f (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnPats ctxt pats thing_inside = do { envs_before <- getRdrEnvs @@ -424,7 +424,7 @@ rnPats ctxt pats thing_inside -- complain *twice* about duplicates e.g. f (x,x) = ... -- -- See Note [Don't report shadowing for pattern synonyms] - ; let bndrs = collectPatsBinders CollNoDictBinders pats' + ; let bndrs = collectPatsBinders CollNoDictBinders (toList pats') ; addErrCtxt doc_pat $ if isPatSynCtxt ctxt then checkDupNames bndrs @@ -432,6 +432,8 @@ rnPats ctxt pats thing_inside ; thing_inside pats' } } where doc_pat = text "In" <+> pprMatchContext ctxt +{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-} +{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-} rnPat :: HsMatchContext GhcRn -- for error messages -> LPat GhcPs @@ -439,7 +441,7 @@ rnPat :: HsMatchContext GhcRn -- for error messages -> RnM (a, FreeVars) -- Variables bound by pattern do not -- appear in the result FreeVars rnPat ctxt pat thing_inside - = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') + = rnPats ctxt (Identity pat) (thing_inside . runIdentity) applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name) applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) @@ -471,7 +473,7 @@ rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) -- ----------- Entry point 3: rnLPatAndThen ------------------- -- General version: parameterized by how you make new names -rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] +rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn)) rnLPatsAndThen mk = mapM (rnLPatAndThen mk) -- Despite the map, the monad ensures that each pattern binds -- variables that may be mentioned in subsequent patterns in the list @@ -963,7 +965,7 @@ generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e})) , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val}) generalizeOverLitVal lit = lit -isNegativeZeroOverLit :: HsOverLit t -> Bool +isNegativeZeroOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> Bool isNegativeZeroOverLit lit = case ol_val lit of HsIntegral i -> 0 == il_value i && il_neg i @@ -985,7 +987,7 @@ in this case return not only literal itself but also negateName so that users can apply it explicitly. In this case it stays negative zero. #13211 -} -rnOverLit :: HsOverLit t -> +rnOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) rnOverLit origLit = do { opt_NumDecimals <- xoptM LangExt.NumDecimals diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 1d84d794ae..e657141358 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -1,8 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Rename.Splice ( rnTopSpliceDecls, diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index fcf6b21b7a..66d96b163b 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- This module contains miscellaneous functions related to renaming. diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 432c13fdf4..35eb37b17f 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 @@ -279,6 +277,7 @@ import GHC.Utils.Misc import GHC.Types.Var.Env import Data.Bifunctor (second) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM @@ -483,10 +482,9 @@ elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con = _ unariseExpr rho2 rhs -elimCase rho args bndr (MultiValAlt _) alts +elimCase rho args@(tag_arg : real_args) bndr (MultiValAlt _) alts | isUnboxedSumBndr bndr - = do let (tag_arg : real_args) = args - tag_bndr <- mkId (mkFastString "tag") tagTy + = do tag_bndr <- mkId (mkFastString "tag") tagTy -- this won't be used but we need a binder anyway let rho1 = extendRho rho bndr (MultiVal args) scrut' = case tag_arg of @@ -658,7 +656,7 @@ mkUbxSum -> [OutStgArg] -- Final tuple arguments mkUbxSum dc ty_args args0 = let - (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) + _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) -- drop tag slot tag = dataConTag dc diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index bcf0990b49..989121207d 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fprof-auto-top #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- -- (c) The University of Glasgow 2002-2006 diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 9e493dff3e..55132860d6 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -6,8 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.StgToCmm.Heap ( getVirtHp, setVirtHp, setRealHp, getHpRelOffset, @@ -612,10 +610,6 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do gc_id <- newBlockId let - Just alloc_lit = mb_alloc_lit - - bump_hp = cmmOffsetExprB platform hpExpr alloc_lit - -- Sp overflow if ((old + 0) - CmmHighStack < SpLim) -- At the beginning of a function old + 0 = Sp -- See Note [Single stack check] @@ -630,8 +624,6 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do -- HpLim points to the LAST WORD of valid allocation space. hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr] - alloc_n = mkAssign hpAllocReg alloc_lit - case mb_stk_hwm of Nothing -> return () Just stk_hwm -> tickyStackCheck @@ -646,12 +638,14 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id _otherwise -> return () - if isJust mb_alloc_lit - then do + case mb_alloc_lit of + Just alloc_lit -> do + let bump_hp = cmmOffsetExprB platform hpExpr alloc_lit + alloc_n = mkAssign hpAllocReg alloc_lit tickyHeapCheck emitAssign hpReg bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) - else + Nothing -> when (checkYield && not omit_yields) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index c2181e5c32..d4ee8abef2 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -2,8 +2,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Tc.Errors.Hole ( findValidHoleFits , tcCheckHoleFit diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index c44fb65a29..06158cace3 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -6,8 +6,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- % (c) The University of Glasgow 2006 diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 99b09487b1..5154d7c98a 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -9,8 +9,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- % (c) The University of Glasgow 2006 diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index 8db260182d..139bb3b6b8 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.Solver.Interact ( diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 63f8216633..12b6fcc69f 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Monadic definitions for the constraint solver module GHC.Tc.Solver.Monad ( diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs index 33b25f29a7..252e2aba52 100644 --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -2,8 +2,6 @@ {-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Tc.Solver.Rewrite( rewrite, rewriteArgsNom, rewriteType diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs index d7a46a7c61..4c52721638 100644 --- a/compiler/GHC/Tc/Solver/Types.hs +++ b/compiler/GHC/Tc/Solver/Types.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Utility types used within the constraint solver module GHC.Tc.Solver.Types ( -- Inert CDictCans diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 06a06a0fad..6fda868642 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -8,7 +8,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Typechecking instance declarations @@ -1284,7 +1283,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; self_dict <- newDict clas inst_tys ; let class_tc = classTyCon clas loc' = noAnnSrcSpan loc - [dict_constr] = tyConDataCons class_tc + dict_constr = tyConSingleDataCon class_tc dict_bind = mkVarBind self_dict (L loc' con_app_args) -- We don't produce a binding for the dict_constr; instead we @@ -1368,7 +1367,7 @@ addDFunPrags dfun_id sc_meth_ids ev_ids = mkTemplateLocalsNum 1 dfun_theta dfun_bndrs = dfun_tvs ++ ev_ids clas_tc = classTyCon clas - [dict_con] = tyConDataCons clas_tc + dict_con = tyConSingleDataCon clas_tc is_newtype = isNewTyCon clas_tc wrapId :: HsWrapper -> Id -> HsExpr GhcTc diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index fdc4e59f1e..4c691185aa 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index 572efd34d4..475437701c 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -3,8 +3,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | This module defines types and simple operations over constraints, as used -- in the type-checker and constraint solver. module GHC.Tc.Types.Constraint ( diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index ce16837805..6c7759db31 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -3,9 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. module GHC.Tc.Types.Origin ( diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index d5e8e182e9..abbee42526 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 2f61ff8777..2c34b15f6f 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -4,7 +4,6 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 5c1e13ab76..98b8e2ae76 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -3,8 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 61787d299f..f7e1ec938a 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -2,9 +2,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecursiveDo #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 5072b8eeff..15168ddd2f 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1734,15 +1734,12 @@ synonyms, by matching on TyConApp directly. -} checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () -checkValidInstance ctxt hs_type ty - | not is_tc_app - = failWithTc (TcRnNoClassInstHead tau) - - | isNothing mb_cls - = failWithTc (TcRnIllegalClassInst (tyConFlavour tc)) - - | otherwise - = do { setSrcSpanA head_loc $ +checkValidInstance ctxt hs_type ty = case tau of + -- See Note [Instances and constraint synonyms] + TyConApp tc inst_tys -> case tyConClass_maybe tc of + Nothing -> failWithTc (TcRnIllegalClassInst (tyConFlavour tc)) + Just clas -> do + { setSrcSpanA head_loc $ checkValidInstHead ctxt clas inst_tys ; traceTc "checkValidInstance {" (ppr ty) @@ -1775,12 +1772,9 @@ checkValidInstance ctxt hs_type ty ; traceTc "End checkValidInstance }" empty ; return () } + _ -> failWithTc (TcRnNoClassInstHead tau) where (_tvs, theta, tau) = tcSplitSigmaTy ty - is_tc_app = case tau of { TyConApp {} -> True; _ -> False } - TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] - mb_cls = tyConClass_maybe tc - Just clas = mb_cls -- The location of the "head" of the instance head_loc = getLoc (getLHsInstDeclHead hs_type) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 6642ce84b1..0a1fb615ec 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -9,7 +9,6 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- (c) The University of Glasgow 2006 @@ -28,7 +27,7 @@ module GHC.ThToHs ) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.Hs as Hs import GHC.Builtin.Names @@ -62,6 +61,7 @@ import Control.Applicative( (<|>) ) import Data.Bifunctor (first) import Data.Foldable (for_) import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) +import qualified Data.List.NonEmpty as NE import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -1224,11 +1224,12 @@ cvtOpApp x op y ------------------------------------- cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs) -cvtHsDo do_or_lc stmts - | null stmts = failWith EmptyStmtListInDoBlock - | otherwise - = do { stmts' <- cvtStmts stmts - ; let Just (stmts'', last') = snocView stmts' +cvtHsDo do_or_lc stmts = case nonEmpty stmts of + Nothing -> failWith EmptyStmtListInDoBlock + Just stmts -> do + { stmts' <- traverse cvtStmt stmts + ; let stmts'' = NE.init stmts' + last' = NE.last stmts' ; last'' <- case last' of (L loc (BodyStmt _ body _ _)) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 88baab297c..1ad6b608fc 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -20,8 +20,6 @@ types that {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Types.Basic ( LeftOrRight(..), pickLR, diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 9c394771cf..a5e39f5c63 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -56,6 +56,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List.NonEmpty (NonEmpty (..)) import Data.List (sort) import qualified Data.IntSet as IS @@ -203,14 +204,14 @@ type SortedSlotTys = [SlotTy] -- -- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head -- of the list we have the slot for the tag. -ubxSumRepType :: [[PrimRep]] -> [SlotTy] +ubxSumRepType :: [[PrimRep]] -> NonEmpty SlotTy ubxSumRepType constrs0 -- These first two cases never classify an actual unboxed sum, which always -- has at least two disjuncts. But it could happen if a user writes, e.g., -- forall (a :: TYPE (SumRep [IntRep])). ... -- which could never be instantiated. We still don't want to panic. | constrs0 `lengthLessThan` 2 - = [WordSlot] + = WordSlot :| [] | otherwise = let @@ -238,7 +239,7 @@ ubxSumRepType constrs0 rep :: [PrimRep] -> SortedSlotTys rep ty = sort (map primRepSlot ty) - sumRep = WordSlot : combine_alts (map rep constrs0) + sumRep = WordSlot :| combine_alts (map rep constrs0) -- WordSlot: for the tag of the sum in sumRep diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index 494ee70ccf..69ba5b0d22 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms, BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index da532279f7..0d5eabeb0b 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -7,8 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Highly random utility functions -- module GHC.Utils.Misc ( @@ -17,9 +15,7 @@ module GHC.Utils.Misc ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, - - zipWithLazy, zipWith3Lazy, + stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -262,25 +258,6 @@ zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) #endif --- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) -zipLazy :: [a] -> [b] -> [(a,b)] -zipLazy [] _ = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys - --- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. --- The length of the output is always the same as the length of the first --- list. -zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWithLazy _ [] _ = [] -zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs - --- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. --- The length of the output is always the same as the length of the first --- list. -zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] -zipWith3Lazy _ [] _ _ = [] -zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs - -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index 012304edf4..21a03c9c22 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -19,9 +19,6 @@ (c) The GRASP/@type@AQUA Project, Glasgow University, 1992-1998 -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* -- | Abstract syntax of global declarations. diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 5a22e35c74..ba818e82c5 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -10,8 +10,6 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 |