ghc-lib-parser 0.20210501 → 0.20210601
raw patch · 165 files changed
+4632/−3257 lines, 165 files
Files
- compiler/GHC/Builtin/Names.hs +0/−2
- compiler/GHC/Builtin/PrimOps.hs +0/−2
- compiler/GHC/Builtin/Types.hs +5/−7
- compiler/GHC/Builtin/Types/Prim.hs +0/−2
- compiler/GHC/Builtin/Uniques.hs +4/−6
- compiler/GHC/ByteCode/Types.hs +4/−9
- compiler/GHC/Cmm/CLabel.hs +8/−8
- compiler/GHC/Cmm/MachOp.hs +14/−5
- compiler/GHC/Core.hs +6/−7
- compiler/GHC/Core/Class.hs +5/−6
- compiler/GHC/Core/Coercion.hs +58/−60
- compiler/GHC/Core/Coercion/Axiom.hs +3/−5
- compiler/GHC/Core/Coercion/Opt.hs +54/−51
- compiler/GHC/Core/ConLike.hs +1/−3
- compiler/GHC/Core/DataCon.hs +43/−15
- compiler/GHC/Core/FVs.hs +5/−8
- compiler/GHC/Core/FamInstEnv.hs +7/−9
- compiler/GHC/Core/InstEnv.hs +9/−11
- compiler/GHC/Core/Lint.hs +36/−22
- compiler/GHC/Core/Make.hs +8/−9
- compiler/GHC/Core/Multiplicity.hs +3/−4
- compiler/GHC/Core/Opt/Arity.hs +16/−18
- compiler/GHC/Core/Opt/ConstantFold.hs +40/−23
- compiler/GHC/Core/Opt/Monad.hs +1/−1
- compiler/GHC/Core/Opt/OccurAnal.hs +10/−12
- compiler/GHC/Core/PatSyn.hs +5/−7
- compiler/GHC/Core/Rules.hs +5/−8
- compiler/GHC/Core/SimpleOpt.hs +11/−12
- compiler/GHC/Core/Subst.hs +14/−16
- compiler/GHC/Core/Tidy.hs +1/−3
- compiler/GHC/Core/TyCo/FVs.hs +4/−6
- compiler/GHC/Core/TyCo/Rep.hs +9/−9
- compiler/GHC/Core/TyCo/Subst.hs +38/−38
- compiler/GHC/Core/TyCo/Tidy.hs +1/−1
- compiler/GHC/Core/TyCon.hs +23/−18
- compiler/GHC/Core/TyCon/Env.hs +1/−3
- compiler/GHC/Core/TyCon/RecWalk.hs +1/−3
- compiler/GHC/Core/Type.hs +24/−25
- compiler/GHC/Core/Unfold.hs +1/−3
- compiler/GHC/Core/Unfold/Make.hs +3/−5
- compiler/GHC/Core/Unify.hs +4/−5
- compiler/GHC/Core/Utils.hs +22/−26
- compiler/GHC/CoreToIface.hs +8/−11
- compiler/GHC/Data/Bag.hs +1/−1
- compiler/GHC/Data/FastString.hs +3/−4
- compiler/GHC/Data/Graph/Directed.hs +1/−3
- compiler/GHC/Data/IOEnv.hs +1/−1
- compiler/GHC/Data/List/SetOps.hs +3/−5
- compiler/GHC/Data/Maybe.hs +1/−1
- compiler/GHC/Data/Pair.hs +1/−3
- compiler/GHC/Data/Strict.hs +67/−0
- compiler/GHC/Data/StringBuffer.hs +3/−6
- compiler/GHC/Driver/CmdLine.hs +3/−4
- compiler/GHC/Driver/Config.hs +2/−0
- compiler/GHC/Driver/Env.hs +55/−13
- compiler/GHC/Driver/Errors.hs +15/−9
- compiler/GHC/Driver/Errors/Ppr.hs +140/−8
- compiler/GHC/Driver/Errors/Types.hs +114/−20
- compiler/GHC/Driver/Flags.hs +273/−5
- compiler/GHC/Driver/Hooks.hs +1/−1
- compiler/GHC/Driver/Monad.hs +1/−1
- compiler/GHC/Driver/Phases.hs +1/−3
- compiler/GHC/Driver/Pipeline/Monad.hs +31/−7
- compiler/GHC/Driver/Plugins.hs +1/−1
- compiler/GHC/Driver/Ppr.hs +8/−11
- compiler/GHC/Driver/Ppr.hs-boot +1/−1
- compiler/GHC/Driver/Session.hs +183/−273
- compiler/GHC/Hs/Decls.hs +3/−4
- compiler/GHC/Hs/Doc.hs +1/−3
- compiler/GHC/Hs/Expr.hs +166/−98
- compiler/GHC/Hs/Extension.hs +5/−0
- compiler/GHC/Hs/Instances.hs +4/−4
- compiler/GHC/Hs/Lit.hs +0/−3
- compiler/GHC/Hs/Pat.hs +25/−28
- compiler/GHC/Hs/Type.hs +17/−14
- compiler/GHC/Hs/Utils.hs +22/−30
- compiler/GHC/HsToCore/Errors/Ppr.hs +1/−1
- compiler/GHC/Iface/Recomp/Binary.hs +2/−5
- compiler/GHC/Iface/Syntax.hs +20/−14
- compiler/GHC/Iface/Type.hs +11/−4
- compiler/GHC/Parser/Annotation.hs +124/−131
- compiler/GHC/Parser/CharClass.hs +1/−3
- compiler/GHC/Parser/Errors.hs +0/−433
- compiler/GHC/Parser/Errors/Ppr.hs +771/−638
- compiler/GHC/Parser/Errors/Types.hs +496/−3
- compiler/GHC/Parser/Header.hs +8/−12
- compiler/GHC/Parser/PostProcess.hs +224/−189
- compiler/GHC/Parser/PostProcess/Haddock.hs +17/−16
- compiler/GHC/Parser/Types.hs +5/−4
- compiler/GHC/Platform/Ways.hs +0/−2
- compiler/GHC/Runtime/Heap/Layout.hs +2/−1
- compiler/GHC/Runtime/Interpreter.hs +1/−1
- compiler/GHC/Settings.hs +1/−1
- compiler/GHC/Stg/Syntax.hs +3/−6
- compiler/GHC/StgToCmm/Types.hs +1/−3
- compiler/GHC/SysTools/BaseDir.hs +0/−2
- compiler/GHC/SysTools/Terminal.hs +1/−1
- compiler/GHC/Tc/Errors/Ppr.hs +68/−3
- compiler/GHC/Tc/Errors/Types.hs +70/−4
- compiler/GHC/Tc/Types.hs +51/−41
- compiler/GHC/Tc/Types/Constraint.hs +7/−9
- compiler/GHC/Tc/Types/Evidence.hs +5/−6
- compiler/GHC/Tc/Types/Origin.hs +5/−8
- compiler/GHC/Tc/Utils/TcType.hs +18/−19
- compiler/GHC/Types/Avail.hs +2/−3
- compiler/GHC/Types/Cpr.hs +3/−3
- compiler/GHC/Types/Demand.hs +1/−3
- compiler/GHC/Types/Error.hs +31/−12
- compiler/GHC/Types/Hint.hs +128/−0
- compiler/GHC/Types/Id.hs +21/−16
- compiler/GHC/Types/Id/Info.hs +5/−6
- compiler/GHC/Types/Id/Make.hs +11/−13
- compiler/GHC/Types/Literal.hs +13/−16
- compiler/GHC/Types/Name/Cache.hs +2/−5
- compiler/GHC/Types/Name/Env.hs +1/−3
- compiler/GHC/Types/Name/Occurrence.hs +0/−15
- compiler/GHC/Types/Name/Ppr.hs +2/−4
- compiler/GHC/Types/Name/Reader.hs +3/−4
- compiler/GHC/Types/Name/Set.hs +1/−3
- compiler/GHC/Types/RepType.hs +4/−5
- compiler/GHC/Types/SrcLoc.hs +13/−12
- compiler/GHC/Types/TyThing.hs +2/−2
- compiler/GHC/Types/Unique.hs +4/−5
- compiler/GHC/Types/Unique/FM.hs +19/−6
- compiler/GHC/Types/Unique/Supply.hs +1/−5
- compiler/GHC/Types/Var.hs +6/−13
- compiler/GHC/Types/Var/Set.hs +1/−3
- compiler/GHC/Unit/Info.hs +1/−3
- compiler/GHC/Unit/Module/Deps.hs +116/−19
- compiler/GHC/Unit/Module/ModIface.hs +1/−1
- compiler/GHC/Unit/Module/Status.hs +13/−11
- compiler/GHC/Unit/State.hs +1/−3
- compiler/GHC/Unit/Types.hs +1/−1
- compiler/GHC/Utils/Binary.hs +11/−2
- compiler/GHC/Utils/Binary/Typeable.hs +0/−2
- compiler/GHC/Utils/Constants.hs +51/−0
- compiler/GHC/Utils/Error.hs +3/−4
- compiler/GHC/Utils/Exception.hs +1/−1
- compiler/GHC/Utils/Fingerprint.hs +1/−3
- compiler/GHC/Utils/GlobalVars.hs +30/−5
- compiler/GHC/Utils/IO/Unsafe.hs +1/−3
- compiler/GHC/Utils/Logger.hs +8/−6
- compiler/GHC/Utils/Misc.hs +4/−53
- compiler/GHC/Utils/Panic.hs +24/−4
- compiler/GHC/Utils/Panic/Plain.hs +29/−5
- compiler/GhclibHsVersions.h +0/−56
- compiler/Language/Haskell/Syntax/Binds.hs +2/−1
- compiler/Language/Haskell/Syntax/Decls.hs +1/−1
- compiler/Language/Haskell/Syntax/Expr.hs +99/−45
- compiler/Language/Haskell/Syntax/Extension.hs +36/−24
- compiler/Language/Haskell/Syntax/Lit.hs +2/−4
- compiler/Language/Haskell/Syntax/Pat.hs +26/−24
- compiler/Language/Haskell/Syntax/Type.hs +32/−28
- ghc-lib-parser.cabal +4/−3
- ghc-lib/stage0/compiler/build/GHC/Parser.hs +76/−58
- ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs +124/−92
- ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs +2/−1
- ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +0/−1
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +1/−1
- ghc-lib/stage0/lib/ghcautoconf.h +3/−0
- ghc-lib/stage0/lib/llvm-targets +1/−0
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- libraries/ghci/GHCi/Message.hs +1/−1
- libraries/template-haskell/Language/Haskell/TH.hs +1/−0
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs +66/−1
compiler/GHC/Builtin/Names.hs view
@@ -133,8 +133,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Unit.Types
compiler/GHC/Builtin/PrimOps.hs view
@@ -24,8 +24,6 @@ PrimCall(..) ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Builtin.Types.Prim
compiler/GHC/Builtin/Types.hs view
@@ -4,7 +4,6 @@ Wired-in knowledge about {\em non-primitive} types -} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -157,8 +156,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )@@ -196,6 +193,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import qualified Data.ByteString.Char8 as BS @@ -719,7 +717,7 @@ mkWiredInName modu wrk_occ wrk_key (AnId (dataConWorkId data_con)) UserSyntax where- modu = ASSERT( isExternalName dc_name )+ modu = assert (isExternalName dc_name) $ nameModule dc_name dc_name = dataConName data_con dc_occ = nameOccName dc_name@@ -993,7 +991,7 @@ isCTupleTyConName :: Name -> Bool isCTupleTyConName n- = ASSERT2( isExternalName n, ppr n )+ = assertPpr (isExternalName n) (ppr n) $ getUnique n `elementOfUniqSet` cTupleTyConKeys -- | If the given name is that of a constraint tuple, return its arity.@@ -2062,11 +2060,11 @@ where go list_ty | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty- = ASSERT( tc `hasKey` consDataConKey )+ = assert (tc `hasKey` consDataConKey) $ t : go ts | Just (tc, [_k]) <- splitTyConApp_maybe list_ty- = ASSERT( tc `hasKey` nilDataConKey )+ = assert (tc `hasKey` nilDataConKey) [] | otherwise
compiler/GHC/Builtin/Types/Prim.hs view
@@ -94,8 +94,6 @@ #include "primop-vector-tys-exports.hs-incl" ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types
compiler/GHC/Builtin/Uniques.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | This is where we define a mapping from Uniques to their associated -- known-key Names for things associated with tuples and sums. We use this -- mapping while deserializing known-key Names in interface file symbol tables,@@ -51,8 +51,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types@@ -65,8 +63,8 @@ import GHC.Data.FastString import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.Maybe @@ -113,8 +111,8 @@ mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity =- ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the- -- alternative+ assert (arity < 0x3f) $ -- 0x3f since we only have 6 bits to encode the+ -- alternative mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) mkSumDataConUnique :: ConTagZ -> Arity -> Unique
compiler/GHC/ByteCode/Types.hs view
@@ -43,6 +43,7 @@ import Data.Maybe (catMaybes) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS+import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) -- ----------------------------------------------------------------------------- -- Compiled Byte Code@@ -106,10 +107,7 @@ -} data TupleInfo = TupleInfo { tupleSize :: !WordOff -- total size of tuple in words- , tupleVanillaRegs :: !RegBitmap -- vanilla registers used- , tupleLongRegs :: !RegBitmap -- long registers used- , tupleFloatRegs :: !RegBitmap -- float registers used- , tupleDoubleRegs :: !RegBitmap -- double registers used+ , tupleRegs :: !GlobalRegSet , tupleNativeStackSize :: !WordOff {- words spilled on the stack by GHCs native calling convention -} } deriving (Show)@@ -118,14 +116,11 @@ ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+> text "stack" <+> ppr tupleNativeStackSize <+> text "regs" <+>- char 'R' <> ppr tupleVanillaRegs <+>- char 'L' <> ppr tupleLongRegs <+>- char 'F' <> ppr tupleFloatRegs <+>- char 'D' <> ppr tupleDoubleRegs <>+ ppr (map (text.show) $ regSetToList tupleRegs) <> char '>' voidTupleInfo :: TupleInfo-voidTupleInfo = TupleInfo 0 0 0 0 0 0+voidTupleInfo = TupleInfo 0 emptyRegSet 0 type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which
compiler/GHC/Cmm/CLabel.hs view
@@ -6,7 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}@@ -132,8 +131,6 @@ foreignLabelStdcallInfo ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Types.Id.Info@@ -146,6 +143,7 @@ import GHC.Types.CostCentre import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Driver.Session import GHC.Platform@@ -330,6 +328,8 @@ compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = compare a1 a2 `thenCmp` compare b1 b2 `thenCmp`+ -- This non-determinism is "safe" in the sense that it only affects object code,+ -- which is currently not covered by GHC's determinism guarantees. See #12935. uniqCompareFS c1 c2 `thenCmp` compare d1 d2 compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2@@ -342,7 +342,7 @@ compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = compare a1 a2 `thenCmp`- uniqCompareFS b1 b2+ lexicalCompareFS b1 b2 compare (StringLitLabel u1) (StringLitLabel u2) = nonDetCmpUnique u1 u2 compare (CC_Label a1) (CC_Label a2) =@@ -664,22 +664,22 @@ mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel mkSelectorInfoLabel platform upd offset =- ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))+ assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $ RtsLabel (RtsSelectorInfoTable upd offset) mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel mkSelectorEntryLabel platform upd offset =- ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))+ assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $ RtsLabel (RtsSelectorEntry upd offset) mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel mkApInfoTableLabel platform upd arity =- ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))+ assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $ RtsLabel (RtsApInfoTable upd arity) mkApEntryLabel :: Platform -> Bool -> Int -> CLabel mkApEntryLabel platform upd arity =- ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))+ assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $ RtsLabel (RtsApEntry upd arity)
compiler/GHC/Cmm/MachOp.hs view
@@ -638,6 +638,12 @@ -- Should be an AtomicRMW variant eventually. -- Sequential consistent. | MO_Xchg Width++ -- These rts provided functions are special: suspendThread releases the+ -- capability, hence we mustn't sink any use of data stored in the capability+ -- after this instruction.+ | MO_SuspendThread+ | MO_ResumeThread deriving (Eq, Show) -- | The operation to perform atomically.@@ -653,13 +659,16 @@ pprCallishMachOp :: CallishMachOp -> SDoc pprCallishMachOp mo = text (show mo) +-- | Return (results_hints,args_hints) callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint]) callishMachOpHints op = case op of- MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint])- MO_Memset _ -> ([], [AddrHint,NoHint,NoHint])- MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])- MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint])- _ -> ([],[])+ MO_Memcpy _ -> ([], [AddrHint,AddrHint,NoHint])+ MO_Memset _ -> ([], [AddrHint,NoHint,NoHint])+ MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])+ MO_Memcmp _ -> ([], [AddrHint, AddrHint, NoHint])+ MO_SuspendThread -> ([AddrHint], [AddrHint,NoHint])+ MO_ResumeThread -> ([AddrHint], [AddrHint])+ _ -> ([],[]) -- empty lists indicate NoHint -- | The alignment of a 'memcpy'-ish operation.
compiler/GHC/Core.hs view
@@ -3,7 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} @@ -92,8 +92,6 @@ isBuiltinRule, isLocalRule, isAutoRule, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -115,6 +113,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Driver.Ppr @@ -300,7 +299,7 @@ -- The instance adheres to the order described in [Core case invariants] instance Ord AltCon where compare (DataAlt con1) (DataAlt con2) =- ASSERT( dataConTyCon con1 == dataConTyCon con2 )+ assert (dataConTyCon con1 == dataConTyCon con2) $ compare (dataConTag con1) (dataConTag con2) compare (DataAlt _) _ = GT compare _ (DataAlt _) = LT@@ -1575,8 +1574,8 @@ cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 cmpAltCon (LitAlt _) DEFAULT = GT -cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>- ppr con1 <+> ppr con2 )+cmpAltCon con1 con2 = warnPprTrace True (text "Comparing incomparable AltCons" <+>+ ppr con1 <+> ppr con2) $ LT {-@@ -1803,7 +1802,7 @@ varToCoreExpr :: CoreBndr -> Expr b varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) | isCoVar v = Coercion (mkCoVarCo v)- | otherwise = ASSERT( isId v ) Var v+ | otherwise = assert (isId v) $ Var v varsToCoreExprs :: [CoreBndr] -> [Expr b] varsToCoreExprs vs = map varToCoreExpr vs
compiler/GHC/Core/Class.hs view
@@ -3,8 +3,8 @@ -- -- The @Class@ datatype -{-# LANGUAGE CPP #-} + module GHC.Core.Class ( Class, ClassOpItem,@@ -21,8 +21,6 @@ isAbstractClass, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )@@ -34,6 +32,7 @@ import GHC.Types.Unique import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)@@ -254,20 +253,20 @@ -- Both superclass-dictionary and method selectors classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) = sc_sels ++ classMethods c-classAllSelIds c = ASSERT( null (classMethods c) ) []+classAllSelIds c = assert (null (classMethods c) ) [] classSCSelIds :: Class -> [Id] -- Both superclass-dictionary and method selectors classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) = sc_sels-classSCSelIds c = ASSERT( null (classMethods c) ) []+classSCSelIds c = assert (null (classMethods c) ) [] classSCSelId :: Class -> Int -> Id -- Get the n'th superclass selector Id -- where n is 0-indexed, and counts -- *all* superclasses including equalities classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n- = ASSERT( n >= 0 && lengthExceeds sc_sels n )+ = assert (n >= 0 && lengthExceeds sc_sels n ) sc_sels !! n classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
compiler/GHC/Core/Coercion.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -127,8 +126,6 @@ HoleSet, coercionHolesOfType, coercionHolesOfCo ) where -#include "GhclibHsVersions.h"- import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) import GHC.Prelude@@ -162,6 +159,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Monad (foldM, zipWithM) import Data.Function ( on )@@ -404,7 +402,7 @@ -- Expects co :: (s1 -> t1) ~ (s2 -> t2) -- Returns (co1 :: s1~s2, co2 :: t1~t2) -- See Note [Function coercions] for the "3" and "4"-decomposeFunCo r co = ASSERT2( all_ok, ppr co )+decomposeFunCo r co = assertPpr all_ok (ppr co) (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co) where Pair s1t1 s2t2 = coercionKind co@@ -584,7 +582,7 @@ coVarKind :: CoVar -> Type coVarKind cv- = ASSERT( isCoVar cv )+ = assert (isCoVar cv ) varType cv coVarRole :: CoVar -> Role@@ -860,8 +858,8 @@ -- See Note [Unused coercion variable in ForAllCo] mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo v kind_co co- | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True- , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True+ | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True+ , assert (isTyVar v || almostDevoidCoVarOfCo v co) True , Just (ty, r) <- isReflCo_maybe co , isGReflCo kind_co = mkReflCo r (mkTyCoInvForAllTy v ty)@@ -873,9 +871,9 @@ -- The kind of the tycovar should be the left-hand kind of the kind coercion. mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo_NoRefl v kind_co co- | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True- , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True- , ASSERT( not (isReflCo co)) True+ | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True+ , assert (isTyVar v || almostDevoidCoVarOfCo v co) True+ , assert (not (isReflCo co)) True , isCoVar v , not (v `elemVarSet` tyCoVarsOfCo co) = FunCo (coercionRole co) (multToCo Many) kind_co co@@ -907,7 +905,7 @@ -- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion mkHomoForAllCos_NoRefl vs orig_co- = ASSERT( not (isReflCo orig_co))+ = assert (not (isReflCo orig_co)) foldr go orig_co vs where go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co@@ -942,7 +940,7 @@ mkAxInstCo role ax index tys cos | arity == n_tys = downgradeRole role ax_role $ mkAxiomInstCo ax_br index (rtys `chkAppend` cos)- | otherwise = ASSERT( arity < n_tys )+ | otherwise = assert (arity < n_tys) $ downgradeRole role ax_role $ mkAppCos (mkAxiomInstCo ax_br index (ax_args `chkAppend` cos))@@ -962,7 +960,7 @@ -- worker function mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkAxiomInstCo ax index args- = ASSERT( args `lengthIs` coAxiomArity ax index )+ = assert (args `lengthIs` coAxiomArity ax index) $ AxiomInstCo ax index args -- to be used only with unbranched axioms@@ -977,7 +975,7 @@ -- A companion to mkAxInstCo: -- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) mkAxInstRHS ax index tys cos- = ASSERT( tvs `equalLength` tys1 )+ = assert (tvs `equalLength` tys1) $ mkAppTys rhs' tys2 where branch = coAxiomNthBranch ax index@@ -995,7 +993,7 @@ -- at the types given. mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type mkAxInstLHS ax index tys cos- = ASSERT( tvs `equalLength` tys1 )+ = assert (tvs `equalLength` tys1) $ mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) where branch = coAxiomNthBranch ax index@@ -1052,7 +1050,7 @@ -> Coercion -> Coercion mkNthCo r n co- = ASSERT2( good_call, bad_call_msg )+ = assertPpr good_call bad_call_msg $ go r n co where Pair ty1 ty2 = coercionKind co@@ -1061,14 +1059,14 @@ | Just (ty, _) <- isReflCo_maybe co , Just (tv, _) <- splitForAllTyCoVar_maybe ty = -- works for both tyvar and covar- ASSERT( r == Nominal )+ assert (r == Nominal) $ mkNomReflCo (varType tv) go r n co | Just (ty, r0) <- isReflCo_maybe co , let tc = tyConAppTyCon ty- = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )- ASSERT( nthRole r0 tc n == r )+ = assertPpr (ok_tc_app ty n) (ppr n $$ ppr ty) $+ assert (nthRole r0 tc n == r) $ mkReflCo r (tyConAppArgN n ty) where ok_tc_app :: Type -> Int -> Bool ok_tc_app ty n@@ -1080,7 +1078,7 @@ = False go r 0 (ForAllCo _ kind_co _)- = ASSERT( r == Nominal )+ = assert (r == Nominal) kind_co -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) -- then (nth 0 co :: k1 ~N k2)@@ -1090,12 +1088,12 @@ go _ n (FunCo _ w arg res) = mkNthCoFunCo n w arg res - go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n- , (vcat [ ppr tc- , ppr arg_cos- , ppr r0- , ppr n- , ppr r ]) )+ go r n (TyConAppCo r0 tc arg_cos) = assertPpr (r == nthRole r0 tc n)+ (vcat [ ppr tc+ , ppr arg_cos+ , ppr r0+ , ppr n+ , ppr r ]) $ arg_cos `getNth` n go r n co =@@ -1260,7 +1258,7 @@ = FunCo Representational w (downgradeRole Representational Nominal arg) (downgradeRole Representational Nominal res)-mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) )+mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $ SubCo co -- | Changes a role, but only a downgrade. See Note [Role twiddling functions]@@ -1352,7 +1350,7 @@ | case prov of PhantomProv _ -> False -- should always be phantom ProofIrrelProv _ -> True -- it's always safe PluginProv _ -> False -- who knows? This choice is conservative.- CorePrepProv -> True+ CorePrepProv _ -> True = Just $ UnivCo prov Nominal co1 co2 setNominalRole_maybe_helper _ = Nothing @@ -1414,13 +1412,13 @@ _ | ki1 `eqType` ki2 -> mkNomReflCo (typeKind ty1) -- no later branch should return refl- -- The ASSERT( False )s throughout+ -- The assert (False )s throughout -- are these cases explicitly, but they should never fire. - Refl _ -> ASSERT( False )+ Refl _ -> assert False $ mkNomReflCo ki1 - GRefl _ _ MRefl -> ASSERT( False )+ GRefl _ _ MRefl -> assert False $ mkNomReflCo ki1 GRefl _ _ (MCo co) -> co@@ -1443,12 +1441,12 @@ -> promoteCoercion g ForAllCo _ _ _- -> ASSERT( False )+ -> assert False $ mkNomReflCo liftedTypeKind -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep FunCo _ _ _ _- -> ASSERT( False )+ -> assert False $ mkNomReflCo liftedTypeKind CoVarCo {} -> mkKindCo co@@ -1456,10 +1454,10 @@ AxiomInstCo {} -> mkKindCo co AxiomRuleCo {} -> mkKindCo co - UnivCo (PhantomProv kco) _ _ _ -> kco+ UnivCo (PhantomProv kco) _ _ _ -> kco UnivCo (ProofIrrelProv kco) _ _ _ -> kco- UnivCo (PluginProv _) _ _ _ -> mkKindCo co- UnivCo CorePrepProv _ _ _ -> mkKindCo co+ UnivCo (PluginProv _) _ _ _ -> mkKindCo co+ UnivCo (CorePrepProv _) _ _ _ -> mkKindCo co SymCo g -> mkSymCo (promoteCoercion g)@@ -1474,7 +1472,7 @@ | Just _ <- splitForAllCo_maybe co , n == 0- -> ASSERT( False ) mkNomReflCo liftedTypeKind+ -> assert False $ mkNomReflCo liftedTypeKind | otherwise -> mkKindCo co@@ -1490,15 +1488,15 @@ InstCo g _ | isForAllTy_ty ty1- -> ASSERT( isForAllTy_ty ty2 )+ -> assert (isForAllTy_ty ty2) $ promoteCoercion g | otherwise- -> ASSERT( False)+ -> assert False $ mkNomReflCo liftedTypeKind -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep KindCo _- -> ASSERT( False )+ -> assert False $ mkNomReflCo liftedTypeKind SubCo g@@ -1565,7 +1563,7 @@ -> CoercionN -> Coercion castCoercionKind1 g r t1 t2 h = case g of- Refl {} -> ASSERT( r == Nominal ) -- Refl is always Nominal+ Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal mkNomReflCo (mkCastTy t2 h) GRefl _ _ mco -> case mco of MRefl -> mkReflCo r (mkCastTy t2 h)@@ -1600,7 +1598,7 @@ mkFamilyTyConAppCo tc cos | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc , let tvs = tyConTyVars tc- fam_cos = ASSERT2( tvs `equalLength` cos, ppr tc <+> ppr cos )+ fam_cos = assertPpr (tvs `equalLength` cos) (ppr tc <+> ppr cos) $ map (liftCoSubstWith Nominal tvs cos) fam_tys = mkTyConAppCo Nominal fam_tc fam_cos | otherwise@@ -1615,7 +1613,7 @@ -- are quantified over the same variable. mkPiCo :: Role -> Var -> Coercion -> Coercion mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co- | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) )+ | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $ -- We didn't call mkForAllCo here because if v does not appear -- in co, the argement coercion will be nominal. But here we -- want it to be r. It is only called in 'mkPiCos', which is@@ -1979,7 +1977,7 @@ -- lift_s1 :: s1 ~r s1' -- lift_s2 :: s2 ~r s2' -- kco :: (s1 ~r s2) ~N (s1' ~r s2')- ASSERT( isCoVar v )+ assert (isCoVar v) $ let (_, _, s1, s2, r) = coVarKindsTypesRole v lift_s1 = ty_co_subst lc r s1 lift_s2 = ty_co_subst lc r s2@@ -2040,7 +2038,7 @@ -- fall into it. then mkForAllCo v' h body_co else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)- go r ty@(LitTy {}) = ASSERT( r == Nominal )+ go r ty@(LitTy {}) = assert (r == Nominal) $ mkNomReflCo ty go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co) (substRightCo lc co)@@ -2135,7 +2133,7 @@ -> LiftingContext -> TyVar -> (LiftingContext, TyVar, CoercionN, a) liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var- = ASSERT( isTyVar old_var )+ = assert (isTyVar old_var) $ ( LC (subst `extendTCvInScope` new_var) new_cenv , new_var, eta, stuff ) where@@ -2153,7 +2151,7 @@ -> LiftingContext -> CoVar -> (LiftingContext, CoVar, CoercionN, a) liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var- = ASSERT( isCoVar old_var )+ = assert (isCoVar old_var) $ ( LC (subst `extendTCvInScope` new_var) new_cenv , new_var, kind_co, stuff ) where@@ -2283,7 +2281,7 @@ seqProv (PhantomProv co) = seqCo co seqProv (ProofIrrelProv co) = seqCo co seqProv (PluginProv _) = ()-seqProv CorePrepProv = ()+seqProv (CorePrepProv _) = () seqCos :: [Coercion] -> () seqCos [] = ()@@ -2348,7 +2346,7 @@ , cab_lhs = lhs } <- coAxiomNthBranch ax ind , let (tys1, cotys1) = splitAtList tvs tys cos1 = map stripCoercionTy cotys1- = ASSERT( tys `equalLength` (tvs ++ cvs) )+ = assert (tys `equalLength` (tvs ++ cvs)) $ -- Invariant of AxiomInstCo: cos should -- exactly saturate the axiom branch substTyWith tvs tys1 $@@ -2364,7 +2362,7 @@ go_nth :: Int -> Type -> Type go_nth d ty | Just args <- tyConAppArgs_maybe ty- = ASSERT( args `lengthExceeds` d )+ = assert (args `lengthExceeds` d) $ args `getNth` d | d == 0@@ -2410,7 +2408,7 @@ , cab_rhs = rhs } <- coAxiomNthBranch ax ind , let (tys2, cotys2) = splitAtList tvs tys cos2 = map stripCoercionTy cotys2- = ASSERT( tys `equalLength` (tvs ++ cvs) )+ = assert (tys `equalLength` (tvs ++ cvs)) $ -- Invariant of AxiomInstCo: cos should -- exactly saturate the axiom branch substTyWith tvs tys2 $@@ -2589,9 +2587,9 @@ in mkCoherenceRightCo r ty2 co co' go ty1@(TyVarTy tv1) _tyvarty- = ASSERT( case _tyvarty of+ = assert (case _tyvarty of { TyVarTy tv2 -> tv1 == tv2- ; _ -> False } )+ ; _ -> False }) $ mkNomReflCo ty1 go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 })@@ -2599,7 +2597,7 @@ = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2) go (TyConApp tc1 args1) (TyConApp tc2 args2)- = ASSERT( tc1 == tc2 )+ = assert (tc1 == tc2) $ mkTyConAppCo Nominal tc1 (zipWith go args1 args2) go (AppTy ty1a ty1b) ty2@@ -2612,7 +2610,7 @@ go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) | isTyVar tv1- = ASSERT( isTyVar tv2 )+ = assert (isTyVar tv2) $ mkForAllCo tv1 kind_co (go ty1 ty2') where kind_co = go (tyVarKind tv1) (tyVarKind tv2) in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co@@ -2621,7 +2619,7 @@ ty2 go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)- = ASSERT( isCoVar cv1 && isCoVar cv2 )+ = assert (isCoVar cv1 && isCoVar cv2) $ mkForAllCo cv1 kind_co (go ty1 ty2') where s1 = varType cv1 s2 = varType cv2@@ -2646,9 +2644,9 @@ ty2 go ty1@(LitTy lit1) _lit2- = ASSERT( case _lit2 of+ = assert (case _lit2 of { LitTy lit2 -> lit1 == lit2- ; _ -> False } )+ ; _ -> False }) $ mkNomReflCo ty1 go (CoercionTy co1) (CoercionTy co2)@@ -3019,8 +3017,8 @@ co1_kind = coercionKind co1 unrewritten_tys = map (coercionRKind . snd) args (arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys- casted_args = ASSERT2( equalLength args arg_cos- , ppr args $$ ppr arg_cos )+ casted_args = assertPpr (equalLength args arg_cos)+ (ppr args $$ ppr arg_cos) [ (casted_xi, casted_co) | ((xi, co), arg_co, role) <- zip3 args arg_cos roles , let casted_xi = xi `mkCastTy` arg_co
compiler/GHC/Core/Coercion/Axiom.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}@@ -47,6 +46,7 @@ import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable )@@ -55,8 +55,6 @@ import Data.Array import Data.List ( mapAccumL ) -#include "GhclibHsVersions.h"- {- Note [Coercion axiom branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -143,7 +141,7 @@ type role Branches nominal manyBranches :: [CoAxBranch] -> Branches Branched-manyBranches brs = ASSERT( snd bnds >= fst bnds )+manyBranches brs = assert (snd bnds >= fst bnds ) MkBranches (listArray bnds brs) where bnds = (0, length brs - 1)@@ -155,7 +153,7 @@ toBranched = MkBranches . unMkBranches toUnbranched :: Branches br -> Branches Unbranched-toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) )+toUnbranched (MkBranches arr) = assert (bounds arr == (0,0) ) MkBranches arr fromBranches :: Branches br -> [CoAxBranch]
compiler/GHC/Core/Coercion/Opt.hs view
@@ -9,8 +9,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Ppr@@ -30,8 +28,10 @@ import Control.Monad ( zipWithM ) import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain {- %************************************************************************@@ -130,18 +130,18 @@ (Pair in_ty1 in_ty2, in_role) = coercionKindRole co (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co in- ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&- substTyUnchecked env in_ty2 `eqType` out_ty2 &&- in_role == out_role- , text "optCoercion changed types!"- $$ hang (text "in_co:") 2 (ppr co)- $$ hang (text "in_ty1:") 2 (ppr in_ty1)- $$ hang (text "in_ty2:") 2 (ppr in_ty2)- $$ hang (text "out_co:") 2 (ppr out_co)- $$ hang (text "out_ty1:") 2 (ppr out_ty1)- $$ hang (text "out_ty2:") 2 (ppr out_ty2)- $$ hang (text "subst:") 2 (ppr env) )- out_co+ assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 &&+ substTyUnchecked env in_ty2 `eqType` out_ty2 &&+ in_role == out_role)+ ( text "optCoercion changed types!"+ $$ hang (text "in_co:") 2 (ppr co)+ $$ hang (text "in_ty1:") 2 (ppr in_ty1)+ $$ hang (text "in_ty2:") 2 (ppr in_ty2)+ $$ hang (text "out_co:") 2 (ppr out_co)+ $$ hang (text "out_ty1:") 2 (ppr out_ty1)+ $$ hang (text "out_ty2:") 2 (ppr out_ty2)+ $$ hang (text "subst:") 2 (ppr env))+ out_co | otherwise = opt_co1 lc False co where@@ -197,28 +197,31 @@ , text "Rep:" <+> ppr rep , text "Role:" <+> ppr r , text "Co:" <+> ppr co ]) $- ASSERT( r == coercionRole co )+ assert (r == coercionRole co ) let result = opt_co4 env sym rep r co in pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ result -} opt_co4 env _ rep r (Refl ty)- = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$- text "Found role:" <+> ppr Nominal $$- text "Type:" <+> ppr ty )+ = assertPpr (r == Nominal)+ (text "Expected role:" <+> ppr r $$+ text "Found role:" <+> ppr Nominal $$+ text "Type:" <+> ppr ty) $ liftCoSubst (chooseRole rep r) env ty opt_co4 env _ rep r (GRefl _r ty MRefl)- = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$- text "Found role:" <+> ppr _r $$- text "Type:" <+> ppr ty )+ = assertPpr (r == _r)+ (text "Expected role:" <+> ppr r $$+ text "Found role:" <+> ppr _r $$+ text "Type:" <+> ppr ty) $ liftCoSubst (chooseRole rep r) env ty opt_co4 env sym rep r (GRefl _r ty (MCo co))- = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$- text "Found role:" <+> ppr _r $$- text "Type:" <+> ppr ty )+ = assertPpr (r == _r)+ (text "Expected role:" <+> ppr r $$+ text "Found role:" <+> ppr _r $$+ text "Type:" <+> ppr ty) $ if isGReflCo co || isGReflCo co' then liftCoSubst r' env ty else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)@@ -234,7 +237,7 @@ -- exchange them. opt_co4 env sym rep r g@(TyConAppCo _r tc cos)- = ASSERT( r == _r )+ = assert (r == _r) $ case (rep, r) of (True, Nominal) -> mkTyConAppCo Representational tc@@ -263,7 +266,7 @@ -- Use the "mk" functions to check for nested Refls opt_co4 env sym rep r (FunCo _r cow co1 co2)- = ASSERT( r == _r )+ = assert (r == _r) $ if rep then mkFunCo Representational cow' co1' co2' else mkFunCo r cow' co1' co2'@@ -280,7 +283,7 @@ = mkReflCo (chooseRole rep r) ty1 | otherwise- = ASSERT( isCoVar cv1 )+ = assert (isCoVar cv1 ) wrapRole rep r $ wrapSym sym $ CoVarCo cv1 @@ -289,9 +292,9 @@ cv1 = case lookupInScope (lcInScopeSet env) cv of Just cv1 -> cv1- Nothing -> WARN( True, text "opt_co: not in scope:"- <+> ppr cv $$ ppr env)- cv+ Nothing -> warnPprTrace True+ (text "opt_co: not in scope:" <+> ppr cv $$ ppr env)+ cv -- cv1 might have a substituted kind! opt_co4 _ _ _ _ (HoleCo h)@@ -302,7 +305,7 @@ -- e.g. if g is a top-level axiom -- g a : f a ~ a -- then (sym (g ty)) /= g (sym ty) !!- = ASSERT( r == coAxiomRole con )+ = assert (r == coAxiomRole con ) wrapRole rep (coAxiomRole con) $ wrapSym sym $ -- some sub-cos might be P: use opt_co2@@ -313,7 +316,7 @@ -- Note that the_co does *not* have sym pushed into it opt_co4 env sym rep r (UnivCo prov _r t1 t2)- = ASSERT( r == _r )+ = assert (r == _r ) opt_univ env sym prov (chooseRole rep r) t1 t2 opt_co4 env sym rep r (TransCo co1 co2)@@ -327,7 +330,7 @@ opt_co4 env _sym rep r (NthCo _r n co) | Just (ty, _) <- isReflCo_maybe co- , Just (_tc, args) <- ASSERT( r == _r )+ , Just (_tc, args) <- assert (r == _r ) splitTyConApp_maybe ty = liftCoSubst (chooseRole rep r) env (args `getNth` n) @@ -338,18 +341,18 @@ = liftCoSubst (chooseRole rep r) env (varType tv) opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))- = ASSERT( r == r1 )+ = assert (r == r1 ) opt_co4_wrap env sym rep r (cos `getNth` n) -- see the definition of GHC.Builtin.Types.Prim.funTyCon opt_co4 env sym rep r (NthCo r1 n (FunCo _r2 w co1 co2))- = ASSERT( r == r1 )+ = assert (r == r1 ) opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2) opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) -- works for both tyvar and covar- = ASSERT( r == _r )- ASSERT( n == 0 )+ = assert (r == _r )+ assert (n == 0 ) opt_co4_wrap env sym rep Nominal eta opt_co4 env sym rep r (NthCo _r n co)@@ -370,10 +373,10 @@ opt_co4 env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co- = ASSERT( r == Nominal )+ = assert (r == Nominal ) opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) | Just pr_co <- splitAppCo_maybe co'- = ASSERT( r == Nominal )+ = assert (r == Nominal) $ if rep then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) else pick_lr lr pr_co@@ -453,7 +456,7 @@ (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) opt_co4 env sym _rep r (KindCo co)- = ASSERT( r == Nominal )+ = assert (r == Nominal) $ let kco' = promoteCoercion co in case kco' of KindCo co' -> promoteCoercion (opt_co1 env sym co')@@ -462,12 +465,12 @@ -- and substitution/optimization at the same time opt_co4 env sym _ r (SubCo co)- = ASSERT( r == Representational )+ = assert (r == Representational) $ opt_co4_wrap env sym True Nominal co -- This could perhaps be optimized more. opt_co4 env sym rep r (AxiomRuleCo co cs)- = ASSERT( r == coaxrRole co )+ = assert (r == coaxrRole co) $ wrapRole rep r $ wrapSym sym $ AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)@@ -594,7 +597,7 @@ #endif ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco PluginProv _ -> prov- CorePrepProv -> prov+ CorePrepProv _ -> prov ------------- opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]@@ -638,7 +641,7 @@ opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))- = ASSERT( r1 == r2 )+ = assert (r1 == r2) $ fireTransRule "GRefl" in_co1 in_co2 $ mkGReflRightCo r1 t1 (opt_trans is co1 co2) @@ -647,7 +650,7 @@ | d1 == d2 , coercionRole co1 == coercionRole co2 , co1 `compatible_co` co2- = ASSERT( r1 == r2 )+ = assert (r1 == r2) $ fireTransRule "PushNth" in_co1 in_co2 $ mkNthCo r1 d1 (opt_trans is co1 co2) @@ -667,7 +670,7 @@ opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) in_co2@(UnivCo p2 r2 _tyl2 tyr2) | Just prov' <- opt_trans_prov p1 p2- = ASSERT( r1 == r2 )+ = assert (r1 == r2) $ fireTransRule "UnivCo" in_co1 in_co2 $ mkUnivCo prov' r1 tyl1 tyr2 where@@ -682,12 +685,12 @@ -- Push transitivity down through matching top-level constructors. opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) | tc1 == tc2- = ASSERT( r1 == r2 )+ = assert (r1 == r2) $ fireTransRule "PushTyConApp" in_co1 in_co2 $ mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b)- = ASSERT( r1 == r2) -- Just like the TyConAppCo/TyConAppCo case+ = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case fireTransRule "PushFun" in_co1 in_co2 $ mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b) @@ -858,7 +861,7 @@ = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) | otherwise- = ASSERT( co1bs `equalLength` co2bs )+ = assert (co1bs `equalLength` co2bs) $ fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ let rt1a = coercionRKind co1a @@ -1191,7 +1194,7 @@ -- g :: T s1 .. sn ~ T t1 .. tn -- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)- = ASSERT( tc == tc2 ) Just cos2+ = assert (tc == tc2) $ Just cos2 etaTyConAppCo_maybe tc co | not (mustBeSaturated tc)@@ -1204,7 +1207,7 @@ , tys2 `lengthIs` n -- This can fail in an erroneous program -- E.g. T a ~# T a b -- #14607- = ASSERT( tc == tc1 )+ = assert (tc == tc1) $ Just (decomposeCo n co (tyConRolesX r tc1)) -- NB: n might be <> tyConArity tc -- e.g. data family T a :: * -> *
compiler/GHC/Core/ConLike.hs view
@@ -5,8 +5,8 @@ \section[ConLike]{@ConLike@: Constructor-like things} -} -{-# LANGUAGE CPP #-} + module GHC.Core.ConLike ( ConLike(..) , conLikeArity@@ -24,8 +24,6 @@ , conLikeIsInfix , conLikeHasBuilder ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Core/DataCon.hs view
@@ -5,7 +5,7 @@ \section[DataCon]{@DataCon@: Data Constructors} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} module GHC.Core.DataCon ( -- * Main data types@@ -63,8 +63,6 @@ promoteDataCon ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer )@@ -92,6 +90,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB@@ -196,6 +195,9 @@ * INVARIANT: the dictionary constructor for a class never has a wrapper. +* See Note [Data Constructor Naming] for how the worker and wrapper+ are named+ * Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments * The wrapper (if it exists) takes dcOrigArgTys as its arguments.@@ -822,16 +824,42 @@ b) the constructor may store an unboxed version of a strict field. -Here's an example illustrating both:- data Ord a => T a = MkT Int! a+So whenever this module talks about the representation of a data constructor+what it means is the DataCon with all Unpacking having been applied.+We can think of this as the Core representation.++Here's an example illustrating the Core representation:+ data Ord a => T a = MkT Int! a Void# Here- T :: Ord a => Int -> a -> T a+ T :: Ord a => Int -> a -> Void# -> T a but the rep type is- Trep :: Int# -> a -> T a+ Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! +Not that this representation is still *different* from runtime+representation. (Which is what STG uses afer unarise). +This is how T would end up being used in STG post-unarise: + let x = T 1# y+ in ...+ case x of+ T int a -> ...++The Void# argument is dropped and the boxed int is replaced by an unboxed+one. In essence we only generate binders for runtime relevant values.++We also flatten out unboxed tuples in this process. See the unarise+pass for details on how this is done. But as an example consider+`data S = MkS Bool (# Bool | Char #)` which when matched on would+result in an alternative with three binders like this++ MkS bool tag tpl_field ->++See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation]+for the details of this transformation.++ ************************************************************************ * * \subsection{Instances}@@ -1406,9 +1434,9 @@ -> [Scaled Type] dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs}) inst_tys- = ASSERT2( univ_tvs `equalLength` inst_tys- , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)- ASSERT2( null ex_tvs, ppr dc )+ = assertPpr (univ_tvs `equalLength` inst_tys)+ (text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) $+ assertPpr (null ex_tvs) (ppr dc) $ map (mapScaledType (substTyWith univ_tvs inst_tys)) (dataConRepArgTys dc) -- | Returns just the instantiated /value/ argument types of a 'DataCon',@@ -1424,8 +1452,8 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs}) inst_tys- = ASSERT2( tyvars `equalLength` inst_tys- , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )+ = assertPpr (tyvars `equalLength` inst_tys)+ (text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys) $ substScaledTys subst arg_tys where tyvars = univ_tvs ++ ex_tvs@@ -1449,7 +1477,7 @@ , dcOtherTheta = theta , dcOrigArgTys = orig_arg_tys }) = case rep of- NoDataConRep -> ASSERT( null eq_spec ) (map unrestricted theta) ++ orig_arg_tys+ NoDataConRep -> assert (null eq_spec) $ (map unrestricted theta) ++ orig_arg_tys DCR { dcr_arg_tys = arg_tys } -> arg_tys -- | The string @package:module.name@ identifying a constructor, which is attached@@ -1467,7 +1495,7 @@ occNameFS $ nameOccName name ] where name = dataConName dc- mod = ASSERT( isExternalName name ) nameModule name+ mod = assert (isExternalName name) $ nameModule name isTupleDataCon :: DataCon -> Bool isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc@@ -1496,7 +1524,7 @@ classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of- (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr+ (dict_constr:no_more) -> assert (null no_more) dict_constr [] -> panic "classDataCon" dataConCannotMatch :: [Type] -> DataCon -> Bool
compiler/GHC/Core/FVs.hs view
@@ -5,7 +5,6 @@ Taken quite directly from the Peyton Jones/Lester paper. -} -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -- | A module concerned with finding the free variables of an expression.@@ -56,8 +55,6 @@ freeVarsOfAnn ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core@@ -80,7 +77,7 @@ import GHC.Utils.FV as FV import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain {- ************************************************************************@@ -404,7 +401,7 @@ orphNamesOfProv (PhantomProv co) = orphNamesOfCo co orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co orphNamesOfProv (PluginProv _) = emptyNameSet-orphNamesOfProv CorePrepProv = emptyNameSet+orphNamesOfProv (CorePrepProv _) = emptyNameSet orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo@@ -628,14 +625,14 @@ varTypeTyCoFVs var = tyCoFVsOfType (varType var) idFreeVars :: Id -> VarSet-idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id+idFreeVars id = assert (isId id) $ fvVarSet $ idFVs id dIdFreeVars :: Id -> DVarSet dIdFreeVars id = fvDVarSet $ idFVs id idFVs :: Id -> FV -- Type variables, rule variables, and inline variables-idFVs id = ASSERT( isId id)+idFVs id = assert (isId id) $ varTypeTyCoFVs id `unionFV` bndrRuleAndUnfoldingFVs id @@ -654,7 +651,7 @@ idRuleVars id = fvVarSet $ idRuleFVs id idRuleFVs :: Id -> FV-idRuleFVs id = ASSERT( isId id)+idRuleFVs id = assert (isId id) $ FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) idUnfoldingVars :: Id -> VarSet
compiler/GHC/Core/FamInstEnv.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -38,8 +37,6 @@ topReduceTyFamApp_maybe, reduceTyFamApp_maybe ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core.Unify@@ -62,6 +59,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain {- ************************************************************************@@ -808,9 +806,9 @@ -- In example above, fam tys' = F [b] my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _- = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs,- (ppr fam <+> ppr tys) $$- (ppr tpl_tvs <+> ppr tpl_tys) )+ = assertPpr (tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs)+ ((ppr fam <+> ppr tys) $$+ (ppr tpl_tvs <+> ppr tpl_tys)) $ -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch@@ -1003,7 +1001,7 @@ | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 = (FamInstMatch { fim_instance = item , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2- , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )+ , fim_cos = assert (all (isJust . lookupCoVar subst) tpl_cvs) $ substCoVars subst tpl_cvs }) : find rest@@ -1186,7 +1184,7 @@ | apartnessCheck flattened_target branch -> -- matching worked & we're apart from all incompatible branches. -- success- ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )+ assert (all (isJust . lookupCoVar subst) tpl_cvs) $ Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) -- failure. keep looking@@ -1509,7 +1507,7 @@ normalise_tyvar :: TyVar -> NormM (Coercion, Type) normalise_tyvar tv- = ASSERT( isTyVar tv )+ = assert (isTyVar tv) $ do { lc <- getLC ; r <- getRole ; return $ case liftCoSubstTyVar lc r tv of
compiler/GHC/Core/InstEnv.hs view
@@ -7,7 +7,7 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} module GHC.Core.InstEnv ( DFunId, InstMatch, ClsInstLookupResult,@@ -29,8 +29,6 @@ isOverlappable, isOverlapping, isIncoherent ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker,@@ -54,6 +52,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain {- ************************************************************************@@ -266,7 +265,7 @@ where cls_name = className cls dfun_name = idName dfun- this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name+ this_mod = assert (isExternalName dfun_name) $ nameModule dfun_name is_local name = nameIsLocalOrFrom this_mod name -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv@@ -274,9 +273,9 @@ arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] -- See Note [When exactly is an instance decl an orphan?]- orph | is_local cls_name = NotOrphan (nameOccName cls_name)- | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns- | otherwise = IsOrphan+ orph | is_local cls_name = NotOrphan (nameOccName cls_name)+ | all notOrphan mb_ns = assert (not (null mb_ns)) $ head mb_ns+ | otherwise = IsOrphan notOrphan NotOrphan{} = True notOrphan _ = False@@ -859,10 +858,9 @@ = find ms us rest | otherwise- = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,- (ppr cls <+> ppr tys) $$- (ppr tpl_tvs <+> ppr tpl_tys)- )+ = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set)+ ((ppr cls <+> ppr tys) $$+ (ppr tpl_tvs <+> ppr tpl_tys)) $ -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them -- See Note [Template tyvars are fresh]
compiler/GHC/Core/Lint.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -25,8 +24,6 @@ dumpIfSet, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Session@@ -76,6 +73,7 @@ import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Core.InstEnv ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo )@@ -490,8 +488,19 @@ { lf_check_global_ids = check_globals , lf_check_inline_loop_breakers = check_lbs , lf_check_static_ptrs = check_static_ptrs- , lf_check_linearity = check_linearity }+ , lf_check_linearity = check_linearity+ , lf_check_levity_poly = check_levity } + -- In the output of the desugarer, before optimisation,+ -- we have eta-expanded data constructors with levity-polymorphic+ -- bindings; so we switch off the lev-poly checks. The very simple+ -- optimiser will beta-reduce them away.+ -- See Note [Checking levity-polymorphic data constructors]+ -- in GHC.HsToCore.Expr.+ check_levity = case pass of+ CoreDesugar -> False+ _ -> True+ -- See Note [Checking for global Ids] check_globals = case pass of CoreTidy -> False@@ -541,7 +550,6 @@ Note [Linting Unfoldings from Interfaces] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We use this to check all top-level unfoldings that come in from interfaces (it is very painful to catch errors otherwise). @@ -922,9 +930,9 @@ , fun `hasKey` runRWKey -- N.B. we may have an over-saturated application of the form: -- runRW (\s -> \x -> ...) y- , arg_ty1 : arg_ty2 : arg3 : rest <- args- = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) arg_ty1- ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2+ , ty_arg1 : ty_arg2 : arg3 : rest <- args+ = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1+ ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 ty_arg2 -- See Note [Linting of runRW#] ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) lintRunRWCont expr@(Lam _ _) =@@ -1190,14 +1198,18 @@ = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg -- See Note [Levity polymorphism invariants] in GHC.Core ; flags <- getLintFlags- ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty))- (text "Levity-polymorphic argument:" <+>- (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))- -- check for levity polymorphism first, because otherwise isUnliftedType panics - ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)- (mkLetAppMsg arg)+ ; when (lf_check_levity_poly flags) $+ -- Only do these checks if lf_check_levity_poly is on,+ -- because otherwise isUnliftedType panics+ do { checkL (not (isTypeLevPoly arg_ty))+ (text "Levity-polymorphic argument:"+ <+> ppr arg <+> dcolon+ <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) + ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)+ (mkLetAppMsg arg) }+ ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } -----------------@@ -1525,7 +1537,7 @@ -- new type to the in-scope set of the second argument -- ToDo: lint its rules lintIdBndr top_lvl bind_site id thing_inside- = ASSERT2( isId id, ppr id )+ = assertPpr (isId id) (ppr id) $ do { flags <- getLintFlags ; checkL (not (lf_check_global_ids flags) || isLocalId id) (text "Non-local Id binder" <+> ppr id)@@ -2108,13 +2120,15 @@ -- see #9122 for discussion of these checks checkTypes t1 t2+ | allow_ill_kinded_univ_co prov+ = return () -- Skip kind checks+ | otherwise = do { checkWarnL (not lev_poly1) (report "left-hand type is levity-polymorphic") ; checkWarnL (not lev_poly2) (report "right-hand type is levity-polymorphic") ; when (not (lev_poly1 || lev_poly2)) $- do { checkWarnL (reps1 `equalLength` reps2 ||- is_core_prep_prov prov)+ do { checkWarnL (reps1 `equalLength` reps2) (report "between values with different # of reps") ; zipWithM_ validateCoercion reps1 reps2 }} where@@ -2130,8 +2144,8 @@ -- e.g (case error @Int "blah" of {}) :: Int# -- ==> (error @Int "blah") |> Unsafe Int Int# -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep- is_core_prep_prov CorePrepProv = True- is_core_prep_prov _ = False+ allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind+ allow_ill_kinded_univ_co _ = False validateCoercion :: PrimRep -> PrimRep -> LintM () validateCoercion rep1 rep2@@ -2162,8 +2176,8 @@ ; check_kinds kco k1 k2 ; return (ProofIrrelProv kco') } - lint_prov _ _ prov@(PluginProv _) = return prov- lint_prov _ _ prov@CorePrepProv = return prov+ lint_prov _ _ prov@(PluginProv _) = return prov+ lint_prov _ _ prov@(CorePrepProv _) = return prov check_kinds kco k1 k2 = do { let Pair k1' k2' = coercionKind kco@@ -2762,7 +2776,7 @@ addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg- = ASSERT2( notNull loc_msgs, msg )+ = assertPpr (notNull loc_msgs) msg $ msgs `snocBag` mk_msg msg where loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first
compiler/GHC/Core/Make.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Handy functions for creating much Core syntax@@ -52,8 +52,6 @@ tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -84,6 +82,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -167,7 +166,7 @@ mkCoreAppTyped _ (fun, fun_ty) (Coercion co) = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg- = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )+ = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d) (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty) where (mult, arg_ty, res_ty) = splitFunTy fun_ty@@ -393,7 +392,7 @@ -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr mkCoreUbxTup tys exps- = ASSERT( tys `equalLength` exps)+ = assert (tys `equalLength` exps) $ mkCoreConApps (tupleDataCon Unboxed (length tys)) (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) @@ -407,8 +406,8 @@ -- Alternative number ("alt") starts from 1. mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr mkCoreUbxSum arity alt tys exp- = ASSERT( length tys == arity )- ASSERT( alt <= arity )+ = assert (length tys == arity) $+ assert (alt <= arity) $ mkCoreConApps (sumDataCon alt arity) (map (Type . getRuntimeRep) tys ++ map Type tys@@ -516,7 +515,7 @@ -> CoreExpr -- Scrutinee -> CoreExpr mkSmallTupleSelector [var] should_be_the_same_var _ scrut- = ASSERT(var == should_be_the_same_var)+ = assert (var == should_be_the_same_var) $ scrut -- Special case for 1-tuples mkSmallTupleSelector vars the_var scrut_var scrut = mkSmallTupleSelector1 vars the_var scrut_var scrut@@ -524,7 +523,7 @@ -- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' -- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) mkSmallTupleSelector1 vars the_var scrut_var scrut- = ASSERT( notNull vars )+ = assert (notNull vars) $ Case scrut scrut_var (idType the_var) [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)]
compiler/GHC/Core/Multiplicity.hs view
@@ -237,9 +237,7 @@ code! Bad! Bad! Bad! It could be solved with subtyping, but subtyping doesn't combine well with-polymorphism.--Instead, we generalise the type of Just, when used as term:+polymorphism. Instead, we generalise the type of Just, when used as term: Just :: forall {p}. a %p-> Just a @@ -254,7 +252,8 @@ other multiplicity expressions are exclusive to -XLinearTypes, hence don't have backward compatibility implications. -The implementation is described in Note [Linear fields generalization].+The implementation is described in Note [Typechecking data constructors]+in GHC.Tc.Gen.Head. More details in the proposal. -}
compiler/GHC/Core/Opt/Arity.hs view
@@ -7,7 +7,6 @@ -} {-# LANGUAGE CPP #-}- {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Arity and eta expansion@@ -30,8 +29,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Ppr@@ -61,8 +58,10 @@ import GHC.Types.Tickish import GHC.Builtin.Uniques import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.Pair import GHC.Utils.Misc@@ -653,11 +652,10 @@ | next_at == cur_at = cur_at | otherwise = -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]- WARN( debugIsOn && n > 2, text "Exciting arity"- $$ nest 2 (- ppr bndr <+> ppr cur_at <+> ppr next_at- $$ ppr rhs) )- go (n+1) next_at+ warnPprTrace (debugIsOn && n > 2)+ (text "Exciting arity" $$ nest 2+ ( ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $+ go (n+1) next_at where next_at = step cur_at @@ -1554,7 +1552,7 @@ | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder -- is levity-polymorphic- = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )+ = warnPprTrace True ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) (getTCvInScope subst, reverse eis) -- This *can* legitimately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is@@ -1622,7 +1620,7 @@ = Just (ty, MRefl) | isForAllTy_ty tyL- = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )+ = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ Just (ty `mkCastTy` co1, MCo co2) | otherwise@@ -1671,7 +1669,7 @@ -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) -- then co1 :: tyL1 ~ tyR1 -- co2 :: tyL2 ~ tyR2- = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )+ = assertPpr (isFunTy tyR) (ppr co $$ ppr arg) $ Just (coToMCo (mkSymCo co1), coToMCo co2) -- Critically, coToMCo to checks for ReflCo; the whole coercion may not -- be reflexive, but either of its components might be@@ -1691,7 +1689,7 @@ -- ===> -- (\x'. e |> co') pushCoercionIntoLambda in_scope x e co- | ASSERT(not (isTyVar x) && not (isCoVar x)) True+ | assert (not (isTyVar x) && not (isCoVar x)) True , Pair s1s2 t1t2 <- coercionKind co , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2 , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2@@ -1764,8 +1762,8 @@ ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] in- ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )- ASSERT2( equalLength val_args arg_tys, dump_doc )+ assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $+ assertPpr (equalLength val_args arg_tys) dump_doc $ Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) | otherwise@@ -1806,14 +1804,14 @@ go_lam bs b e co | isTyVar b , let Pair tyL tyR = coercionKind co- , ASSERT( isForAllTy_ty tyL )+ , assert (isForAllTy_ty tyL) $ isForAllTy_ty tyR , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) | isCoVar b , let Pair tyL tyR = coercionKind co- , ASSERT( isForAllTy_co tyL )+ , assert (isForAllTy_co tyL) $ isForAllTy_co tyR , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] , let cov = mkCoVarCo b@@ -1821,7 +1819,7 @@ | isId b , let Pair tyL tyR = coercionKind co- , ASSERT( isFunTy tyL) isFunTy tyR+ , assert (isFunTy tyL) $ isFunTy tyR , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co , isReflCo co_mult -- See Note [collectBindersPushingCo] , isReflCo co_arg -- See Note [collectBindersPushingCo]@@ -1860,7 +1858,7 @@ etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule etaExpandToJoinPointRule _ rule@(BuiltinRule {})- = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule]))+ = warnPprTrace True (sep [text "Can't eta-expand built-in rule:", ppr rule]) -- How did a local binding get a built-in rule anyway? Probably a plugin. rule etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -11,7 +11,6 @@ -} {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -31,8 +30,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Ppr@@ -70,6 +67,7 @@ import GHC.Platform import GHC.Utils.Misc import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Control.Applicative ( Alternative(..) ) @@ -165,8 +163,8 @@ , equalArgs $> Lit zeroW8 ] Word8NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp , semiInversePrimOp Word8NotOp ]- Word8SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]- Word8SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ const $ shiftRightLogical @Word8 ]+ Word8SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 (const shiftL) ]+ Word8SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 $ const $ shiftRightLogical @Word8 ] -- Int16 operations@@ -232,8 +230,8 @@ , equalArgs $> Lit zeroW16 ] Word16NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp , semiInversePrimOp Word16NotOp ]- Word16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]- Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ const $ shiftRightLogical @Word16 ]+ Word16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 (const shiftL) ]+ Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 $ const $ shiftRightLogical @Word16 ] -- Int32 operations@@ -299,8 +297,8 @@ , equalArgs $> Lit zeroW32 ] Word32NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp , semiInversePrimOp Word32NotOp ]- Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]- Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ const $ shiftRightLogical @Word32 ]+ Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 (const shiftL) ]+ Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 $ const $ shiftRightLogical @Word32 ] -- Int operations@@ -1536,11 +1534,11 @@ let tag = fromInteger i correct_tag dc = (dataConTagZ dc) == tag (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])- ASSERT(null rest) return ()+ massert (null rest) return $ mkTyApps (Var (dataConWorkId dc)) tc_args -- See Note [tagToEnum#]- _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )+ _ -> warnPprTrace True (text "tagToEnum# on non-enumeration type" <+> ppr ty) $ return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" ------------------------------@@ -1564,7 +1562,7 @@ [_, val_arg] <- getArgs in_scope <- getInScopeEnv (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg- ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()+ massert (not (isNewTyCon (dataConTyCon dc))) return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) {- Note [dataToTag# magic]@@ -1786,7 +1784,7 @@ , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False - , lit_to_natural "Word# -> Natural" naturalNSDataConName+ , lit_to_natural "Word# -> Natural" naturalNSName , natural_to_word "Natural -> Word# (wrap)" naturalToWordName False , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True @@ -1859,21 +1857,21 @@ , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap -- identity passthrough- , id_passthrough "Int# -> Integer -> Int#" integerToIntName integerISDataConName+ , id_passthrough "Int# -> Integer -> Int#" integerToIntName integerISName , id_passthrough "Word# -> Integer -> Word#" integerToWordName integerFromWordName , id_passthrough "Int64# -> Integer -> Int64#" integerToInt64Name integerFromInt64Name , id_passthrough "Word64# -> Integer -> Word64#" integerToWord64Name integerFromWord64Name- , id_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSDataConName+ , id_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSName -- identity passthrough with a conversion that can be done directly instead , small_passthrough "Int# -> Integer -> Word#"- integerISDataConName integerToWordName (mkPrimOpId IntToWordOp)+ integerISName integerToWordName (mkPrimOpId IntToWordOp) , small_passthrough "Int# -> Integer -> Float#"- integerISDataConName integerToFloatName (mkPrimOpId IntToFloatOp)+ integerISName integerToFloatName (mkPrimOpId IntToFloatOp) , small_passthrough "Int# -> Integer -> Double#"- integerISDataConName integerToDoubleName (mkPrimOpId IntToDoubleOp)+ integerISName integerToDoubleName (mkPrimOpId IntToDoubleOp) , small_passthrough "Word# -> Natural -> Int#"- naturalNSDataConName naturalToWordName (mkPrimOpId WordToIntOp)+ naturalNSName naturalToWordName (mkPrimOpId WordToIntOp) -- Bits.bit , bignum_bit "integerBit" integerBitName mkLitInteger@@ -1910,6 +1908,25 @@ , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble ] where+ -- The rule is matching against an occurrence of a data constructor in a+ -- Core expression. It must match either its worker name or its wrapper+ -- name, /not/ the DataCon name itself, which is different.+ -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892+ --+ -- But data constructor wrappers deliberately inline late; See Note+ -- [Activation for data constructor wrappers] in GHC.Types.Id.Make.+ -- Suppose there is a wrapper and the rule matches on the worker: the+ -- wrapper won't be inlined until rules have finished firing and the rule+ -- will never fire.+ --+ -- Hence the rule must match on the wrapper, if there is one, otherwise on+ -- the worker. That is exactly the dataConWrapId for the data constructor.+ -- The data constructor may or may not have a wrapper, but if not+ -- dataConWrapId will return the worker+ --+ integerISName = idName (dataConWrapId integerISDataCon)+ naturalNSName = idName (dataConWrapId naturalNSDataCon)+ mkRule str name nargs f = BuiltinRule { ru_name = fsLit str , ru_fn = name@@ -2137,7 +2154,7 @@ in eqExpr freeVars c1 c2 , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 , c2Ticks <- stripTicksTopT tickishFloatable c2- = ASSERT( ty1 `eqType` ty2 )+ = assert (ty1 `eqType` ty2) $ Just $ mkTicks strTicks $ Var unpk `App` Type ty1 `App` Lit (LitString (s1 `BS.append` s2))@@ -2337,7 +2354,7 @@ addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr addFoldingRules op num_ops = do- ASSERT(op == numAdd num_ops) return ()+ massert (op == numAdd num_ops) env <- getEnv guard (roNumConstantFolding env) [arg1,arg2] <- getArgs@@ -2349,7 +2366,7 @@ subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr subFoldingRules op num_ops = do- ASSERT(op == numSub num_ops) return ()+ massert (op == numSub num_ops) env <- getEnv guard (roNumConstantFolding env) [arg1,arg2] <- getArgs@@ -2358,7 +2375,7 @@ mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr mulFoldingRules op num_ops = do- ASSERT(op == numMul num_ops) return ()+ massert (op == numMul num_ops) env <- getEnv guard (roNumConstantFolding env) [arg1,arg2] <- getArgs
compiler/GHC/Core/Opt/Monad.hs view
@@ -3,7 +3,7 @@ -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
compiler/GHC/Core/Opt/OccurAnal.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -19,8 +18,6 @@ module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Ppr@@ -54,6 +51,7 @@ import GHC.Data.Maybe( isJust ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.List (mapAccumL, mapAccumR) {-@@ -81,8 +79,8 @@ = occ_anald_binds | otherwise -- See Note [Glomming]- = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)- 2 (ppr final_usage ) )+ = warnPprTrace True (hang (text "Glomming in" <+> ppr this_mod <> colon)+ 2 (ppr final_usage)) occ_anald_glommed_binds where init_env = initOccEnv { occ_rule_act = active_rule@@ -3020,7 +3018,7 @@ occ = lookupDetails usage binder will_be_join = decideJoinPointHood lvl usage [binder] occ' | will_be_join = -- must already be marked AlwaysTailCalled- ASSERT(isAlwaysTailCalled occ) occ+ assert (isAlwaysTailCalled occ) occ | otherwise = markNonTail occ binder' = setBinderOcc occ' binder usage' = usage `delDetails` binder@@ -3060,7 +3058,7 @@ , AlwaysTailCalled arity <- tailCallInfo occ = Just arity | otherwise- = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if+ = assert (not will_be_joins) -- Should be AlwaysTailCalled if Nothing -- we are making join points! -- 3. Compute final usage details from adjusted RHS details@@ -3105,9 +3103,9 @@ = False decideJoinPointHood NotTopLevel usage bndrs | isJoinId (head bndrs)- = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+>- ppr bndrs)- all_ok+ = warnPprTrace (not all_ok)+ (text "OccurAnal failed to rediscover join point(s):" <+> ppr bndrs)+ all_ok | otherwise = all_ok where@@ -3205,7 +3203,7 @@ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo -addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+addOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $ ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` tailCallInfo a2 } -- Both branches are at least One@@ -3227,7 +3225,7 @@ , occ_int_cxt = int_cxt1 `mappend` int_cxt2 , occ_tail = tail1 `andTailCallInfo` tail2 } -orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )+orOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $ ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` tailCallInfo a2 }
compiler/GHC/Core/PatSyn.hs view
@@ -5,8 +5,8 @@ \section[PatSyn]{@PatSyn@: Pattern synonyms} -} -{-# LANGUAGE CPP #-} + module GHC.Core.PatSyn ( -- * Main data types PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,@@ -23,8 +23,6 @@ pprPatSynType ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core.Type@@ -473,8 +471,8 @@ patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs , psExTyVars = ex_tvs, psArgs = arg_tys }) inst_tys- = ASSERT2( tyvars `equalLength` inst_tys- , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )+ = assertPpr (tyvars `equalLength` inst_tys)+ (text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys) $ map (substTyWith tyvars inst_tys) arg_tys where tyvars = binderVars (univ_tvs ++ ex_tvs)@@ -488,8 +486,8 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs , psResultTy = res_ty }) inst_tys- = ASSERT2( univ_tvs `equalLength` inst_tys- , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )+ = assertPpr (univ_tvs `equalLength` inst_tys)+ (text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys) $ substTyWith (binderVars univ_tvs) inst_tys res_ty -- | Print the type of a pattern synonym. The foralls are printed explicitly
compiler/GHC/Core/Rules.hs view
@@ -4,7 +4,6 @@ \section[CoreRules]{Rewrite rules} -} -{-# LANGUAGE CPP #-} -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere.@@ -26,8 +25,6 @@ lookupRule, mkRule, roughTopNames, initRuleOpts ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core -- All of it@@ -66,6 +63,7 @@ import GHC.Driver.Flags import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag@@ -858,13 +856,12 @@ Just (arg2, res2) -> match_cos renv subst [arg1, res1] [arg2, res2] _ -> Nothing-match_co _ _ _co1 _co2+match_co _ _ co1 co2 -- Currently just deals with CoVarCo, TyConAppCo and Refl-#if defined(DEBUG)- = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing-#else+ | debugIsOn+ = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing+ | otherwise = Nothing-#endif match_cos :: RuleMatchEnv -> RuleSubst
compiler/GHC/Core/SimpleOpt.hs view
@@ -3,7 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE MultiWayIf #-} module GHC.Core.SimpleOpt (@@ -20,8 +20,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core@@ -52,6 +50,7 @@ import GHC.Unit.Module ( Module ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Data.Maybe ( orElse ) import GHC.Data.FastString@@ -338,11 +337,11 @@ | (bndrs, body) <- collectBinders e , let zapped_bndrs = zapLamBndrs (length as) bndrs -- Be careful to zap the lambda binders if necessary- -- c.f. the Lam caes of simplExprF1 in GHC.Core.Opt.Simplify+ -- c.f. the Lam case of simplExprF1 in GHC.Core.Opt.Simplify -- Lacking this zap caused #19347, when we had a redex -- (\ a b. K a b) e1 e2 -- where (as it happens) the eta-expanded K is produced by- -- Note [Linear fields generalization] in GHC.Tc.Gen.Head+ -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head = do_beta env zapped_bndrs body as where do_beta env (b:bs) body (a:as)@@ -419,15 +418,15 @@ top_level | Type ty <- in_rhs -- let a::* = TYPE ty in <body> , let out_ty = substTy (soe_subst rhs_env) ty- = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr in_rhs )+ = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $ (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion co <- in_rhs , let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co- = ASSERT( isCoVar in_bndr )+ = assert (isCoVar in_bndr) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) - | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )+ | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr) -- The previous two guards got rid of tyvars and coercions -- See Note [Core type and coercion invariant] in GHC.Core pre_inline_unconditionally@@ -477,11 +476,11 @@ -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) | Type out_ty <- out_rhs- = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr out_ty $$ ppr out_rhs )+ = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr out_ty $$ ppr out_rhs) (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion out_co <- out_rhs- = ASSERT( isCoVar in_bndr )+ = assert (isCoVar in_bndr) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) | otherwise@@ -495,7 +494,7 @@ -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) simple_out_bind_pair env in_bndr mb_out_bndr out_rhs occ_info active stable_unf top_level- | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )+ | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr) -- Type and coercion bindings are caught earlier -- See Note [Core type and coercion invariant] post_inline_unconditionally@@ -1342,7 +1341,7 @@ -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x)- , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True+ , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co , let res = Just (x',e',ts) = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
compiler/GHC/Core/Subst.hs view
@@ -6,7 +6,7 @@ Utility functions on @Core@ syntax -} -{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Subst ( -- * Main data types@@ -34,9 +34,6 @@ ) where -#include "GhclibHsVersions.h"-- import GHC.Prelude import GHC.Driver.Ppr@@ -67,6 +64,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.List (mapAccumL) @@ -191,13 +189,13 @@ extendIdSubst :: Subst -> Id -> CoreExpr -> Subst -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set extendIdSubst (Subst in_scope ids tvs cvs) v r- = ASSERT2( isNonCoVarId v, ppr v $$ ppr r )+ = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $ Subst in_scope (extendVarEnv ids v r) tvs cvs -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst extendIdSubstList (Subst in_scope ids tvs cvs) prs- = ASSERT( all (isNonCoVarId . fst) prs )+ = assert (all (isNonCoVarId . fst) prs) $ Subst in_scope (extendVarEnvList ids prs) tvs cvs -- | Add a substitution for a 'TyVar' to the 'Subst'@@ -207,7 +205,7 @@ -- after extending the substitution like this. extendTvSubst :: Subst -> TyVar -> Type -> Subst extendTvSubst (Subst in_scope ids tvs cvs) tv ty- = ASSERT( isTyVar tv )+ = assert (isTyVar tv) $ Subst in_scope ids (extendVarEnv tvs tv ty) cvs -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'@@ -223,7 +221,7 @@ -- after extending the substitution like this extendCvSubst :: Subst -> CoVar -> Coercion -> Subst extendCvSubst (Subst in_scope ids tvs cvs) v r- = ASSERT( isCoVar v )+ = assert (isCoVar v) $ Subst in_scope ids tvs (extendVarEnv cvs v r) -- | Add a substitution appropriate to the thing being substituted@@ -232,15 +230,15 @@ extendSubst :: Subst -> Var -> CoreArg -> Subst extendSubst subst var arg = case arg of- Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty- Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co- _ -> ASSERT( isId var ) extendIdSubst subst var arg+ Type ty -> assert (isTyVar var) $ extendTvSubst subst var ty+ Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co+ _ -> assert (isId var) $ extendIdSubst subst var arg extendSubstWithVar :: Subst -> Var -> Var -> Subst extendSubstWithVar subst v1 v2- | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)- | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)- | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2)+ | isTyVar v1 = assert (isTyVar v2) $ extendTvSubst subst v1 (mkTyVarTy v2)+ | isCoVar v1 = assert (isCoVar v2) $ extendCvSubst subst v1 (mkCoVarCo v2)+ | otherwise = assert (isId v2) $ extendIdSubst subst v1 (Var v2) -- | Add a substitution as appropriate to each of the terms being -- substituted (whether expressions, types, or coercions). See also@@ -256,8 +254,8 @@ | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst]- | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v- $$ ppr in_scope)+ | otherwise = warnPprTrace True (text "GHC.Core.Subst.lookupIdSubst" <+> ppr v+ $$ ppr in_scope) $ Var v -- | Find the substitution for a 'TyVar' in the 'Subst'
compiler/GHC/Core/Tidy.hs view
@@ -7,13 +7,11 @@ The code for *top-level* bindings is in GHC.Iface.Tidy. -} -{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Tidy ( tidyExpr, tidyRules, tidyUnfolding ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Core/TyCo/FVs.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Core.TyCo.FVs ( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, tyCoVarsOfType, tyCoVarsOfTypes,@@ -42,8 +42,6 @@ Endo(..), runTyCoVars ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes)@@ -650,7 +648,7 @@ tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc-tyCoFVsOfProv CorePrepProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc+tyCoFVsOfProv (CorePrepProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc@@ -720,8 +718,8 @@ = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_prov (ProofIrrelProv co) cv = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (PluginProv _) _ = True-almost_devoid_co_var_of_prov CorePrepProv _ = True+almost_devoid_co_var_of_prov (PluginProv _) _ = True+almost_devoid_co_var_of_prov (CorePrepProv _) _ = True almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True
compiler/GHC/Core/TyCo/Rep.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK not-home #-}@@ -74,8 +74,6 @@ Scaled(..), scaledMult, scaledThing, mapScaledType, Mult ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit )@@ -251,7 +249,7 @@ checker can handle it; see #16185 For now we use the CPP macro #define FunTy FFunTy _- (see GhclibHsVersions.h) to allow pattern matching on a+ (see HsVersions.h) to allow pattern matching on a (positional) FunTy constructor. {-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp@@ -938,7 +936,7 @@ -} mkTyVarTy :: TyVar -> Type-mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) )+mkTyVarTy v = assertPpr (isTyVar v) (ppr v <+> dcolon <+> ppr (tyVarKind v)) $ TyVarTy v mkTyVarTys :: [TyVar] -> [Type]@@ -1540,7 +1538,9 @@ | PluginProv String -- ^ From a plugin, which asserts that this coercion -- is sound. The string is for the use of the plugin. - | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Pprep+ | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep+ Bool -- True <=> the UnivCo must be homogeneously kinded+ -- False <=> allow hetero-kinded, e.g. Int ~ Int# deriving Data.Data @@ -1548,7 +1548,7 @@ ppr (PhantomProv _) = text "(phantom)" ppr (ProofIrrelProv _) = text "(proof irrel.)" ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str))- ppr CorePrepProv = text "(CorePrep)"+ ppr (CorePrepProv _) = text "(CorePrep)" -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole@@ -1860,7 +1860,7 @@ go_prov env (PhantomProv co) = go_co env co go_prov env (ProofIrrelProv co) = go_co env co go_prov _ (PluginProv _) = mempty- go_prov _ CorePrepProv = mempty+ go_prov _ (CorePrepProv _) = mempty {- ********************************************************************* * *@@ -1917,7 +1917,7 @@ provSize (PhantomProv co) = 1 + coercionSize co provSize (ProofIrrelProv co) = 1 + coercionSize co provSize (PluginProv _) = 1-provSize CorePrepProv = 1+provSize (CorePrepProv _) = 1 {- ************************************************************************
compiler/GHC/Core/TyCo/Subst.hs view
@@ -4,7 +4,7 @@ Type and Coercion - friends' interface -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -52,8 +52,6 @@ checkValidSubst, isValidTCvSubst, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type@@ -76,6 +74,7 @@ import GHC.Types.Var.Env import GHC.Data.Pair+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Types.Unique.Supply import GHC.Types.Unique@@ -83,6 +82,7 @@ import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.List (mapAccumL) @@ -344,7 +344,7 @@ extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty- = ASSERT( isTyVar v )+ = assert (isTyVar v ) extendTvSubstAndInScope subst v ty extendTvSubstBinderAndInScope subst (Anon {}) _ = subst@@ -388,7 +388,7 @@ unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -- Works when the ranges are disjoint unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)- = ASSERT( tenv1 `disjointVarEnv` tenv2+ = assert (tenv1 `disjointVarEnv` tenv2 && cenv1 `disjointVarEnv` cenv2 ) TCvSubst (in_scope1 `unionInScope` in_scope2) (tenv1 `plusVarEnv` tenv2)@@ -430,7 +430,7 @@ mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst mkTvSubstPrs [] = emptyTCvSubst mkTvSubstPrs prs =- ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )+ assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $ mkTvSubst in_scope tenv where tenv = mkVarEnv prs in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs@@ -444,7 +444,7 @@ , not (all isTyVar tyvars && (tyvars `equalLength` tys)) = pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys) | otherwise- = ASSERT( all (not . isCoercionTy) tys )+ = assert (all (not . isCoercionTy) tys ) zipToUFM tyvars tys -- There used to be a special case for when -- ty == TyVarTy tv@@ -556,7 +556,7 @@ -- Works only if the domain of the substitution is a -- superset of the type being substituted into substTyWith tvs tys = {-#SCC "substTyWith" #-}- ASSERT( tvs `equalLength` tys )+ assert (tvs `equalLength` tys ) substTy (zipTvSubst tvs tys) -- | Type substitution, see 'zipTvSubst'. Disables sanity checks.@@ -566,7 +566,7 @@ -- substTy and remove this function. Please don't use in new code. substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type substTyWithUnchecked tvs tys- = ASSERT( tvs `equalLength` tys )+ = assert (tvs `equalLength` tys ) substTyUnchecked (zipTvSubst tvs tys) -- | Substitute tyvars within a type using a known 'InScopeSet'.@@ -575,13 +575,13 @@ -- and of 'ty' minus the domain of the subst. substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type substTyWithInScope in_scope tvs tys ty =- ASSERT( tvs `equalLength` tys )+ assert (tvs `equalLength` tys ) substTy (mkTvSubst in_scope tenv) ty where tenv = zipTyEnv tvs tys -- | Coercion substitution, see 'zipTvSubst' substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion-substCoWith tvs tys = ASSERT( tvs `equalLength` tys )+substCoWith tvs tys = assert (tvs `equalLength` tys ) substCo (zipTvSubst tvs tys) -- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.@@ -591,7 +591,7 @@ -- substCo and remove this function. Please don't use in new code. substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion substCoWithUnchecked tvs tys- = ASSERT( tvs `equalLength` tys )+ = assert (tvs `equalLength` tys ) substCoUnchecked (zipTvSubst tvs tys) @@ -602,12 +602,12 @@ -- | Type substitution, see 'zipTvSubst' substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]-substTysWith tvs tys = ASSERT( tvs `equalLength` tys )+substTysWith tvs tys = assert (tvs `equalLength` tys ) substTys (zipTvSubst tvs tys) -- | Type substitution, see 'zipTvSubst' substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]-substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos )+substTysWithCoVars cvs cos = assert (cvs `equalLength` cos ) substTys (zipCvSubst cvs cos) -- | Substitute within a 'Type' after adding the free variables of the type@@ -634,21 +634,21 @@ -- Note [The substitution invariant]. checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a- = ASSERT2( isValidTCvSubst subst,- text "in_scope" <+> ppr in_scope $$- text "tenv" <+> ppr tenv $$- text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$- text "cenv" <+> ppr cenv $$- text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$- text "tys" <+> ppr tys $$- text "cos" <+> ppr cos )- ASSERT2( tysCosFVsInScope,- text "in_scope" <+> ppr in_scope $$- text "tenv" <+> ppr tenv $$- text "cenv" <+> ppr cenv $$- text "tys" <+> ppr tys $$- text "cos" <+> ppr cos $$- text "needInScope" <+> ppr needInScope )+ = assertPpr (isValidTCvSubst subst)+ (text "in_scope" <+> ppr in_scope $$+ text "tenv" <+> ppr tenv $$+ text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$+ text "cenv" <+> ppr cenv $$+ text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$+ text "tys" <+> ppr tys $$+ text "cos" <+> ppr cos) $+ assertPpr tysCosFVsInScope+ (text "in_scope" <+> ppr in_scope $$+ text "tenv" <+> ppr tenv $$+ text "cenv" <+> ppr cenv $$+ text "tys" <+> ppr tys $$+ text "cos" <+> ppr cos $$+ text "needInScope" <+> ppr needInScope) a where substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv@@ -764,7 +764,7 @@ substTyVar :: TCvSubst -> TyVar -> Type substTyVar (TCvSubst _ tenv _) tv- = ASSERT( isTyVar tv )+ = assert (isTyVar tv) $ case lookupVarEnv tenv tv of Just ty -> ty Nothing -> TyVarTy tv@@ -783,7 +783,7 @@ lookupTyVar :: TCvSubst -> TyVar -> Maybe Type -- See Note [Extending the TCvSubst] lookupTyVar (TCvSubst _ tenv _) tv- = ASSERT( isTyVar tv )+ = assert (isTyVar tv ) lookupVarEnv tenv tv -- | Substitute within a 'Coercion'@@ -852,7 +852,7 @@ go_prov (PhantomProv kco) = PhantomProv (go kco) go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) go_prov p@(PluginProv _) = p- go_prov p@CorePrepProv = p+ go_prov p@(CorePrepProv _) = p -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv })@@ -887,7 +887,7 @@ -> TCvSubst -> TyVar -> KindCoercion -> (TCvSubst, TyVar, KindCoercion) substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co- = ASSERT( isTyVar old_var )+ = assert (isTyVar old_var ) ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv , new_var, new_kind_co ) where@@ -916,7 +916,7 @@ -> (TCvSubst, CoVar, KindCoercion) substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co- = ASSERT( isCoVar old_var )+ = assert (isCoVar old_var ) ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv , new_var, new_kind_co ) where@@ -983,8 +983,8 @@ :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind -> TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var- = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )- ASSERT( isTyVar old_var )+ = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $+ assert (isTyVar old_var ) (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) where new_env | no_change = delVarEnv tenv old_var@@ -1018,7 +1018,7 @@ :: (TCvSubst -> Type -> Type) -> TCvSubst -> CoVar -> (TCvSubst, CoVar) substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var- = ASSERT( isCoVar old_var )+ = assert (isCoVar old_var) (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) where new_co = mkCoVarCo new_var@@ -1040,7 +1040,7 @@ cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq- = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars+ = assertPpr (isTyVar tv) (ppr tv) -- I think it's only called on TyVars (TCvSubst (extendInScopeSet in_scope tv') (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') where
compiler/GHC/Core/TyCo/Tidy.hs view
@@ -261,7 +261,7 @@ go_prov (PhantomProv co) = PhantomProv $! go co go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co go_prov p@(PluginProv _) = p- go_prov p@CorePrepProv = p+ go_prov p@(CorePrepProv _) = p tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env)
compiler/GHC/Core/TyCon.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -132,8 +132,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -166,6 +164,7 @@ import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString.Env import GHC.Types.FieldLabel import GHC.Settings.Constants@@ -455,7 +454,7 @@ ppr (AnonTCB af) = text "AnonTCB" <> ppr af mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder-mkAnonTyConBinder af tv = ASSERT( isTyVar tv)+mkAnonTyConBinder af tv = assert (isTyVar tv) $ Bndr tv (AnonTCB af) mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]@@ -463,7 +462,7 @@ mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder -- The odd argument order supports currying-mkNamedTyConBinder vis tv = ASSERT( isTyVar tv )+mkNamedTyConBinder vis tv = assert (isTyVar tv) $ Bndr tv (NamedTCB vis) mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder]@@ -1337,17 +1336,22 @@ ~~~~~~~~~~~~~~~~~~ Consider newtype Parser a = MkParser (IO a) deriving Monad-Are these two types equal (that is, does a coercion exist between them)?+Are these two types equal? That is, does a coercion exist between them? Monad Parser Monad IO-which we need to make the derived instance for Monad Parser.+(We need this coercion to make the derived instance for Monad Parser.) Well, yes. But to see that easily we eta-reduce the RHS type of-Parser, in this case to IO, so that even unsaturated applications-of Parser will work right. This eta reduction is done when the type-constructor is built, and cached in NewTyCon.+Parser, in this case to IO, so that even unsaturated applications of+Parser will work right. So instead of+ axParser :: forall a. Parser a ~ IO a+we generate an eta-reduced axiom+ axParser :: Parser ~ IO -Here's an example that I think showed up in practice+This eta reduction is done when the type constructor is built, in+GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon.++Here's an example that I think showed up in practice. Source code: newtype T a = MkT [a] newtype Foo m = MkFoo (forall a. m a -> Int)@@ -1359,14 +1363,15 @@ w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) After desugaring, and discarding the data constructors for the newtypes,-we get:- w2 = w1 `cast` Foo CoT-so the coercion tycon CoT must have- kind: T ~ []- and arity: 0+we would like to get:+ w2 = w1 `cast` Foo axT -This eta-reduction is implemented in GHC.Tc.TyCl.Build.mkNewTyConRhs.+so that w2 and w1 share the same code. To do this, the coercion axiom+axT must have+ kind: axT :: T ~ []+ and arity: 0 +See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. ************************************************************************ * *@@ -1746,7 +1751,7 @@ algTcStupidTheta = stupid, algTcRhs = rhs, algTcFields = fieldsOfAlgTcRhs rhs,- algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,+ algTcParent = assertPpr (okParent name parent) (ppr name $$ ppr parent) parent, algTcGadtSyntax = gadt_syn } in tc
compiler/GHC/Core/TyCon/Env.hs view
@@ -5,7 +5,7 @@ \section[TyConEnv]{@TyConEnv@: tyCon environments} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE ScopedTypeVariables #-} @@ -32,8 +32,6 @@ mapDTyConEnv, mapMaybeDTyConEnv, adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Core/TyCon/RecWalk.hs view
@@ -6,8 +6,8 @@ -} -{-# LANGUAGE CPP #-} + module GHC.Core.TyCon.RecWalk ( -- * Recursion breaking@@ -15,8 +15,6 @@ setRecTcMaxBound, checkRecTc ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Core/Type.hs view
@@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-}+{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -235,8 +235,6 @@ isKindLevPoly ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Types.Basic@@ -282,6 +280,7 @@ import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.List.SetOps@@ -417,7 +416,7 @@ -- At the Core level, Constraint = Type -- See Note [coreView vs tcView] | isConstraintKindCon tc- = ASSERT2( null tys, ppr ty )+ = assertPpr (null tys) (ppr ty) $ Just liftedTypeKind coreView _ = Nothing@@ -581,7 +580,7 @@ go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) go_prov _ p@(PluginProv _) = p- go_prov _ p@CorePrepProv = p+ go_prov _ p@(CorePrepProv _) = p -- the "False" and "const" are to accommodate the type of -- substForAllCoBndrUsing, which is general enough to@@ -720,7 +719,7 @@ isNullaryTyConKeyApp :: Unique -> Type -> Bool isNullaryTyConKeyApp key ty | Just args <- isTyConKeyApp_maybe key ty- = ASSERT( null args ) True+ = assert (null args ) True | otherwise = False {-# INLINE isNullaryTyConKeyApp #-}@@ -915,7 +914,7 @@ go_prov env (PhantomProv co) = PhantomProv <$> go_co env co go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co go_prov _ p@(PluginProv _) = return p- go_prov _ p@CorePrepProv = return p+ go_prov _ p@(CorePrepProv _) = return p {-@@ -1099,7 +1098,7 @@ in (TyConApp tc tc_args1, tc_args2 ++ args) split _ (FunTy _ w ty1 ty2) args- = ASSERT( null args )+ = assert (null args ) (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) where rep1 = getRuntimeRep ty1@@ -1119,7 +1118,7 @@ in (TyConApp tc tc_args1, tc_args2 ++ args) split (FunTy _ w ty1 ty2) args- = ASSERT( null args )+ = assert (null args ) (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) where rep1 = getRuntimeRep ty1@@ -1363,8 +1362,8 @@ -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys -- Assumes that (/\tvs. body_ty) is closed applyTysX tvs body_ty arg_tys- = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff )- ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )+ = assertPpr (arg_tys `lengthAtLeast` n_tvs) pp_stuff $+ assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $ mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) (drop n_tvs arg_tys) where@@ -1511,7 +1510,7 @@ -- arguments, using an eta-reduced version of the @newtype@ if possible. -- This requires tys to have at least @newTyConInstArity tycon@ elements. newTyConInstRhs tycon tys- = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs )+ = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $ applyTysX tvs rhs tys where (tvs, rhs) = newTyConEtadRhs tycon@@ -1750,7 +1749,7 @@ -- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar mkInfForAllTy :: TyVar -> Type -> Type-mkInfForAllTy tv ty = ASSERT( isTyVar tv )+mkInfForAllTy tv ty = assert (isTyVar tv ) ForAllTy (Bndr tv Inferred) ty -- | Like 'mkForAllTys', but assumes all variables are dependent and@@ -1765,7 +1764,7 @@ -- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', -- a common case mkSpecForAllTy :: TyVar -> Type -> Type-mkSpecForAllTy tv ty = ASSERT( isTyVar tv )+mkSpecForAllTy tv ty = assert (isTyVar tv ) -- covar is always Inferred, so input should be tyvar ForAllTy (Bndr tv Specified) ty @@ -1776,7 +1775,7 @@ -- | Like mkForAllTys, but assumes all variables are dependent and visible mkVisForAllTys :: [TyVar] -> Type -> Type-mkVisForAllTys tvs = ASSERT( all isTyVar tvs )+mkVisForAllTys tvs = assert (all isTyVar tvs ) -- covar is always Inferred, so all inputs should be tyvar mkForAllTys [ Bndr tv Required | tv <- tvs ] @@ -1790,7 +1789,7 @@ mkTyConBindersPreferAnon :: [TyVar] -- ^ binders -> TyCoVarSet -- ^ free variables of result -> [TyConBinder]-mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars)+mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars) fst (go vars) where go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars@@ -2155,7 +2154,7 @@ tyBinderType :: TyBinder -> Type tyBinderType (Named (Bndr tv _))- = ASSERT( isTyVar tv )+ = assert (isTyVar tv ) tyVarKind tv tyBinderType (Anon _ ty) = scaledThing ty @@ -2185,7 +2184,7 @@ mkFamilyTyConApp tc tys | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc , let tvs = tyConTyVars tc- fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys )+ fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $ zipTvSubst tvs tys = mkTyConApp fam_tc (substTys fam_subst fam_tys) | otherwise@@ -2328,7 +2327,7 @@ isAlgType :: Type -> Bool isAlgType ty = case splitTyConApp_maybe ty of- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )+ Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) isAlgTyCon tc _other -> False @@ -2347,7 +2346,7 @@ isPrimitiveType :: Type -> Bool -- ^ Returns true of types that are opaque to Haskell. isPrimitiveType ty = case splitTyConApp_maybe ty of- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )+ Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) isPrimTyCon tc _ -> False @@ -2669,7 +2668,7 @@ -- See Note [nonDetCmpType nondeterminism] nonDetCmpTc :: TyCon -> TyCon -> Ordering nonDetCmpTc tc1 tc2- = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) )+ = assert (not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2)) $ u1 `nonDetCmpUnique` u2 where u1 = tyConUnique tc1@@ -2858,7 +2857,7 @@ tcIsConstraintKind ty | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here , isConstraintKindCon tc- = ASSERT2( null args, ppr ty ) True+ = assertPpr (null args) (ppr ty) True | otherwise = False@@ -3140,7 +3139,7 @@ go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co go_prov _ p@(PluginProv _) = return p- go_prov _ p@CorePrepProv = return p+ go_prov _ p@(CorePrepProv _) = return p {-@@ -3195,7 +3194,7 @@ go_prov (PhantomProv co) = go_co co go_prov (ProofIrrelProv co) = go_co co go_prov (PluginProv _) = emptyUniqSet- go_prov CorePrepProv = emptyUniqSet+ go_prov (CorePrepProv _) = emptyUniqSet -- this last case can happen from the tyConsOfType used from -- checkTauTvUpdate @@ -3282,7 +3281,7 @@ -- E.g. True of TYPE k, TYPE (F Int) -- False of TYPE 'LiftedRep isKindLevPoly :: Kind -> Bool-isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k )+isKindLevPoly k = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $ -- the isLiftedTypeKind check is necessary b/c of Constraint go k where
compiler/GHC/Core/Unfold.hs view
@@ -15,7 +15,7 @@ find, unsurprisingly, a Core expression. -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -36,8 +36,6 @@ callSiteInline, CallCtxt(..), calcUnfoldingGuidance ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Core/Unfold/Make.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Unfolding creation module GHC.Core.Unfold.Make ( noUnfolding@@ -19,8 +19,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core import GHC.Core.Unfold@@ -149,8 +147,8 @@ -- specUnfolding opts spec_bndrs spec_app rule_lhs_args df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })- = ASSERT2( rule_lhs_args `equalLength` old_bndrs- , ppr df $$ ppr rule_lhs_args )+ = assertPpr (rule_lhs_args `equalLength` old_bndrs)+ (ppr df $$ ppr rule_lhs_args) $ -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise mkDFunUnfolding spec_bndrs con (map spec_arg args) -- For DFunUnfoldings we transform
compiler/GHC/Core/Unify.hs view
@@ -1,7 +1,7 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-} module GHC.Core.Unify (@@ -27,8 +27,6 @@ flattenTys, flattenTysX ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Types.Var@@ -51,6 +49,7 @@ import GHC.Types.Unique.Set import GHC.Exts( oneShot ) import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import Data.Data ( Data )@@ -308,7 +307,7 @@ rough ty | Just (ty', _) <- splitCastTy_maybe ty = rough ty' | Just (tc,_) <- splitTyConApp_maybe ty- , not (isTypeFamilyTyCon tc) = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc )+ , not (isTypeFamilyTyCon tc) = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) $ KnownTc (tyConName tc) -- See Note [Rough matching in class and family instances] | otherwise = OtherTc@@ -2021,7 +2020,7 @@ where arity = tyConArity fam_tc tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv- (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )+ (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $ splitAt arity fam_args -- Apply the substitution before looking up an application in the -- environment. See Note [Flattening type-family applications when matching instances],
compiler/GHC/Core/Utils.hs view
@@ -6,8 +6,6 @@ Utility functions on @Core@ syntax -} -{-# LANGUAGE CPP #-}- -- | Commonly useful utilities for manipulating the Core language module GHC.Core.Utils ( -- * Constructing expressions@@ -66,8 +64,6 @@ dumpIdInfoOfProgram ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -96,8 +92,10 @@ import GHC.Core.TyCon import GHC.Core.Multiplicity import GHC.Types.Unique+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList )@@ -180,7 +178,7 @@ -- See GHC.Types.Var Note [AnonArgFlag] mkFunctionType mult arg_ty res_ty | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag]- = ASSERT(eqType mult Many)+ = assert (eqType mult Many) $ mkInvisFunTy mult arg_ty res_ty | otherwise@@ -305,9 +303,9 @@ -- identity coercions and coalescing nested coercions mkCast :: CoreExpr -> CoercionR -> CoreExpr mkCast e co- | ASSERT2( coercionRole co == Representational- , text "coercion" <+> ppr co <+> text "passed to mkCast"- <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )+ | assertPpr (coercionRole co == Representational)+ (text "coercion" <+> ppr co <+> text "passed to mkCast"+ <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co)) $ isReflCo co = e @@ -319,12 +317,12 @@ = Coercion (mkCoCast e_co co) mkCast (Cast expr co2) co- = WARN(let { from_ty = coercionLKind co;+ = warnPprTrace (let { from_ty = coercionLKind co; to_ty2 = coercionRKind co2 } in- not (from_ty `eqType` to_ty2),- vcat ([ text "expr:" <+> ppr expr+ not (from_ty `eqType` to_ty2))+ (vcat ([ text "expr:" <+> ppr expr , text "co2:" <+> ppr co2- , text "co:" <+> ppr co ]) )+ , text "co:" <+> ppr co ])) $ mkCast expr (mkTransCo co2 co) mkCast (Tick t expr) co@@ -332,11 +330,11 @@ mkCast expr co = let from_ty = coercionLKind co in- WARN( not (from_ty `eqType` exprType expr),- text "Trying to coerce" <+> text "(" <> ppr expr+ warnPprTrace (not (from_ty `eqType` exprType expr))+ (text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co)- $$ callStackDoc )+ $$ callStackDoc) $ (Cast expr co) -- | Wraps the given expression in the source annotation, dropping the@@ -614,8 +612,8 @@ -- | Extract the default case alternative findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))-findDefault (Alt DEFAULT args rhs : alts) = ASSERT( null args ) (alts, Just rhs)-findDefault alts = (alts, Nothing)+findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)+findDefault alts = (alts, Nothing) addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] addDefault alts Nothing = alts@@ -640,7 +638,7 @@ = case con `cmpAltCon` con1 of LT -> deflt -- Missed it already; the alts are in increasing order EQ -> Just alt- GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt+ GT -> assert (not (con1 == DEFAULT)) $ go alts deflt {- Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -695,8 +693,8 @@ -- We want to drop the leading type argument of the scrutinee -- leaving the arguments to match against the pattern -trimConArgs DEFAULT args = ASSERT( null args ) []-trimConArgs (LitAlt _) args = ASSERT( null args ) []+trimConArgs DEFAULT args = assert (null args) []+trimConArgs (LitAlt _) args = assert (null args) [] trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities)@@ -1613,11 +1611,9 @@ Var f -> app_ok primop_ok f args -- 'LitRubbish' is the only literal that can occur in the head of an -- application and will not be matched by the above case (Var /= Lit).- Lit LitRubbish{} -> True-#if defined(DEBUG)- Lit _ -> pprPanic "Non-rubbish lit in app head" (ppr other_expr)-#endif- _ -> False+ Lit LitRubbish{} -> True+ Lit _ | debugIsOn -> pprPanic "Non-rubbish lit in app head" (ppr other_expr)+ _ -> False ----------------------------- app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool@@ -2027,7 +2023,7 @@ -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us dataConInstPat fss uniqs mult con inst_tys- = ASSERT( univ_tvs `equalLength` inst_tys )+ = assert (univ_tvs `equalLength` inst_tys) $ (ex_bndrs, arg_ids) where univ_tvs = dataConUnivTyVars con
compiler/GHC/CoreToIface.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] -- | Functions for converting Core things to interface file things.@@ -44,8 +44,6 @@ , toIfaceLFInfo ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Ppr@@ -313,8 +311,7 @@ go_prov (PhantomProv co) = IfacePhantomProv (go co) go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) go_prov (PluginProv str) = IfacePluginProv str- go_prov CorePrepProv = pprPanic "toIfaceCoercionX" empty- -- CorePrepProv only happens after the iface file is generated+ go_prov (CorePrepProv b) = IfaceCorePrepProv b toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet@@ -369,7 +366,7 @@ -- This is probably a compiler bug, so we print a trace and -- carry on as if it were FunTy. Without the test for -- isEmptyTCvSubst we'd get an infinite loop (#15473)- WARN( True, ppr kind $$ ppr ty_args )+ warnPprTrace True (ppr kind $$ ppr ty_args) $ IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) tidyToIfaceType :: TidyEnv -> Type -> IfaceType@@ -632,15 +629,15 @@ LFReEntrant top_lvl arity no_fvs _arg_descr -> -- Exported LFReEntrant closures are top level, and top-level closures -- don't have free variables- ASSERT2(isTopLevel top_lvl, ppr nm)- ASSERT2(no_fvs, ppr nm)+ assertPpr (isTopLevel top_lvl) (ppr nm) $+ assertPpr no_fvs (ppr nm) $ IfLFReEntrant arity LFThunk top_lvl no_fvs updatable sfi mb_fun -> -- Exported LFThunk closures are top level (which don't have free -- variables) and non-standard (see cgTopRhsClosure)- ASSERT2(isTopLevel top_lvl, ppr nm)- ASSERT2(no_fvs, ppr nm)- ASSERT2(sfi == NonStandardThunk, ppr nm)+ assertPpr (isTopLevel top_lvl) (ppr nm) $+ assertPpr no_fvs (ppr nm) $+ assertPpr (sfi == NonStandardThunk) (ppr nm) $ IfLFThunk updatable mb_fun LFCon dc -> IfLFCon (dataConName dc)
compiler/GHC/Data/Bag.hs view
@@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor, TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, TypeFamilies #-} module GHC.Data.Bag ( Bag, -- abstract type
compiler/GHC/Data/FastString.hs view
@@ -1,7 +1,5 @@--- (c) The University of Glasgow, 1997-2006--{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-}@@ -112,7 +110,8 @@ lengthPS ) where -#include "GhclibHsVersions.h"+-- For GHC_STAGE+#include "ghcplatform.h" import GHC.Prelude as Prelude
compiler/GHC/Data/Graph/Directed.hs view
@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}@@ -26,8 +26,6 @@ -- Simple way to classify edges EdgeType(..), classifyEdges ) where--#include "GhclibHsVersions.h" ------------------------------------------------------------------------------ -- A version of the graph algorithms described in:
compiler/GHC/Data/IOEnv.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE PatternSynonyms #-} --
compiler/GHC/Data/List/SetOps.hs view
@@ -4,8 +4,8 @@ -} -{-# LANGUAGE CPP #-} + -- | Set-like operations on lists -- -- Avoid using them as much as possible@@ -23,8 +23,6 @@ getNth ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Utils.Outputable@@ -38,7 +36,7 @@ import qualified Data.Set as S getNth :: Outputable a => [a] -> Int -> a-getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )+getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $ xs !! n {-@@ -63,7 +61,7 @@ | isIn "unionLists" y xs = xs | otherwise = y:xs unionLists xs ys- = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys)+ = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) (ppr xs $$ ppr ys) $ [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys -- | Calculate the set difference of two lists. This is
compiler/GHC/Data/Maybe.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE KindSignatures #-}
compiler/GHC/Data/Pair.hs view
@@ -3,7 +3,7 @@ Traversable instances. -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} module GHC.Data.Pair@@ -15,8 +15,6 @@ , pLiftSnd ) where--#include "GhclibHsVersions.h" import GHC.Prelude
+ compiler/GHC/Data/Strict.hs view
@@ -0,0 +1,67 @@+-- Strict counterparts to common data structures,+-- e.g. tuples, lists, maybes, etc.+--+-- Import this module qualified as Strict.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}++module GHC.Data.Strict (+ Maybe(Nothing, Just),+ fromMaybe,+ Pair(And),++ -- Not used at the moment:+ --+ -- Either(Left, Right),+ -- List(Nil, Cons),+ ) where++import GHC.Prelude hiding (Maybe(..), Either(..))+import Control.Applicative+import Data.Semigroup+import Data.Data++data Maybe a = Nothing | Just !a+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)++fromMaybe :: a -> Maybe a -> a+fromMaybe d Nothing = d+fromMaybe _ (Just x) = x++apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b+apMaybe (Just f) (Just x) = Just (f x)+apMaybe _ _ = Nothing++altMaybe :: Maybe a -> Maybe a -> Maybe a+altMaybe Nothing r = r+altMaybe l _ = l++instance Semigroup a => Semigroup (Maybe a) where+ Nothing <> b = b+ a <> Nothing = a+ Just a <> Just b = Just (a <> b)++instance Semigroup a => Monoid (Maybe a) where+ mempty = Nothing++instance Applicative Maybe where+ pure = Just+ (<*>) = apMaybe++instance Alternative Maybe where+ empty = Nothing+ (<|>) = altMaybe++data Pair a b = !a `And` !b+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)++-- The definitions below are commented out because they are+-- not used anywhere in the compiler, but are useful to showcase+-- the intent behind this module (i.e. how it may evolve).+--+-- data Either a b = Left !a | Right !b+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)+--+-- data List a = Nil | !a `Cons` !(List a)+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
compiler/GHC/Data/StringBuffer.hs view
@@ -48,18 +48,15 @@ parseUnsignedInteger, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -import GHC.Utils.Encoding import GHC.Data.FastString+import GHC.Utils.Encoding import GHC.Utils.IO.Unsafe import GHC.Utils.Panic.Plain-import GHC.Utils.Misc+import GHC.Utils.Exception ( bracket_ ) import Data.Maybe-import Control.Exception import System.IO import System.IO.Unsafe ( unsafePerformIO ) import GHC.IO.Encoding.UTF8 ( mkUTF8 )@@ -150,7 +147,7 @@ if size > 0 && offset == 0 then do -- Validate assumption that handle is in binary mode.- ASSERTM( hGetEncoding h >>= return . isNothing )+ assertM (hGetEncoding h >>= return . isNothing) -- Temporarily select utf8 encoding with error ignoring, -- to make `hLookAhead` and `hGetChar` return full Unicode characters. bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do
compiler/GHC/Driver/CmdLine.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} -------------------------------------------------------------------------------@@ -23,13 +23,12 @@ EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc import GHC.Utils.Json@@ -224,7 +223,7 @@ = let dash_arg = '-' : arg rest_no_eq = dropEq rest in case opt_kind of- NoArg a -> ASSERT(null rest) Right (a, args)+ NoArg a -> assert (null rest) Right (a, args) HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) | otherwise -> case args of
compiler/GHC/Driver/Config.hs view
@@ -15,6 +15,7 @@ import GHC.Core.Coercion.Opt import GHC.Parser.Lexer import GHC.Runtime.Interpreter (BCOOpts(..))+import GHC.Utils.Error (mkPlainMsgEnvelope) import GHCi.Message (EvalOpts(..)) import GHC.Conc (getNumProcessors)@@ -39,6 +40,7 @@ mkParserOpts <$> warningFlags <*> extensionFlags+ <*> mkPlainMsgEnvelope <*> safeImportsOn <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream
compiler/GHC/Driver/Env.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Driver.Env ( Hsc(..) , HscEnv (..)@@ -8,12 +8,14 @@ , hsc_HPT , hscUpdateHPT , runHsc+ , runHsc' , mkInteractiveHscEnv , runInteractiveHsc , hscEPS , hscInterp , hptCompleteSigs- , hptInstances+ , hptAllInstances+ , hptInstancesBelow , hptAnns , hptAllThings , hptSomeThingsBelowUs@@ -25,13 +27,12 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Driver.Errors ( printOrThrowDiagnostics )+import GHC.Driver.Errors.Types ( GhcMessage ) import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types (Interp)@@ -52,7 +53,7 @@ import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import GHC.Types.CompleteMatch-import GHC.Types.Error ( emptyMessages )+import GHC.Types.Error ( emptyMessages, Messages ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.TyThing@@ -66,9 +67,10 @@ import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Types.Unique.FM -import Control.Monad ( guard ) import Data.IORef+import qualified Data.Set as Set runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do@@ -76,6 +78,9 @@ printOrThrowDiagnostics (hsc_logger hsc_env) (hsc_dflags hsc_env) w return a +runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)+runHsc' hsc_env (Hsc hsc) = hsc hsc_env emptyMessages+ -- | Switches in the DynFlags and Plugins from the InteractiveContext mkInteractiveHscEnv :: HscEnv -> HscEnv mkInteractiveHscEnv hsc_env =@@ -182,14 +187,28 @@ -- the Home Package Table filtered by the provided predicate function. -- Used in @tcRnImports@, to select the instances that are in the -- transitive closure of imports from the currently compiled module.-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])-hptInstances hsc_env want_this_module+hptAllInstances :: HscEnv -> ([ClsInst], [FamInst])+hptAllInstances hsc_env = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do- guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) let details = hm_details mod_info return (md_insts details, md_fam_insts details) in (concat insts, concat famInsts) +-- | Find instances visible from the given set of imports+hptInstancesBelow :: HscEnv -> ModuleName -> [ModuleNameWithIsBoot] -> ([ClsInst], [FamInst])+hptInstancesBelow hsc_env mn mns =+ let (insts, famInsts) =+ unzip $ hptSomeThingsBelowUs (\mod_info ->+ let details = hm_details mod_info+ -- Don't include instances for the current module+ in if moduleName (mi_module (hm_iface mod_info)) == mn+ then []+ else [(md_insts details, md_fam_insts details)])+ True -- Include -hi-boot+ hsc_env+ mns+ in (concat insts, concat famInsts)+ -- | Get rules from modules "below" this one (in the dependency sense) hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule] hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False@@ -203,10 +222,33 @@ hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) +hptModulesBelow :: HscEnv -> [ModuleNameWithIsBoot] -> Set.Set ModuleNameWithIsBoot+hptModulesBelow hsc_env mn = Set.fromList (eltsUFM $ go mn emptyUFM)+ where+ hpt = hsc_HPT hsc_env++ go [] seen = seen+ go (mn:mns) seen+ | Just mn' <- lookupUFM seen (gwib_mod mn)+ -- Already seen the module before+ , gwib_isBoot mn' == gwib_isBoot mn = go mns seen+ | otherwise =+ case lookupHpt hpt (gwib_mod mn) of+ -- Not a home module+ Nothing -> go mns seen+ Just hmi ->+ let+ comb m@(GWIB { gwib_isBoot = NotBoot }) _ = m+ comb (GWIB { gwib_isBoot = IsBoot }) x = x+ in+ go (dep_direct_mods (mi_deps (hm_iface hmi)) ++ mns)+ (addToUFM_C comb seen (gwib_mod mn) mn)++ -- | Get things from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]-hptSomeThingsBelowUs extract include_hi_boot hsc_env deps+hptSomeThingsBelowUs extract include_hi_boot hsc_env mod | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] | otherwise@@ -214,7 +256,7 @@ in [ thing | -- Find each non-hi-boot module below me- GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps+ GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- Set.toList (hptModulesBelow hsc_env mod) , include_hi_boot || (is_boot == NotBoot) -- unsavoury: when compiling the base package with --make, we@@ -245,7 +287,7 @@ -- Extract dependencies of the module if we are supplied one, -- otherwise load annotations from all home package table -- entries regardless of dependency ordering.- home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts+ home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_direct_mods . mg_deps) mb_guts other_pkg_anns = eps_ann_env eps ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, Just home_pkg_anns,@@ -263,7 +305,7 @@ let pte = eps_PTE eps hpt = hsc_HPT hsc_env - mod = ASSERT2( isExternalName name, ppr name )+ mod = assertPpr (isExternalName name) (ppr name) $ if isHoleName name then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name)) else nameModule name
compiler/GHC/Driver/Errors.hs view
@@ -9,12 +9,12 @@ import GHC.Driver.Errors.Types import GHC.Data.Bag import GHC.Prelude-import GHC.Parser.Errors ( PsError(..) )+import GHC.Parser.Errors.Types import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error-import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )+import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext, text, withPprStyle, mkErrStyle ) import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine @@ -23,12 +23,21 @@ = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style in putLogMsg logger dflags (MCDiagnostic sev . diagnosticReason $ dia) s $- withPprStyle style (formatBulleted ctx (diagnosticMessage dia))+ withPprStyle style (messageWithHints ctx dia) | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, errMsgSeverity = sev, errMsgContext = unqual } <- sortMsgBag (Just dflags) (getMessages msgs) ]+ where+ messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc+ messageWithHints ctx e =+ let main_msg = formatBulleted ctx $ diagnosticMessage e+ in case diagnosticHints e of+ [] -> main_msg+ [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)+ hs -> main_msg $$ hang (text "Suggested fixes:") 2+ (formatBulleted ctx . mkDecorated . map ppr $ hs) handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO () handleFlagWarnings logger dflags warns = do@@ -37,8 +46,7 @@ bag = listToBag [ mkPlainMsgEnvelope dflags loc $ GhcDriverMessage $ DriverUnknownMessage $- mkPlainDiagnostic reason $- text warn+ mkPlainDiagnostic reason noHints $ text warn | CmdLine.Warn reason (L loc warn) <- warns ] printOrThrowDiagnostics logger dflags (mkMessages bag)@@ -56,7 +64,5 @@ -- for dealing with parse errors when the driver is doing dependency analysis. -- Defined here to avoid module loops between GHC.Driver.Error.Types and -- GHC.Driver.Error.Ppr-mkDriverPsHeaderMessage :: PsError -> MsgEnvelope DriverMessage-mkDriverPsHeaderMessage ps_err- = mkPlainErrorMsgEnvelope (errLoc ps_err) $- DriverPsHeaderMessage (errDesc ps_err) (errHints ps_err)+mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage+mkDriverPsHeaderMessage = fmap DriverPsHeaderMessage
compiler/GHC/Driver/Errors/Ppr.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} @@ -5,12 +6,28 @@ import GHC.Prelude -import GHC.Types.Error import GHC.Driver.Errors.Types-import GHC.Parser.Errors.Ppr-import GHC.Tc.Errors.Ppr ()+import GHC.Driver.Flags+import GHC.Driver.Session import GHC.HsToCore.Errors.Ppr ()+import GHC.Parser.Errors.Ppr ()+import GHC.Tc.Errors.Ppr ()+import GHC.Types.Error+import GHC.Unit.Types+import GHC.Utils.Outputable+import GHC.Unit.Module+import GHC.Types.Hint +--+-- Suggestions+--++-- | Suggests a list of 'InstantiationSuggestion' for the '.hsig' file to the user.+suggestInstantiatedWith :: ModuleName -> GenInstantiations UnitId -> [InstantiationSuggestion]+suggestInstantiatedWith pi_mod_name insts =+ [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ]++ instance Diagnostic GhcMessage where diagnosticMessage = \case GhcPsMessage m@@ -36,10 +53,125 @@ GhcUnknownMessage m -> diagnosticReason m + diagnosticHints = \case+ GhcPsMessage m+ -> diagnosticHints m+ GhcTcRnMessage m+ -> diagnosticHints m+ GhcDsMessage m+ -> diagnosticHints m+ GhcDriverMessage m+ -> diagnosticHints m+ GhcUnknownMessage m+ -> diagnosticHints m+ instance Diagnostic DriverMessage where- diagnosticMessage (DriverUnknownMessage m) = diagnosticMessage m- diagnosticMessage (DriverPsHeaderMessage desc hints)- = mkSimpleDecorated $ pprPsError desc hints+ diagnosticMessage = \case+ DriverUnknownMessage m+ -> diagnosticMessage m+ DriverPsHeaderMessage m+ -> diagnosticMessage m+ DriverMissingHomeModules missing buildingCabalPackage+ -> let msg | buildingCabalPackage == YesBuildingCabalPackage+ = hang+ (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")+ 4+ (sep (map ppr missing))+ | otherwise+ =+ hang+ (text "Modules are not listed in command line but needed for compilation: ")+ 4+ (sep (map ppr missing))+ in mkSimpleDecorated msg+ DriverUnusedPackages unusedArgs+ -> let msg = vcat [ text "The following packages were specified" <+>+ text "via -package or -package-id flags,"+ , text "but were not needed for compilation:"+ , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs))+ ]+ in mkSimpleDecorated msg+ where+ withDash :: SDoc -> SDoc+ withDash = (<+>) (text "-") - diagnosticReason (DriverUnknownMessage m) = diagnosticReason m- diagnosticReason (DriverPsHeaderMessage {}) = ErrorWithoutFlag+ pprUnusedArg :: PackageArg -> SDoc+ pprUnusedArg (PackageArg str) = text str+ pprUnusedArg (UnitIdArg uid) = ppr uid+ DriverUnnecessarySourceImports mod+ -> mkSimpleDecorated (text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod))+ DriverDuplicatedModuleDeclaration mod files+ -> mkSimpleDecorated $+ text "module" <+> quotes (ppr mod) <+>+ text "is defined in multiple files:" <+>+ sep (map text files)+ DriverModuleNotFound mod+ -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally")+ DriverFileModuleNameMismatch actual expected+ -> mkSimpleDecorated $+ text "File name does not match module name:"+ $$ text "Saw :" <+> quotes (ppr actual)+ $$ text "Expected:" <+> quotes (ppr expected)++ DriverUnexpectedSignature pi_mod_name _buildingCabalPackage _instantiations+ -> mkSimpleDecorated $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name)+ DriverFileNotFound hsFilePath+ -> mkSimpleDecorated (text "Can't find" <+> text hsFilePath)+ DriverStaticPointersNotSupported+ -> mkSimpleDecorated (text "StaticPointers is not supported in GHCi interactive expressions.")+ DriverBackpackModuleNotFound modname+ -> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found")++ diagnosticReason = \case+ DriverUnknownMessage m+ -> diagnosticReason m+ DriverPsHeaderMessage {}+ -> ErrorWithoutFlag+ DriverMissingHomeModules{}+ -> WarningWithFlag Opt_WarnMissingHomeModules+ DriverUnusedPackages{}+ -> WarningWithFlag Opt_WarnUnusedPackages+ DriverUnnecessarySourceImports{}+ -> WarningWithFlag Opt_WarnUnusedImports+ DriverDuplicatedModuleDeclaration{}+ -> ErrorWithoutFlag+ DriverModuleNotFound{}+ -> ErrorWithoutFlag+ DriverFileModuleNameMismatch{}+ -> ErrorWithoutFlag+ DriverUnexpectedSignature{}+ -> ErrorWithoutFlag+ DriverFileNotFound{}+ -> ErrorWithoutFlag+ DriverStaticPointersNotSupported+ -> WarningWithoutFlag+ DriverBackpackModuleNotFound{}+ -> ErrorWithoutFlag++ diagnosticHints = \case+ DriverUnknownMessage m+ -> diagnosticHints m+ DriverPsHeaderMessage psMsg+ -> diagnosticHints psMsg+ DriverMissingHomeModules{}+ -> noHints+ DriverUnusedPackages{}+ -> noHints+ DriverUnnecessarySourceImports{}+ -> noHints+ DriverDuplicatedModuleDeclaration{}+ -> noHints+ DriverModuleNotFound{}+ -> noHints+ DriverFileModuleNameMismatch{}+ -> noHints+ DriverUnexpectedSignature pi_mod_name buildingCabalPackage instantiations+ -> if buildingCabalPackage == YesBuildingCabalPackage+ then [SuggestAddSignatureCabalFile pi_mod_name]+ else [SuggestSignatureInstantiations pi_mod_name (suggestInstantiatedWith pi_mod_name instantiations)]+ DriverFileNotFound{}+ -> noHints+ DriverStaticPointersNotSupported+ -> noHints+ DriverBackpackModuleNotFound{}+ -> noHints
compiler/GHC/Driver/Errors/Types.hs view
@@ -3,6 +3,7 @@ module GHC.Driver.Errors.Types ( GhcMessage(..) , DriverMessage(..), DriverMessages+ , BuildingCabalPackage(..) , WarningMessages , ErrorMessages , WarnMsg@@ -11,19 +12,21 @@ -- * Utility functions , hoistTcRnMessage , hoistDsMessage- , foldPsMessages+ , checkBuildingCabalPackage ) where import GHC.Prelude +import Data.Bifunctor import Data.Typeable++import GHC.Driver.Session import GHC.Types.Error+import GHC.Unit.Module -import GHC.Parser.Errors ( PsErrorDesc, PsHint ) import GHC.Parser.Errors.Types ( PsMessage ) import GHC.Tc.Errors.Types ( TcRnMessage ) import GHC.HsToCore.Errors.Types ( DsMessage )-import Data.Bifunctor -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity.@@ -87,14 +90,6 @@ ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage ghcUnknownMessage = GhcUnknownMessage --- | Given a collection of @e@ wrapped in a 'Foldable' structure, converts it--- into 'Messages' via the supplied transformation function.-foldPsMessages :: Foldable f- => (e -> MsgEnvelope PsMessage)- -> f e- -> Messages GhcMessage-foldPsMessages f = foldMap (singleMessage . fmap GhcPsMessage . f)- -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on -- the result of 'IO (Messages TcRnMessage, a)'. hoistTcRnMessage :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)@@ -105,16 +100,115 @@ hoistDsMessage :: Monad m => m (Messages DsMessage, a) -> m (Messages GhcMessage, a) hoistDsMessage = fmap (first (fmap GhcDsMessage)) +-- | A collection of driver messages+type DriverMessages = Messages DriverMessage+ -- | A message from the driver.-data DriverMessage- = DriverUnknownMessage !DiagnosticMessage- -- ^ Simply rewraps a generic 'DiagnosticMessage'. More- -- constructors will be added in the future (#18516).- | DriverPsHeaderMessage !PsErrorDesc ![PsHint]- -- ^ A parse error in parsing a Haskell file header during dependency+data DriverMessage where+ -- | Simply wraps a generic 'Diagnostic' message @a@.+ DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage+ -- | A parse error in parsing a Haskell file header during dependency -- analysis+ DriverPsHeaderMessage :: !PsMessage -> DriverMessage --- | A collection of driver messages-type DriverMessages = Messages DriverMessage+ {-| DriverMissingHomeModules is a warning (controlled with -Wmissing-home-modules) that+ arises when running GHC in --make mode when some modules needed for compilation+ are not included on the command line. For example, if A imports B, `ghc --make+ A.hs` will cause this warning, while `ghc --make A.hs B.hs` will not. --- | A message about Safe Haskell.+ Useful for cabal to ensure GHC won't pick up modules listed neither in+ 'exposed-modules' nor in 'other-modules'.++ Test case: warnings/should_compile/MissingMod++ -}+ DriverMissingHomeModules :: [ModuleName] -> !BuildingCabalPackage -> DriverMessage++ {-| DriverUnusedPackages occurs when when package is requested on command line,+ but was never needed during compilation. Activated by -Wunused-packages.++ Test cases: warnings/should_compile/UnusedPackages+ -}+ DriverUnusedPackages :: [PackageArg] -> DriverMessage++ {-| DriverUnnecessarySourceImports (controlled with -Wunused-imports) occurs if there+ are {-# SOURCE #-} imports which are not necessary. See 'warnUnnecessarySourceImports'+ in 'GHC.Driver.Make'.++ Test cases: warnings/should_compile/T10637+ -}+ DriverUnnecessarySourceImports :: !ModuleName -> DriverMessage++ {-| DriverDuplicatedModuleDeclaration occurs if a module 'A' is declared in+ multiple files.++ Test cases: None.+ -}+ DriverDuplicatedModuleDeclaration :: !Module -> [FilePath] -> DriverMessage++ {-| DriverModuleNotFound occurs if a module 'A' can't be found.++ Test cases: None.+ -}+ DriverModuleNotFound :: !ModuleName -> DriverMessage++ {-| DriverFileModuleNameMismatch occurs if a module 'A' is defined in a file with a different name.+ The first field is the name written in the source code; the second argument is the name extracted+ from the filename.++ Test cases: module/mod178, /driver/bug1677+ -}+ DriverFileModuleNameMismatch :: !ModuleName -> !ModuleName -> DriverMessage++ {-| DriverUnexpectedSignature occurs when GHC encounters a module 'A' that imports a signature+ file which is neither in the 'signatures' section of a '.cabal' file nor in any package in+ the home modules.++ Example:++ -- MyStr.hsig is defined, but not added to 'signatures' in the '.cabal' file.+ signature MyStr where+ data Str++ -- A.hs, which tries to import the signature.+ module A where+ import MyStr+++ Test cases: driver/T12955+ -}+ DriverUnexpectedSignature :: !ModuleName -> !BuildingCabalPackage -> GenInstantiations UnitId -> DriverMessage++ {-| DriverFileNotFound occurs when the input file (e.g. given on the command line) can't be found.++ Test cases: None.+ -}+ DriverFileNotFound :: !FilePath -> DriverMessage++ {-| DriverStaticPointersNotSupported occurs when the 'StaticPointers' extension is used+ in an interactive GHCi context.++ Test cases: ghci/scripts/StaticPtr+ -}+ DriverStaticPointersNotSupported :: DriverMessage++ {-| DriverBackpackModuleNotFound occurs when Backpack can't find a particular module+ during its dependency analysis.++ Test cases: -+ -}+ DriverBackpackModuleNotFound :: !ModuleName -> DriverMessage++-- | Pass to a 'DriverMessage' the information whether or not the+-- '-fbuilding-cabal-package' flag is set.+data BuildingCabalPackage+ = YesBuildingCabalPackage+ | NoBuildingCabalPackage+ deriving Eq++-- | Checks if we are building a cabal package by consulting the 'DynFlags'.+checkBuildingCabalPackage :: DynFlags -> BuildingCabalPackage+checkBuildingCabalPackage dflags =+ if gopt Opt_BuildingCabalPackage dflags+ then YesBuildingCabalPackage+ else NoBuildingCabalPackage
compiler/GHC/Driver/Flags.hs view
@@ -1,9 +1,21 @@ module GHC.Driver.Flags ( DumpFlag(..) , GeneralFlag(..)- , WarningFlag(..) , Language(..) , optimisationFlags++ -- * Warnings+ , WarningFlag(..)+ , warnFlagNames+ , warningGroups+ , warningHierarchies+ , smallestWarningGroups+ , standardWarnings+ , minusWOpts+ , minusWallOpts+ , minusWeverythingOpts+ , minusWcompatOpts+ , unusedBindsFlags ) where @@ -11,6 +23,17 @@ import GHC.Utils.Outputable import GHC.Data.EnumSet as EnumSet +import Control.Monad (guard)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe,mapMaybe)+++data Language = Haskell98 | Haskell2010 | GHC2021+ deriving (Eq, Enum, Show, Bounded)++instance Outputable Language where+ ppr = text . show+ -- | Debugging flags data DumpFlag -- See Note [Updating flag description in the User's Guide]@@ -511,10 +534,255 @@ | Opt_WarnAmbiguousFields -- Since 9.2 | Opt_WarnImplicitLift -- Since 9.2 | Opt_WarnMissingKindSignatures -- Since 9.2+ | Opt_WarnMissingExportedPatternSynonymSignatures -- since 9.2 deriving (Eq, Show, Enum) -data Language = Haskell98 | Haskell2010 | GHC2021- deriving (Eq, Enum, Show, Bounded)+-- | Return the names of a WarningFlag+--+-- One flag may have several names because of US/UK spelling. The first one is+-- the "preferred one" that will be displayed in warning messages.+warnFlagNames :: WarningFlag -> NonEmpty String+warnFlagNames wflag = case wflag of+ Opt_WarnAlternativeLayoutRuleTransitional -> "alternative-layout-rule-transitional" :| []+ Opt_WarnAmbiguousFields -> "ambiguous-fields" :| []+ Opt_WarnAutoOrphans -> "auto-orphans" :| []+ Opt_WarnCPPUndef -> "cpp-undef" :| []+ Opt_WarnUnbangedStrictPatterns -> "unbanged-strict-patterns" :| []+ Opt_WarnDeferredTypeErrors -> "deferred-type-errors" :| []+ Opt_WarnDeferredOutOfScopeVariables -> "deferred-out-of-scope-variables" :| []+ Opt_WarnWarningsDeprecations -> "deprecations" :| ["warnings-deprecations"]+ Opt_WarnDeprecatedFlags -> "deprecated-flags" :| []+ Opt_WarnDerivingDefaults -> "deriving-defaults" :| []+ Opt_WarnDerivingTypeable -> "deriving-typeable" :| []+ Opt_WarnDodgyExports -> "dodgy-exports" :| []+ Opt_WarnDodgyForeignImports -> "dodgy-foreign-imports" :| []+ Opt_WarnDodgyImports -> "dodgy-imports" :| []+ Opt_WarnEmptyEnumerations -> "empty-enumerations" :| []+ Opt_WarnDuplicateConstraints -> "duplicate-constraints" :| []+ Opt_WarnRedundantConstraints -> "redundant-constraints" :| []+ Opt_WarnDuplicateExports -> "duplicate-exports" :| []+ Opt_WarnHiShadows -> "hi-shadowing" :| []+ Opt_WarnInaccessibleCode -> "inaccessible-code" :| []+ Opt_WarnImplicitPrelude -> "implicit-prelude" :| []+ Opt_WarnImplicitKindVars -> "implicit-kind-vars" :| []+ Opt_WarnIncompletePatterns -> "incomplete-patterns" :| []+ Opt_WarnIncompletePatternsRecUpd -> "incomplete-record-updates" :| []+ Opt_WarnIncompleteUniPatterns -> "incomplete-uni-patterns" :| []+ Opt_WarnInlineRuleShadowing -> "inline-rule-shadowing" :| []+ Opt_WarnIdentities -> "identities" :| []+ Opt_WarnMissingFields -> "missing-fields" :| []+ Opt_WarnMissingImportList -> "missing-import-lists" :| []+ Opt_WarnMissingExportList -> "missing-export-lists" :| []+ Opt_WarnMissingLocalSignatures -> "missing-local-signatures" :| []+ Opt_WarnMissingMethods -> "missing-methods" :| []+ Opt_WarnMissingMonadFailInstances -> "missing-monadfail-instances" :| []+ Opt_WarnSemigroup -> "semigroup" :| []+ Opt_WarnMissingSignatures -> "missing-signatures" :| []+ Opt_WarnMissingKindSignatures -> "missing-kind-signatures" :| []+ Opt_WarnMissingExportedSignatures -> "missing-exported-signatures" :| []+ Opt_WarnMonomorphism -> "monomorphism-restriction" :| []+ Opt_WarnNameShadowing -> "name-shadowing" :| []+ Opt_WarnNonCanonicalMonadInstances -> "noncanonical-monad-instances" :| []+ Opt_WarnNonCanonicalMonadFailInstances -> "noncanonical-monadfail-instances" :| []+ Opt_WarnNonCanonicalMonoidInstances -> "noncanonical-monoid-instances" :| []+ Opt_WarnOrphans -> "orphans" :| []+ Opt_WarnOverflowedLiterals -> "overflowed-literals" :| []+ Opt_WarnOverlappingPatterns -> "overlapping-patterns" :| []+ Opt_WarnMissedSpecs -> "missed-specialisations" :| ["missed-specializations"]+ Opt_WarnAllMissedSpecs -> "all-missed-specialisations" :| ["all-missed-specializations"]+ Opt_WarnSafe -> "safe" :| []+ Opt_WarnTrustworthySafe -> "trustworthy-safe" :| []+ Opt_WarnInferredSafeImports -> "inferred-safe-imports" :| []+ Opt_WarnMissingSafeHaskellMode -> "missing-safe-haskell-mode" :| []+ Opt_WarnTabs -> "tabs" :| []+ Opt_WarnTypeDefaults -> "type-defaults" :| []+ Opt_WarnTypedHoles -> "typed-holes" :| []+ Opt_WarnPartialTypeSignatures -> "partial-type-signatures" :| []+ Opt_WarnUnrecognisedPragmas -> "unrecognised-pragmas" :| []+ Opt_WarnUnsafe -> "unsafe" :| []+ Opt_WarnUnsupportedCallingConventions -> "unsupported-calling-conventions" :| []+ Opt_WarnUnsupportedLlvmVersion -> "unsupported-llvm-version" :| []+ Opt_WarnMissedExtraSharedLib -> "missed-extra-shared-lib" :| []+ Opt_WarnUntickedPromotedConstructors -> "unticked-promoted-constructors" :| []+ Opt_WarnUnusedDoBind -> "unused-do-bind" :| []+ Opt_WarnUnusedForalls -> "unused-foralls" :| []+ Opt_WarnUnusedImports -> "unused-imports" :| []+ Opt_WarnUnusedLocalBinds -> "unused-local-binds" :| []+ Opt_WarnUnusedMatches -> "unused-matches" :| []+ Opt_WarnUnusedPatternBinds -> "unused-pattern-binds" :| []+ Opt_WarnUnusedTopBinds -> "unused-top-binds" :| []+ Opt_WarnUnusedTypePatterns -> "unused-type-patterns" :| []+ Opt_WarnUnusedRecordWildcards -> "unused-record-wildcards" :| []+ Opt_WarnRedundantBangPatterns -> "redundant-bang-patterns" :| []+ Opt_WarnRedundantRecordWildcards -> "redundant-record-wildcards" :| []+ Opt_WarnWrongDoBind -> "wrong-do-bind" :| []+ Opt_WarnMissingPatternSynonymSignatures -> "missing-pattern-synonym-signatures" :| []+ Opt_WarnMissingDerivingStrategies -> "missing-deriving-strategies" :| []+ Opt_WarnSimplifiableClassConstraints -> "simplifiable-class-constraints" :| []+ Opt_WarnMissingHomeModules -> "missing-home-modules" :| []+ Opt_WarnUnrecognisedWarningFlags -> "unrecognised-warning-flags" :| []+ Opt_WarnStarBinder -> "star-binder" :| []+ Opt_WarnStarIsType -> "star-is-type" :| []+ Opt_WarnSpaceAfterBang -> "missing-space-after-bang" :| []+ Opt_WarnPartialFields -> "partial-fields" :| []+ Opt_WarnPrepositiveQualifiedModule -> "prepositive-qualified-module" :| []+ Opt_WarnUnusedPackages -> "unused-packages" :| []+ Opt_WarnCompatUnqualifiedImports -> "compat-unqualified-imports" :| []+ Opt_WarnInvalidHaddock -> "invalid-haddock" :| []+ Opt_WarnOperatorWhitespaceExtConflict -> "operator-whitespace-ext-conflict" :| []+ Opt_WarnOperatorWhitespace -> "operator-whitespace" :| []+ Opt_WarnImplicitLift -> "implicit-lift" :| []+ Opt_WarnMissingExportedPatternSynonymSignatures -> "missing-exported-pattern-synonym-signatures" :| [] -instance Outputable Language where- ppr = text . show+-- -----------------------------------------------------------------------------+-- Standard sets of warning options++-- Note [Documenting warning flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of warning enabled by default+-- please remember to update the User's Guide. The relevant file is:+--+-- docs/users_guide/using-warnings.rst++-- | Warning groups.+--+-- As all warnings are in the Weverything set, it is ignored when+-- displaying to the user which group a warning is in.+warningGroups :: [(String, [WarningFlag])]+warningGroups =+ [ ("compat", minusWcompatOpts)+ , ("unused-binds", unusedBindsFlags)+ , ("default", standardWarnings)+ , ("extra", minusWOpts)+ , ("all", minusWallOpts)+ , ("everything", minusWeverythingOpts)+ ]++-- | Warning group hierarchies, where there is an explicit inclusion+-- relation.+--+-- Each inner list is a hierarchy of warning groups, ordered from+-- smallest to largest, where each group is a superset of the one+-- before it.+--+-- Separating this from 'warningGroups' allows for multiple+-- hierarchies with no inherent relation to be defined.+--+-- The special-case Weverything group is not included.+warningHierarchies :: [[String]]+warningHierarchies = hierarchies ++ map (:[]) rest+ where+ hierarchies = [["default", "extra", "all"]]+ rest = filter (`notElem` "everything" : concat hierarchies) $+ map fst warningGroups++-- | Find the smallest group in every hierarchy which a warning+-- belongs to, excluding Weverything.+smallestWarningGroups :: WarningFlag -> [String]+smallestWarningGroups flag = mapMaybe go warningHierarchies where+ -- Because each hierarchy is arranged from smallest to largest,+ -- the first group we find in a hierarchy which contains the flag+ -- is the smallest.+ go (group:rest) = fromMaybe (go rest) $ do+ flags <- lookup group warningGroups+ guard (flag `elem` flags)+ pure (Just group)+ go [] = Nothing++-- | Warnings enabled unless specified otherwise+standardWarnings :: [WarningFlag]+standardWarnings -- see Note [Documenting warning flags]+ = [ Opt_WarnOverlappingPatterns,+ Opt_WarnWarningsDeprecations,+ Opt_WarnDeprecatedFlags,+ Opt_WarnDeferredTypeErrors,+ Opt_WarnTypedHoles,+ Opt_WarnDeferredOutOfScopeVariables,+ Opt_WarnPartialTypeSignatures,+ Opt_WarnUnrecognisedPragmas,+ Opt_WarnDuplicateExports,+ Opt_WarnDerivingDefaults,+ Opt_WarnOverflowedLiterals,+ Opt_WarnEmptyEnumerations,+ Opt_WarnAmbiguousFields,+ Opt_WarnMissingFields,+ Opt_WarnMissingMethods,+ Opt_WarnWrongDoBind,+ Opt_WarnUnsupportedCallingConventions,+ Opt_WarnDodgyForeignImports,+ Opt_WarnInlineRuleShadowing,+ Opt_WarnAlternativeLayoutRuleTransitional,+ Opt_WarnUnsupportedLlvmVersion,+ Opt_WarnMissedExtraSharedLib,+ Opt_WarnTabs,+ Opt_WarnUnrecognisedWarningFlags,+ Opt_WarnSimplifiableClassConstraints,+ Opt_WarnStarBinder,+ Opt_WarnInaccessibleCode,+ Opt_WarnSpaceAfterBang,+ Opt_WarnNonCanonicalMonadInstances,+ Opt_WarnNonCanonicalMonoidInstances,+ Opt_WarnOperatorWhitespaceExtConflict+ ]++-- | Things you get with -W+minusWOpts :: [WarningFlag]+minusWOpts+ = standardWarnings +++ [ Opt_WarnUnusedTopBinds,+ Opt_WarnUnusedLocalBinds,+ Opt_WarnUnusedPatternBinds,+ Opt_WarnUnusedMatches,+ Opt_WarnUnusedForalls,+ Opt_WarnUnusedImports,+ Opt_WarnIncompletePatterns,+ Opt_WarnDodgyExports,+ Opt_WarnDodgyImports,+ Opt_WarnUnbangedStrictPatterns+ ]++-- | Things you get with -Wall+minusWallOpts :: [WarningFlag]+minusWallOpts+ = minusWOpts +++ [ Opt_WarnTypeDefaults,+ Opt_WarnNameShadowing,+ Opt_WarnMissingSignatures,+ Opt_WarnHiShadows,+ Opt_WarnOrphans,+ Opt_WarnUnusedDoBind,+ Opt_WarnTrustworthySafe,+ Opt_WarnUntickedPromotedConstructors,+ Opt_WarnMissingPatternSynonymSignatures,+ Opt_WarnUnusedRecordWildcards,+ Opt_WarnRedundantRecordWildcards,+ Opt_WarnStarIsType,+ Opt_WarnIncompleteUniPatterns,+ Opt_WarnIncompletePatternsRecUpd+ ]++-- | Things you get with -Weverything, i.e. *all* known warnings flags+minusWeverythingOpts :: [WarningFlag]+minusWeverythingOpts = [ toEnum 0 .. ]++-- | Things you get with -Wcompat.+--+-- This is intended to group together warnings that will be enabled by default+-- at some point in the future, so that library authors eager to make their+-- code future compatible to fix issues before they even generate warnings.+minusWcompatOpts :: [WarningFlag]+minusWcompatOpts+ = [ Opt_WarnSemigroup+ , Opt_WarnNonCanonicalMonoidInstances+ , Opt_WarnStarIsType+ , Opt_WarnCompatUnqualifiedImports+ ]++-- | Things you get with -Wunused-binds+unusedBindsFlags :: [WarningFlag]+unusedBindsFlags = [ Opt_WarnUnusedTopBinds+ , Opt_WarnUnusedLocalBinds+ , Opt_WarnUnusedPatternBinds+ ]+
compiler/GHC/Driver/Hooks.hs view
@@ -3,7 +3,7 @@ -- NB: this module is SOURCE-imported by DynFlags, and should primarily -- refer to *types*, rather than *code* -{-# LANGUAGE CPP, RankNTypes, TypeFamilies #-}+{-# LANGUAGE RankNTypes, TypeFamilies #-} module GHC.Driver.Hooks ( Hooks
compiler/GHC/Driver/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveFunctor, DerivingVia, RankNTypes #-}+{-# LANGUAGE DeriveFunctor, DerivingVia, RankNTypes #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- --
compiler/GHC/Driver/Phases.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- -- GHC Driver@@ -37,8 +37,6 @@ phaseForeignLanguage ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Driver/Pipeline/Monad.hs view
@@ -4,15 +4,16 @@ -- Defined in separate module so that it can safely be imported from Hooks module GHC.Driver.Pipeline.Monad ( CompPipeline(..), evalP- , PhasePlus(..)+ , PhasePlus(..), HscBackendAction (..) , PipeEnv(..), PipeState(..), PipelineOutput(..) , getPipeEnv, getPipeState, getPipeSession , setDynFlags, setModLocation, setForeignOs, setIface- , pipeStateDynFlags, pipeStateModIface, setPlugins+ , pipeStateDynFlags, pipeStateModIface, pipeStateLinkable, setPlugins, setLinkable ) where import GHC.Prelude +import GHC.Utils.Fingerprint import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Logger@@ -22,14 +23,21 @@ import GHC.Driver.Env import GHC.Driver.Plugins +import GHC.Linker.Types+ import GHC.Utils.TmpFs (TempFileLifetime) -import GHC.Types.SourceFile+import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Status +import GHC.Driver.Errors.Types ( GhcMessage )++import GHC.Tc.Types+ import Control.Monad newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }@@ -50,11 +58,17 @@ liftIO m = P $ \_env state -> do a <- m; return (state, a) data PhasePlus = RealPhase Phase- | HscOut HscSource ModuleName HscStatus+ -- | Runs the pipeline post typechecking, till the end+ | HscPostTc ModSummary FrontendResult (Messages GhcMessage) (Maybe Fingerprint)+ -- | The backend phase runs the code-gen. This may be run twice in+ -- the case of -dynamic-too+ | HscBackend ModSummary HscBackendAction + instance Outputable PhasePlus where ppr (RealPhase p) = ppr p- ppr (HscOut {}) = text "HscOut"+ ppr (HscPostTc {}) = text "HscPostTc"+ ppr (HscBackend {}) = text "HscBackend" -- ----------------------------------------------------------------------------- -- The pipeline uses a monad to carry around various bits of information@@ -81,9 +95,11 @@ -- ^ additional object files resulting from compiling foreign -- code. They come from two sources: foreign stubs, and -- add{C,Cxx,Objc,Objcxx}File from template haskell- iface :: Maybe ModIface- -- ^ Interface generated by HscOut phase. Only available after the+ iface :: Maybe ModIface,+ -- ^ Interface generated by HscBackend phase. Only available after the -- phase runs.+ maybe_linkable :: Maybe Linkable+ -- ^ Linkable generated by HscBackend phase, for the Interpreter backend. } pipeStateDynFlags :: PipeState -> DynFlags@@ -92,6 +108,9 @@ pipeStateModIface :: PipeState -> Maybe ModIface pipeStateModIface = iface +pipeStateLinkable :: PipeState -> Maybe Linkable+pipeStateLinkable = maybe_linkable+ data PipelineOutput = Temporary TempFileLifetime -- ^ Output should be to a temporary file: we're going to@@ -104,6 +123,8 @@ -- ^ The output must go into the specific outputFile in DynFlags. -- We don't store the filename in the constructor as it changes -- when doing -dynamic-too.+ | NoOutputFile+ -- ^ No output should be created, like in Interpreter or NoBackend. deriving Show getPipeEnv :: CompPipeline PipeEnv@@ -140,3 +161,6 @@ setIface :: ModIface -> CompPipeline () setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ())++setLinkable :: Linkable -> CompPipeline ()+setLinkable l = P $ \_env state -> return (state{ maybe_linkable = Just l }, ())
compiler/GHC/Driver/Plugins.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}+ -- | Definitions for writing /plugins/ for GHC. Plugins can hook into -- several areas of the compiler. See the 'Plugin' type. These plugins
compiler/GHC/Driver/Ppr.hs view
@@ -28,6 +28,7 @@ import {-# SOURCE #-} GHC.Unit.State import GHC.Utils.Exception+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -123,16 +124,12 @@ pprSTrace :: HasCallStack => SDoc -> a -> a pprSTrace doc = pprTrace "" (doc $$ callStackDoc) -warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a--- ^ Just warn about an assertion failure, recording the given file and line number.--- Should typically be accessed with the WARN macros-warnPprTrace _ _ _ _ x | not debugIsOn = x-warnPprTrace _ _file _line _msg x- | unsafeHasNoDebugOutput = x-warnPprTrace False _file _line _msg x = x-warnPprTrace True file line msg x- = pprDebugAndThen defaultSDocContext trace heading+-- | Just warn about an assertion failure, recording the given file and line number.+warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a+warnPprTrace _ _ x | not debugIsOn = x+warnPprTrace _ _msg x | unsafeHasNoDebugOutput = x+warnPprTrace False _msg x = x+warnPprTrace True msg x+ = pprDebugAndThen defaultSDocContext trace (text "WARNING:") (msg $$ callStackDoc ) x- where- heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
compiler/GHC/Driver/Ppr.hs-boot view
@@ -6,4 +6,4 @@ import {-# SOURCE #-} GHC.Utils.Outputable showSDoc :: DynFlags -> SDoc -> String-warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a+warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
compiler/GHC/Driver/Session.hs view
@@ -28,7 +28,6 @@ FatalMessager, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags,- warningGroups, warningHierarchies, hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, dopt, dopt_set, dopt_unset, gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',@@ -64,7 +63,6 @@ setFlagsFromEnvFile, pprDynFlagsDiff, flagSpecOf,- smallestGroups, targetProfile, @@ -154,6 +152,7 @@ defaultFatalMessager, defaultFlushOut, defaultFlushErr,+ setOutputFile, setDynOutputFile, setOutputHi, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags,@@ -212,13 +211,12 @@ -- * Include specifications IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+ addImplicitQuoteInclude, -- * SDoc initSDocContext, initDefaultSDocContext, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform@@ -241,6 +239,7 @@ import GHC.Utils.Panic import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Utils.Monad@@ -270,6 +269,7 @@ import Data.Ord import Data.Char import Data.List (intercalate, sortBy)+import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import System.FilePath import System.Directory@@ -366,6 +366,8 @@ data IncludeSpecs = IncludeSpecs { includePathsQuote :: [String] , includePathsGlobal :: [String]+ -- | See note [Implicit include paths]+ , includePathsQuoteImplicit :: [String] } deriving Show @@ -382,11 +384,38 @@ addQuoteInclude spec paths = let f = includePathsQuote spec in spec { includePathsQuote = f ++ paths } +-- | These includes are not considered while fingerprinting the flags for iface+-- | See note [Implicit include paths]+addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addImplicitQuoteInclude spec paths = let f = includePathsQuoteImplicit spec+ in spec { includePathsQuoteImplicit = f ++ paths }++ -- | Concatenate and flatten the list of global and quoted includes returning -- just a flat list of paths. flattenIncludes :: IncludeSpecs -> [String]-flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs+flattenIncludes specs =+ includePathsQuote specs +++ includePathsQuoteImplicit specs +++ includePathsGlobal specs +{- Note [Implicit include paths]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ The compile driver adds the path to the folder containing the source file being+ compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags'+ that are used later to compute the interface file. Because of this,+ the flags fingerprint derived from these 'DynFlags' and recorded in the+ interface file will end up containing the absolute path to the source folder.++ Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)+ store the build artifacts produced by a build BA for reuse in subsequent builds.++ Embedding source paths in interface fingerprints will thwart these attemps and+ lead to unnecessary recompilations when the source paths in BA differ from the+ source paths in subsequent builds.+ -}++ -- | Contains not only a collection of 'GeneralFlag's but also a plethora of -- information relating to the compilation of a single file or GHC session data DynFlags = DynFlags {@@ -593,6 +622,7 @@ -- them. thOnLoc :: SrcSpan, newDerivOnLoc :: SrcSpan,+ deriveViaOnLoc :: SrcSpan, overlapInstLoc :: SrcSpan, incoherentOnLoc :: SrcSpan, pkgTrustOnLoc :: SrcSpan,@@ -655,9 +685,12 @@ -- | Run-time linker information (what options we need, etc.) rtldInfo :: IORef (Maybe LinkerInfo), - -- | Run-time compiler information+ -- | Run-time C compiler information rtccInfo :: IORef (Maybe CompilerInfo), + -- | Run-time assembler information+ rtasmInfo :: IORef (Maybe CompilerInfo),+ -- Constants used to control the amount of optimization done. -- | Max size, in bytes, of inline array allocations.@@ -1048,6 +1081,7 @@ refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo) refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing+ refRtasmInfo <- newIORef Nothing canUseUnicode <- do let enc = localeEncoding str = "‘’" (withCString enc str $ \cstr ->@@ -1070,7 +1104,8 @@ canUseColor = stderrSupportsAnsiColors, colScheme = colScheme', rtldInfo = refRtldInfo,- rtccInfo = refRtccInfo+ rtccInfo = refRtccInfo,+ rtasmInfo = refRtasmInfo } -- | The normal 'DynFlags'. Note that they are not suitable for use in this form@@ -1153,7 +1188,7 @@ dumpPrefix = Nothing, dumpPrefixForce = Nothing, ldInputs = [],- includePaths = IncludeSpecs [] [],+ includePaths = IncludeSpecs [] [] [], libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [],@@ -1202,6 +1237,7 @@ safeInferred = True, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan,+ deriveViaOnLoc = noSrcSpan, overlapInstLoc = noSrcSpan, incoherentOnLoc = noSrcSpan, pkgTrustOnLoc = noSrcSpan,@@ -1237,6 +1273,7 @@ avx512pf = False, rtldInfo = panic "defaultDynFlags: no rtldInfo", rtccInfo = panic "defaultDynFlags: no rtccInfo",+ rtasmInfo = panic "defaultDynFlags: no rtasmInfo", maxInlineAllocSize = 128, maxInlineMemcpyInsns = 32,@@ -1620,6 +1657,9 @@ unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, xopt LangExt.GeneralizedNewtypeDeriving, flip xopt_unset LangExt.GeneralizedNewtypeDeriving)+ , ("-XDerivingVia", deriveViaOnLoc,+ xopt LangExt.DerivingVia,+ flip xopt_unset LangExt.DerivingVia) , ("-XTemplateHaskell", thOnLoc, xopt LangExt.TemplateHaskell, flip xopt_unset LangExt.TemplateHaskell)@@ -2963,6 +3003,17 @@ -> (Deprecation, FlagSpec flag) flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) +-- | Define a warning flag.+warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec flag = warnSpec' flag nop++-- | Define a warning flag with an effect.+warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ())+ -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes)+ | name <- NE.toList (warnFlagNames flag)+ ]+ -- | Define a new deprecated flag with an effect. depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String -> (Deprecation, FlagSpec flag)@@ -2974,6 +3025,19 @@ -> (Deprecation, FlagSpec flag) depFlagSpec name flag dep = depFlagSpecOp name flag nop dep +-- | Define a deprecated warning flag.+depWarnSpec :: WarningFlag -> String+ -> [(Deprecation, FlagSpec WarningFlag)]+depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep+ | name <- NE.toList (warnFlagNames flag)+ ]++-- | Define a deprecated warning name substituted by another.+subWarnSpec :: String -> WarningFlag -> String+ -> [(Deprecation, FlagSpec WarningFlag)]+subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ]++ -- | Define a new deprecated flag with an effect where the deprecation message -- depends on the flag value depFlagSpecOp' :: String@@ -3075,121 +3139,113 @@ wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]-wWarningFlagsDeps = [+wWarningFlagsDeps = mconcat [ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically- flagSpec "alternative-layout-rule-transitional"- Opt_WarnAlternativeLayoutRuleTransitional,- flagSpec "ambiguous-fields" Opt_WarnAmbiguousFields,- depFlagSpec "auto-orphans" Opt_WarnAutoOrphans- "it has no effect",- flagSpec "cpp-undef" Opt_WarnCPPUndef,- flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns,- flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors,- flagSpec "deferred-out-of-scope-variables"- Opt_WarnDeferredOutOfScopeVariables,- flagSpec "deprecations" Opt_WarnWarningsDeprecations,- flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags,- flagSpec "deriving-defaults" Opt_WarnDerivingDefaults,- flagSpec "deriving-typeable" Opt_WarnDerivingTypeable,- flagSpec "dodgy-exports" Opt_WarnDodgyExports,- flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports,- flagSpec "dodgy-imports" Opt_WarnDodgyImports,- flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations,- depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints- "it is subsumed by -Wredundant-constraints",- flagSpec "redundant-constraints" Opt_WarnRedundantConstraints,- flagSpec "duplicate-exports" Opt_WarnDuplicateExports,- depFlagSpec "hi-shadowing" Opt_WarnHiShadows- "it is not used, and was never implemented",- flagSpec "inaccessible-code" Opt_WarnInaccessibleCode,- flagSpec "implicit-prelude" Opt_WarnImplicitPrelude,- depFlagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars- "it is now an error",- flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns,- flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd,- flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns,- flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing,- flagSpec "identities" Opt_WarnIdentities,- flagSpec "missing-fields" Opt_WarnMissingFields,- flagSpec "missing-import-lists" Opt_WarnMissingImportList,- flagSpec "missing-export-lists" Opt_WarnMissingExportList,- depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures- "it is replaced by -Wmissing-local-signatures",- flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures,- flagSpec "missing-methods" Opt_WarnMissingMethods,- flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances,- flagSpec "semigroup" Opt_WarnSemigroup,- flagSpec "missing-signatures" Opt_WarnMissingSignatures,- flagSpec "missing-kind-signatures" Opt_WarnMissingKindSignatures,- depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures- "it is replaced by -Wmissing-exported-signatures",- flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures,- flagSpec "monomorphism-restriction" Opt_WarnMonomorphism,- flagSpec "name-shadowing" Opt_WarnNameShadowing,- flagSpec "noncanonical-monad-instances"- Opt_WarnNonCanonicalMonadInstances,- depFlagSpec "noncanonical-monadfail-instances"- Opt_WarnNonCanonicalMonadInstances- "fail is no longer a method of Monad",- flagSpec "noncanonical-monoid-instances"- Opt_WarnNonCanonicalMonoidInstances,- flagSpec "orphans" Opt_WarnOrphans,- flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals,- flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns,- flagSpec "missed-specialisations" Opt_WarnMissedSpecs,- flagSpec "missed-specializations" Opt_WarnMissedSpecs,- flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs,- flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs,- flagSpec' "safe" Opt_WarnSafe setWarnSafe,- flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe,- flagSpec "inferred-safe-imports" Opt_WarnInferredSafeImports,- flagSpec "missing-safe-haskell-mode" Opt_WarnMissingSafeHaskellMode,- flagSpec "tabs" Opt_WarnTabs,- flagSpec "type-defaults" Opt_WarnTypeDefaults,- flagSpec "typed-holes" Opt_WarnTypedHoles,- flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures,- flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas,- flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe,- flagSpec "unsupported-calling-conventions"- Opt_WarnUnsupportedCallingConventions,- flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion,- flagSpec "missed-extra-shared-lib" Opt_WarnMissedExtraSharedLib,- flagSpec "unticked-promoted-constructors"- Opt_WarnUntickedPromotedConstructors,- flagSpec "unused-do-bind" Opt_WarnUnusedDoBind,- flagSpec "unused-foralls" Opt_WarnUnusedForalls,- flagSpec "unused-imports" Opt_WarnUnusedImports,- flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds,- flagSpec "unused-matches" Opt_WarnUnusedMatches,- flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds,- flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds,- flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns,- flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards,- flagSpec "redundant-bang-patterns" Opt_WarnRedundantBangPatterns,- flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards,- flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations,- flagSpec "wrong-do-bind" Opt_WarnWrongDoBind,- flagSpec "missing-pattern-synonym-signatures"- Opt_WarnMissingPatternSynonymSignatures,- flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies,- flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,- flagSpec "missing-home-modules" Opt_WarnMissingHomeModules,- flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags,- flagSpec "star-binder" Opt_WarnStarBinder,- flagSpec "star-is-type" Opt_WarnStarIsType,- depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang- "bang patterns can no longer be written with a space",- flagSpec "partial-fields" Opt_WarnPartialFields,- flagSpec "prepositive-qualified-module"- Opt_WarnPrepositiveQualifiedModule,- flagSpec "unused-packages" Opt_WarnUnusedPackages,- flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports,- flagSpec "invalid-haddock" Opt_WarnInvalidHaddock,- flagSpec "operator-whitespace-ext-conflict" Opt_WarnOperatorWhitespaceExtConflict,- flagSpec "operator-whitespace" Opt_WarnOperatorWhitespace,- flagSpec "implicit-lift" Opt_WarnImplicitLift+ warnSpec Opt_WarnAlternativeLayoutRuleTransitional,+ warnSpec Opt_WarnAmbiguousFields,+ depWarnSpec Opt_WarnAutoOrphans+ "it has no effect",+ warnSpec Opt_WarnCPPUndef,+ warnSpec Opt_WarnUnbangedStrictPatterns,+ warnSpec Opt_WarnDeferredTypeErrors,+ warnSpec Opt_WarnDeferredOutOfScopeVariables,+ warnSpec Opt_WarnWarningsDeprecations,+ warnSpec Opt_WarnDeprecatedFlags,+ warnSpec Opt_WarnDerivingDefaults,+ warnSpec Opt_WarnDerivingTypeable,+ warnSpec Opt_WarnDodgyExports,+ warnSpec Opt_WarnDodgyForeignImports,+ warnSpec Opt_WarnDodgyImports,+ warnSpec Opt_WarnEmptyEnumerations,+ subWarnSpec "duplicate-constraints"+ Opt_WarnDuplicateConstraints+ "it is subsumed by -Wredundant-constraints",+ warnSpec Opt_WarnRedundantConstraints,+ warnSpec Opt_WarnDuplicateExports,+ depWarnSpec Opt_WarnHiShadows+ "it is not used, and was never implemented",+ warnSpec Opt_WarnInaccessibleCode,+ warnSpec Opt_WarnImplicitPrelude,+ depWarnSpec Opt_WarnImplicitKindVars+ "it is now an error",+ warnSpec Opt_WarnIncompletePatterns,+ warnSpec Opt_WarnIncompletePatternsRecUpd,+ warnSpec Opt_WarnIncompleteUniPatterns,+ warnSpec Opt_WarnInlineRuleShadowing,+ warnSpec Opt_WarnIdentities,+ warnSpec Opt_WarnMissingFields,+ warnSpec Opt_WarnMissingImportList,+ warnSpec Opt_WarnMissingExportList,+ subWarnSpec "missing-local-sigs"+ Opt_WarnMissingLocalSignatures+ "it is replaced by -Wmissing-local-signatures",+ warnSpec Opt_WarnMissingLocalSignatures,+ warnSpec Opt_WarnMissingMethods,+ warnSpec Opt_WarnMissingMonadFailInstances,+ warnSpec Opt_WarnSemigroup,+ warnSpec Opt_WarnMissingSignatures,+ warnSpec Opt_WarnMissingKindSignatures,+ subWarnSpec "missing-exported-sigs"+ Opt_WarnMissingExportedSignatures+ "it is replaced by -Wmissing-exported-signatures",+ warnSpec Opt_WarnMissingExportedSignatures,+ warnSpec Opt_WarnMonomorphism,+ warnSpec Opt_WarnNameShadowing,+ warnSpec Opt_WarnNonCanonicalMonadInstances,+ depWarnSpec Opt_WarnNonCanonicalMonadFailInstances+ "fail is no longer a method of Monad",+ warnSpec Opt_WarnNonCanonicalMonoidInstances,+ warnSpec Opt_WarnOrphans,+ warnSpec Opt_WarnOverflowedLiterals,+ warnSpec Opt_WarnOverlappingPatterns,+ warnSpec Opt_WarnMissedSpecs,+ warnSpec Opt_WarnAllMissedSpecs,+ warnSpec' Opt_WarnSafe setWarnSafe,+ warnSpec Opt_WarnTrustworthySafe,+ warnSpec Opt_WarnInferredSafeImports,+ warnSpec Opt_WarnMissingSafeHaskellMode,+ warnSpec Opt_WarnTabs,+ warnSpec Opt_WarnTypeDefaults,+ warnSpec Opt_WarnTypedHoles,+ warnSpec Opt_WarnPartialTypeSignatures,+ warnSpec Opt_WarnUnrecognisedPragmas,+ warnSpec' Opt_WarnUnsafe setWarnUnsafe,+ warnSpec Opt_WarnUnsupportedCallingConventions,+ warnSpec Opt_WarnUnsupportedLlvmVersion,+ warnSpec Opt_WarnMissedExtraSharedLib,+ warnSpec Opt_WarnUntickedPromotedConstructors,+ warnSpec Opt_WarnUnusedDoBind,+ warnSpec Opt_WarnUnusedForalls,+ warnSpec Opt_WarnUnusedImports,+ warnSpec Opt_WarnUnusedLocalBinds,+ warnSpec Opt_WarnUnusedMatches,+ warnSpec Opt_WarnUnusedPatternBinds,+ warnSpec Opt_WarnUnusedTopBinds,+ warnSpec Opt_WarnUnusedTypePatterns,+ warnSpec Opt_WarnUnusedRecordWildcards,+ warnSpec Opt_WarnRedundantBangPatterns,+ warnSpec Opt_WarnRedundantRecordWildcards,+ warnSpec Opt_WarnWrongDoBind,+ warnSpec Opt_WarnMissingPatternSynonymSignatures,+ warnSpec Opt_WarnMissingDerivingStrategies,+ warnSpec Opt_WarnSimplifiableClassConstraints,+ warnSpec Opt_WarnMissingHomeModules,+ warnSpec Opt_WarnUnrecognisedWarningFlags,+ warnSpec Opt_WarnStarBinder,+ warnSpec Opt_WarnStarIsType,+ depWarnSpec Opt_WarnSpaceAfterBang+ "bang patterns can no longer be written with a space",+ warnSpec Opt_WarnPartialFields,+ warnSpec Opt_WarnPrepositiveQualifiedModule,+ warnSpec Opt_WarnUnusedPackages,+ warnSpec Opt_WarnCompatUnqualifiedImports,+ warnSpec Opt_WarnInvalidHaddock,+ warnSpec Opt_WarnOperatorWhitespaceExtConflict,+ warnSpec Opt_WarnOperatorWhitespace,+ warnSpec Opt_WarnImplicitLift,+ warnSpec Opt_WarnMissingExportedPatternSynonymSignatures ] -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@@@ -3495,7 +3551,8 @@ flagSpec "DeriveLift" LangExt.DeriveLift, flagSpec "DeriveTraversable" LangExt.DeriveTraversable, flagSpec "DerivingStrategies" LangExt.DerivingStrategies,- flagSpec "DerivingVia" LangExt.DerivingVia,+ flagSpec' "DerivingVia" LangExt.DerivingVia+ setDeriveVia, flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, flagSpec "BlockArguments" LangExt.BlockArguments,@@ -3828,6 +3885,7 @@ = [ ([0,1,2], Opt_DoLambdaEtaExpansion) , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] , ([0,1,2], Opt_LlvmTBAA)+ , ([2], Opt_DictsStrict) , ([0], Opt_IgnoreInterfacePragmas) , ([0], Opt_OmitInterfacePragmas)@@ -3875,164 +3933,12 @@ ] --- -------------------------------------------------------------------------------- Standard sets of warning options---- Note [Documenting warning flags]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If you change the list of warning enabled by default--- please remember to update the User's Guide. The relevant file is:------ docs/users_guide/using-warnings.rst---- | Warning groups.------ As all warnings are in the Weverything set, it is ignored when--- displaying to the user which group a warning is in.-warningGroups :: [(String, [WarningFlag])]-warningGroups =- [ ("compat", minusWcompatOpts)- , ("unused-binds", unusedBindsFlags)- , ("default", standardWarnings)- , ("extra", minusWOpts)- , ("all", minusWallOpts)- , ("everything", minusWeverythingOpts)- ]---- | Warning group hierarchies, where there is an explicit inclusion--- relation.------ Each inner list is a hierarchy of warning groups, ordered from--- smallest to largest, where each group is a superset of the one--- before it.------ Separating this from 'warningGroups' allows for multiple--- hierarchies with no inherent relation to be defined.------ The special-case Weverything group is not included.-warningHierarchies :: [[String]]-warningHierarchies = hierarchies ++ map (:[]) rest- where- hierarchies = [["default", "extra", "all"]]- rest = filter (`notElem` "everything" : concat hierarchies) $- map fst warningGroups---- | Find the smallest group in every hierarchy which a warning--- belongs to, excluding Weverything.-smallestGroups :: WarningFlag -> [String]-smallestGroups flag = mapMaybe go warningHierarchies where- -- Because each hierarchy is arranged from smallest to largest,- -- the first group we find in a hierarchy which contains the flag- -- is the smallest.- go (group:rest) = fromMaybe (go rest) $ do- flags <- lookup group warningGroups- guard (flag `elem` flags)- pure (Just group)- go [] = Nothing---- | Warnings enabled unless specified otherwise-standardWarnings :: [WarningFlag]-standardWarnings -- see Note [Documenting warning flags]- = [ Opt_WarnOverlappingPatterns,- Opt_WarnWarningsDeprecations,- Opt_WarnDeprecatedFlags,- Opt_WarnDeferredTypeErrors,- Opt_WarnTypedHoles,- Opt_WarnDeferredOutOfScopeVariables,- Opt_WarnPartialTypeSignatures,- Opt_WarnUnrecognisedPragmas,- Opt_WarnDuplicateExports,- Opt_WarnDerivingDefaults,- Opt_WarnOverflowedLiterals,- Opt_WarnEmptyEnumerations,- Opt_WarnAmbiguousFields,- Opt_WarnMissingFields,- Opt_WarnMissingMethods,- Opt_WarnWrongDoBind,- Opt_WarnUnsupportedCallingConventions,- Opt_WarnDodgyForeignImports,- Opt_WarnInlineRuleShadowing,- Opt_WarnAlternativeLayoutRuleTransitional,- Opt_WarnUnsupportedLlvmVersion,- Opt_WarnMissedExtraSharedLib,- Opt_WarnTabs,- Opt_WarnUnrecognisedWarningFlags,- Opt_WarnSimplifiableClassConstraints,- Opt_WarnStarBinder,- Opt_WarnInaccessibleCode,- Opt_WarnSpaceAfterBang,- Opt_WarnNonCanonicalMonadInstances,- Opt_WarnNonCanonicalMonoidInstances,- Opt_WarnOperatorWhitespaceExtConflict- ]---- | Things you get with -W-minusWOpts :: [WarningFlag]-minusWOpts- = standardWarnings ++- [ Opt_WarnUnusedTopBinds,- Opt_WarnUnusedLocalBinds,- Opt_WarnUnusedPatternBinds,- Opt_WarnUnusedMatches,- Opt_WarnUnusedForalls,- Opt_WarnUnusedImports,- Opt_WarnIncompletePatterns,- Opt_WarnDodgyExports,- Opt_WarnDodgyImports,- Opt_WarnUnbangedStrictPatterns- ]---- | Things you get with -Wall-minusWallOpts :: [WarningFlag]-minusWallOpts- = minusWOpts ++- [ Opt_WarnTypeDefaults,- Opt_WarnNameShadowing,- Opt_WarnMissingSignatures,- Opt_WarnHiShadows,- Opt_WarnOrphans,- Opt_WarnUnusedDoBind,- Opt_WarnTrustworthySafe,- Opt_WarnUntickedPromotedConstructors,- Opt_WarnMissingPatternSynonymSignatures,- Opt_WarnUnusedRecordWildcards,- Opt_WarnRedundantRecordWildcards,- Opt_WarnStarIsType,- Opt_WarnIncompleteUniPatterns,- Opt_WarnIncompletePatternsRecUpd- ]---- | Things you get with -Weverything, i.e. *all* known warnings flags-minusWeverythingOpts :: [WarningFlag]-minusWeverythingOpts = [ toEnum 0 .. ]---- | Things you get with -Wcompat.------ This is intended to group together warnings that will be enabled by default--- at some point in the future, so that library authors eager to make their--- code future compatible to fix issues before they even generate warnings.-minusWcompatOpts :: [WarningFlag]-minusWcompatOpts- = [ Opt_WarnSemigroup- , Opt_WarnNonCanonicalMonoidInstances- , Opt_WarnStarIsType- , Opt_WarnCompatUnqualifiedImports- ]- enableUnusedBinds :: DynP () enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags disableUnusedBinds :: DynP () disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags --- Things you get with -Wunused-binds-unusedBindsFlags :: [WarningFlag]-unusedBindsFlags = [ Opt_WarnUnusedTopBinds- , Opt_WarnUnusedLocalBinds- , Opt_WarnUnusedPatternBinds- ]- enableGlasgowExts :: DynP () enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls mapM_ setExtensionFlag glasgowExtsFlags@@ -4093,6 +3999,10 @@ setGenDeriving :: TurnOnFlag -> DynP () setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) setGenDeriving False = return ()++setDeriveVia :: TurnOnFlag -> DynP ()+setDeriveVia True = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l })+setDeriveVia False = return () setOverlappingInsts :: TurnOnFlag -> DynP () setOverlappingInsts False = return ()
compiler/GHC/Hs/Decls.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -329,7 +329,7 @@ type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs -type instance XDataDecl GhcPs = EpAnn [AddEpAnn] -- AZ: used?+type instance XDataDecl GhcPs = EpAnn [AddEpAnn] type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn @@ -568,7 +568,7 @@ * * ********************************************************************* -} -type instance XCHsDataDefn (GhcPass _) = EpAnn [AddEpAnn]+type instance XCHsDataDefn (GhcPass _) = NoExtField type instance XXHsDataDefn (GhcPass _) = NoExtCon type instance XCHsDerivingClause (GhcPass _) = EpAnn [AddEpAnn]@@ -1184,4 +1184,3 @@ type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (Maybe Role) = SrcSpan-
compiler/GHC/Hs/Doc.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveDataTypeable #-} module GHC.Hs.Doc@@ -22,8 +22,6 @@ , ExtractedTHDocs(..) ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Hs/Expr.hs view
@@ -28,8 +28,6 @@ , module GHC.Hs.Expr ) where -#include "GhclibHsVersions.h"- import Language.Haskell.Syntax.Expr -- friends:@@ -46,17 +44,20 @@ -- others: import GHC.Tc.Types.Evidence+import GHC.Core.DataCon (FieldLabelString) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc+import GHC.Types.Var( InvisTVBinder ) import GHC.Core.ConLike import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Core.Type import GHC.Builtin.Types (mkTupleStr)@@ -218,8 +219,13 @@ } deriving Data type instance XVar (GhcPass _) = NoExtField-type instance XConLikeOut (GhcPass _) = NoExtField-type instance XRecFld (GhcPass _) = NoExtField++-- Record selectors at parse time are HsVar; they convert to HsRecSel+-- on renaming.+type instance XRecSel GhcPs = Void+type instance XRecSel GhcRn = NoExtField+type instance XRecSel GhcTc = NoExtField+ type instance XLam (GhcPass _) = NoExtField -- OverLabel not present in GhcTc pass; see GHC.Rename.Expr@@ -240,8 +246,6 @@ -- Much, much easier just to define HoleExprRef with a Data instance and -- store the whole structure. -type instance XConLikeOut (GhcPass _) = NoExtField-type instance XRecFld (GhcPass _) = NoExtField type instance XIPVar (GhcPass _) = EpAnnCO type instance XOverLitE (GhcPass _) = EpAnnCO type instance XLitE (GhcPass _) = EpAnnCO@@ -275,7 +279,7 @@ type instance XNegApp GhcRn = NoExtField type instance XNegApp GhcTc = NoExtField -type instance XPar (GhcPass _) = EpAnn AnnParen+type instance XPar (GhcPass _) = EpAnnCO type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn] type instance XExplicitTuple GhcRn = NoExtField@@ -289,7 +293,7 @@ type instance XCase GhcRn = NoExtField type instance XCase GhcTc = NoExtField -type instance XIf GhcPs = EpAnn [AddEpAnn]+type instance XIf GhcPs = EpAnn AnnsIf type instance XIf GhcRn = NoExtField type instance XIf GhcTc = NoExtField @@ -361,21 +365,9 @@ type instance XPragE (GhcPass _) = NoExtField -type instance XXExpr GhcPs = NoExtCon---- See Note [Rebindable syntax and HsExpansion] below-type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn)- (HsExpr GhcRn)-type instance XXExpr GhcTc = XXExprGhcTc-- type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA -data XXExprGhcTc- = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)- | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))- data AnnExplicitSum = AnnExplicitSum { aesOpen :: EpaLocation,@@ -401,13 +393,22 @@ apClose :: EpaLocation -- ^ ')' } deriving Data +data AnnsIf+ = AnnsIf {+ aiIf :: EpaLocation,+ aiThen :: EpaLocation,+ aiElse :: EpaLocation,+ aiThenSemi :: Maybe EpaLocation,+ aiElseSemi :: Maybe EpaLocation+ } deriving Data+ -- --------------------------------------------------------------------- type instance XSCC (GhcPass _) = EpAnn AnnPragma type instance XXPragE (GhcPass _) = NoExtCon -type instance XCHsFieldLabel (GhcPass _) = EpAnn AnnFieldLabel-type instance XXHsFieldLabel (GhcPass _) = NoExtCon+type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel+type instance XXDotFieldOcc (GhcPass _) = NoExtCon type instance XPresent (GhcPass _) = EpAnn [AddEpAnn] @@ -421,6 +422,40 @@ tupArgPresent (Present {}) = True tupArgPresent (Missing {}) = False ++{- *********************************************************************+* *+ XXExpr: the extension constructor of HsExpr+* *+********************************************************************* -}++type instance XXExpr GhcPs = NoExtCon+type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)+type instance XXExpr GhcTc = XXExprGhcTc+-- HsExpansion: see Note [Rebindable syntax and HsExpansion] below+++data XXExprGhcTc+ = WrapExpr -- Type and evidence application and abstractions+ {-# UNPACK #-} !(HsWrap HsExpr)++ | ExpansionExpr -- See Note [Rebindable syntax and HsExpansion] below+ {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))++ | ConLikeTc -- Result of typechecking a data-con+ -- See Note [Typechecking data constructors] in+ -- GHC.Tc.Gen.Head+ -- The two arguments describe how to eta-expand+ -- the data constructor when desugaring+ ConLike [InvisTVBinder] [Scaled TcType]+++{- *********************************************************************+* *+ Pretty-printing expressions+* *+********************************************************************* -}+ instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where ppr expr = pprExpr expr @@ -457,13 +492,12 @@ => HsExpr (GhcPass p) -> SDoc ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv-ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c-ppr_expr (HsRecFld _ f) = pprPrefixOcc f+ppr_expr (HsRecSel _ f) = pprPrefixOcc f ppr_expr (HsIPVar _ v) = ppr v ppr_expr (HsOverLabel _ l) = char '#' <> ppr l ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit-ppr_expr (HsPar _ e) = parens (ppr_lexpr e)+ppr_expr (HsPar _ _ e _) = parens (ppr_lexpr e) ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] @@ -638,27 +672,41 @@ GhcPs -> ppr x #endif GhcRn -> ppr x- GhcTc -> case x of- WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn- (\parens -> if parens then pprExpr e else pprExpr e)- ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original- -- expression (LHsExpr GhcPs), not the- -- desugared one (LHsExpr GhcT).+ GhcTc -> ppr x +instance Outputable XXExprGhcTc where+ ppr (WrapExpr (HsWrap co_fn e))+ = pprHsWrapper co_fn (\_parens -> pprExpr e)++ ppr (ExpansionExpr e)+ = ppr e -- e is an HsExpansion, we print the original+ -- expression (LHsExpr GhcPs), not the+ -- desugared one (LHsExpr GhcTc).++ ppr (ConLikeTc con _ _) = pprPrefixOcc con+ -- Used in error messages generated by+ -- the pattern match overlap checker+ ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)-ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c))-ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f)+ppr_infix_expr (HsRecSel _ f) = Just (pprInfixOcc f) ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)-ppr_infix_expr (XExpr x) = case (ghcPass @p, x) of+ppr_infix_expr (XExpr x) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 901- (GhcPs, _) -> Nothing+ GhcPs -> Nothing #endif- (GhcRn, HsExpanded a _) -> ppr_infix_expr a- (GhcTc, WrapExpr (HsWrap _ e)) -> ppr_infix_expr e- (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a+ GhcRn -> ppr_infix_expr_rn x+ GhcTc -> ppr_infix_expr_tc x ppr_infix_expr _ = Nothing +ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc+ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a++ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc+ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e+ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a+ppr_infix_expr_tc (ConLikeTc {}) = Nothing+ ppr_apps :: (OutputableBndrId p) => HsExpr (GhcPass p) -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]@@ -698,101 +746,111 @@ -- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs -- parentheses under precedence @p@. hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool-hsExprNeedsParens p = go+hsExprNeedsParens prec = go where+ go :: HsExpr (GhcPass p) -> Bool go (HsVar{}) = False go (HsUnboundVar{}) = False- go (HsConLikeOut{}) = False go (HsIPVar{}) = False go (HsOverLabel{}) = False- go (HsLit _ l) = hsLitNeedsParens p l- go (HsOverLit _ ol) = hsOverLitNeedsParens p ol+ go (HsLit _ l) = hsLitNeedsParens prec l+ go (HsOverLit _ ol) = hsOverLitNeedsParens prec ol go (HsPar{}) = False- go (HsApp{}) = p >= appPrec- go (HsAppType {}) = p >= appPrec- go (OpApp{}) = p >= opPrec- go (NegApp{}) = p > topPrec+ go (HsApp{}) = prec >= appPrec+ go (HsAppType {}) = prec >= appPrec+ go (OpApp{}) = prec >= opPrec+ go (NegApp{}) = prec > topPrec go (SectionL{}) = True go (SectionR{}) = True -- Special-case unary boxed tuple applications so that they are -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) -- See Note [One-tuples] in GHC.Builtin.Types go (ExplicitTuple _ [Present{}] Boxed)- = p >= appPrec+ = prec >= appPrec go (ExplicitTuple{}) = False go (ExplicitSum{}) = False- go (HsLam{}) = p > topPrec- go (HsLamCase{}) = p > topPrec- go (HsCase{}) = p > topPrec- go (HsIf{}) = p > topPrec- go (HsMultiIf{}) = p > topPrec- go (HsLet{}) = p > topPrec+ go (HsLam{}) = prec > topPrec+ go (HsLamCase{}) = prec > topPrec+ go (HsCase{}) = prec > topPrec+ go (HsIf{}) = prec > topPrec+ go (HsMultiIf{}) = prec > topPrec+ go (HsLet{}) = prec > topPrec go (HsDo _ sc _) | isComprehensionContext sc = False- | otherwise = p > topPrec+ | otherwise = prec > topPrec go (ExplicitList{}) = False go (RecordUpd{}) = False- go (ExprWithTySig{}) = p >= sigPrec+ go (ExprWithTySig{}) = prec >= sigPrec go (ArithSeq{}) = False- go (HsPragE{}) = p >= appPrec+ go (HsPragE{}) = prec >= appPrec go (HsSpliceE{}) = False go (HsBracket{}) = False go (HsRnBracketOut{}) = False go (HsTcBracketOut{}) = False- go (HsProc{}) = p > topPrec- go (HsStatic{}) = p >= appPrec+ go (HsProc{}) = prec > topPrec+ go (HsStatic{}) = prec >= appPrec go (HsTick _ _ (L _ e)) = go e go (HsBinTick _ _ _ (L _ e)) = go e go (RecordCon{}) = False- go (HsRecFld{}) = False+ go (HsRecSel{}) = False go (HsProjection{}) = True go (HsGetField{}) = False- go (XExpr x)- | GhcTc <- ghcPass @p- = case x of- WrapExpr (HsWrap _ e) -> go e- ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a- | GhcRn <- ghcPass @p- = case x of HsExpanded a _ -> hsExprNeedsParens p a+ go (XExpr x) = case ghcPass @p of+ GhcTc -> go_x_tc x+ GhcRn -> go_x_rn x #if __GLASGOW_HASKELL__ <= 900- | otherwise- = True+ GhcPs -> True #endif + go_x_tc :: XXExprGhcTc -> Bool+ go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e+ go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a+ go_x_tc (ConLikeTc {}) = False + go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool+ go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a+++-- | Parenthesize an expression without token information+gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)+gHsPar e = HsPar noAnn noHsTok e noHsTok+ -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) parenthesizeHsExpr p le@(L loc e)- | hsExprNeedsParens p e = L loc (HsPar noAnn le)+ | hsExprNeedsParens p e = L loc (gHsPar le) | otherwise = le stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e+stripParensLHsExpr (L _ (HsPar _ _ e _)) = stripParensLHsExpr e stripParensLHsExpr e = e stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)-stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e+stripParensHsExpr (HsPar _ _ (L _ e) _) = stripParensHsExpr e stripParensHsExpr e = e isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool -- True of a single token isAtomicHsExpr (HsVar {}) = True-isAtomicHsExpr (HsConLikeOut {}) = True isAtomicHsExpr (HsLit {}) = True isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True-isAtomicHsExpr (HsRecFld{}) = True+isAtomicHsExpr (HsRecSel{}) = True isAtomicHsExpr (XExpr x)- | GhcTc <- ghcPass @p = case x of- WrapExpr (HsWrap _ e) -> isAtomicHsExpr e- ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a- | GhcRn <- ghcPass @p = case x of- HsExpanded a _ -> isAtomicHsExpr a-isAtomicHsExpr _ = False+ | GhcTc <- ghcPass @p = go_x_tc x+ | GhcRn <- ghcPass @p = go_x_rn x+ where+ go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e+ go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a+ go_x_tc (ConLikeTc {}) = True + go_x_rn (HsExpanded a _) = isAtomicHsExpr a++isAtomicHsExpr _ = False+ instance Outputable (HsPragE (GhcPass p)) where ppr (HsPragSCC _ st (StringLiteral stl lbl _)) = pprWithSourceText st (text "{-# SCC")@@ -991,7 +1049,7 @@ type instance XCmdApp (GhcPass _) = EpAnnCO type instance XCmdLam (GhcPass _) = NoExtField-type instance XCmdPar (GhcPass _) = EpAnn AnnParen+type instance XCmdPar (GhcPass _) = EpAnnCO type instance XCmdCase GhcPs = EpAnn EpAnnHsCase type instance XCmdCase GhcRn = NoExtField@@ -999,7 +1057,7 @@ type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn] -type instance XCmdIf GhcPs = EpAnn [AddEpAnn]+type instance XCmdIf GhcPs = EpAnn AnnsIf type instance XCmdIf GhcRn = NoExtField type instance XCmdIf GhcTc = NoExtField @@ -1063,7 +1121,7 @@ ppr_cmd :: forall p. (OutputableBndrId p ) => HsCmd (GhcPass p) -> SDoc-ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)+ppr_cmd (HsCmdPar _ _ c _) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp _ c e) = let (fun, args) = collect_args c [e] in@@ -1108,21 +1166,27 @@ ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])- = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v- , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2])- = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v- , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])- = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)- , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2])- = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)- , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ op _ _ args)- = hang (text "(|" <+> ppr_lexpr op)- 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")+ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args)+ | HsVar _ (L _ v) <- op+ = ppr_cmd_infix v+ | GhcTc <- ghcPass @p+ , XExpr (ConLikeTc c _ _) <- op+ = ppr_cmd_infix (conLikeName c)+ | otherwise+ = fall_through+ where+ fall_through = hang (text "(|" <+> ppr_expr op)+ 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")++ ppr_cmd_infix :: OutputableBndr v => v -> SDoc+ ppr_cmd_infix v+ | [arg1, arg2] <- args+ , isJust rn_fix || ps_fix == Infix+ = hang (pprCmdArg (unLoc arg1))+ 4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])+ | otherwise+ = fall_through+ ppr_cmd (XCmd x) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811 GhcPs -> ppr x@@ -1225,7 +1289,7 @@ = case ctxt of FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} | SrcStrict <- strictness- -> ASSERT(null pats) -- A strict variable binding+ -> assert (null pats) -- A strict variable binding (char '!'<>pprPrefixOcc fun, pats) | Prefix <- fixity@@ -1837,6 +1901,10 @@ type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL++type instance Anno (FieldLabelStrings (GhcPass p)) = SrcSpan+type instance Anno (FieldLabelString) = SrcSpan+type instance Anno (DotFieldOcc (GhcPass p)) = SrcSpan instance (Anno a ~ SrcSpanAnn' (EpAnn an)) => WrapXRec (GhcPass p) a where
compiler/GHC/Hs/Extension.hs view
@@ -229,3 +229,8 @@ pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc pprIfTc pp = case ghcPass @p of GhcTc -> pp _ -> empty++type instance Anno (HsToken tok) = EpAnnCO++noHsTok :: GenLocated (EpAnn a) (HsToken tok)+noHsTok = L noAnn HsTok
compiler/GHC/Hs/Instances.hs view
@@ -278,9 +278,9 @@ deriving instance Data (FieldLabelStrings GhcRn) deriving instance Data (FieldLabelStrings GhcTc) -deriving instance Data (HsFieldLabel GhcPs)-deriving instance Data (HsFieldLabel GhcRn)-deriving instance Data (HsFieldLabel GhcTc)+deriving instance Data (DotFieldOcc GhcPs)+deriving instance Data (DotFieldOcc GhcRn)+deriving instance Data (DotFieldOcc GhcTc) -- deriving instance (DataIdLR p p) => Data (HsPragE p) deriving instance Data (HsPragE GhcPs)@@ -426,7 +426,7 @@ deriving instance Data ListPatTc -deriving instance (Data a, Data b) => Data (HsRecField' a b)+deriving instance (Data a, Data b) => Data (HsFieldBind a b) deriving instance (Data body) => Data (HsRecFields GhcPs body) deriving instance (Data body) => Data (HsRecFields GhcRn body)
compiler/GHC/Hs/Lit.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -20,8 +19,6 @@ ( module Language.Haskell.Syntax.Lit , module GHC.Hs.Lit ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Hs/Pat.hs view
@@ -28,7 +28,7 @@ ConLikeP, HsConPatDetails, hsConPatArgs,- HsRecFields(..), HsRecField'(..), LHsRecField',+ HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,@@ -39,7 +39,7 @@ isSimplePat, looksLazyPatBind, isBangedLPat,- patNeedsParens, parenthesizePat,+ gParPat, patNeedsParens, parenthesizePat, isIrrefutableHsPat, collectEvVarsPat, collectEvVarsPats,@@ -51,7 +51,7 @@ import GHC.Prelude import Language.Haskell.Syntax.Pat-import Language.Haskell.Syntax.Expr (HsExpr, SyntaxExpr)+import Language.Haskell.Syntax.Expr (SyntaxExpr) import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice) @@ -103,7 +103,7 @@ type instance XAsPat GhcRn = NoExtField type instance XAsPat GhcTc = NoExtField -type instance XParPat (GhcPass _) = EpAnn AnnParen+type instance XParPat (GhcPass _) = EpAnnCO type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!' type instance XBangPat GhcRn = NoExtField@@ -156,7 +156,7 @@ type instance ConLikeP GhcRn = Name -- IdP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XHsRecField _ = EpAnn [AddEpAnn]+type instance XHsFieldBind _ = EpAnn [AddEpAnn] -- --------------------------------------------------------------------- @@ -216,17 +216,17 @@ co_pat_ty :: Type } -hsRecFieldId :: HsRecField GhcTc arg -> Located Id+hsRecFieldId :: HsRecField GhcTc arg -> Id hsRecFieldId = hsRecFieldSel hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName-hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl+hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hfbLHS -hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id-hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc+hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id+hsRecUpdFieldId = fmap foExt . hsRecUpdFieldOcc -hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc-hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl+hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc+hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS {-@@ -285,7 +285,7 @@ pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat]-pprPat (ParPat _ pat) = parens (ppr pat)+pprPat (ParPat _ _ pat _) = parens (ppr pat) pprPat (LitPat _ s) = ppr s pprPat (NPat _ l Nothing _) = ppr l pprPat (NPat _ l (Just _) _) = char '-' <> ppr l@@ -420,7 +420,7 @@ isBangedLPat = isBangedPat . unLoc isBangedPat :: Pat (GhcPass p) -> Bool-isBangedPat (ParPat _ p) = isBangedLPat p+isBangedPat (ParPat _ _ p _) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _ = False @@ -441,8 +441,8 @@ looksLazyLPat = looksLazyPat . unLoc looksLazyPat :: Pat (GhcPass p) -> Bool-looksLazyPat (ParPat _ p) = looksLazyLPat p-looksLazyPat (AsPat _ _ p) = looksLazyLPat p+looksLazyPat (ParPat _ _ p _) = looksLazyLPat p+looksLazyPat (AsPat _ _ p) = looksLazyLPat p looksLazyPat (BangPat {}) = False looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False@@ -508,7 +508,7 @@ = isIrrefutableHsPat' False p' | otherwise = True go (BangPat _ pat) = goL pat- go (ParPat _ pat) = goL pat+ go (ParPat _ _ pat _) = goL pat go (AsPat _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat@@ -553,7 +553,7 @@ -- - x (variable) isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) isSimplePat p = case unLoc p of- ParPat _ x -> isSimplePat x+ ParPat _ _ x _ -> isSimplePat x SigPat _ x _ -> isSimplePat x LazyPat _ x -> isSimplePat x BangPat _ x -> isSimplePat x@@ -628,6 +628,11 @@ go (InfixCon {}) = p >= opPrec -- type args should be empty in this case go (RecCon {}) = False ++-- | Parenthesize a pattern without token information+gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass)+gParPat p = ParPat noAnn noHsTok p noHsTok+ -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: IsPass p@@ -635,7 +640,7 @@ -> LPat (GhcPass p) -> LPat (GhcPass p) parenthesizePat p lpat@(L loc pat)- | patNeedsParens p pat = L loc (ParPat noAnn lpat)+ | patNeedsParens p pat = L loc (gParPat lpat) | otherwise = lpat {-@@ -654,7 +659,7 @@ case pat of LazyPat _ p -> collectEvVarsLPat p AsPat _ _ p -> collectEvVarsLPat p- ParPat _ p -> collectEvVarsLPat p+ ParPat _ _ p _ -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps@@ -684,12 +689,4 @@ type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA type instance Anno (HsOverLit (GhcPass p)) = SrcSpan type instance Anno ConLike = SrcSpanAnnN--type instance Anno (HsRecField' p arg) = SrcSpanAnnA-type instance Anno (HsRecField' (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA-type instance Anno (HsRecField (GhcPass p) arg) = SrcSpanAnnA---- type instance Anno (HsRecUpdField p) = SrcSpanAnnA-type instance Anno (HsRecField' (AmbiguousFieldOcc p) (LocatedA (HsExpr p))) = SrcSpanAnnA--type instance Anno (AmbiguousFieldOcc GhcTc) = SrcSpanAnnA+type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA
compiler/GHC/Hs/Type.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -51,7 +51,7 @@ HsConDetails(..), noTypeArgs, FieldOcc(..), LFieldOcc, mkFieldOcc,- AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,+ AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc, rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, @@ -85,8 +85,6 @@ hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import Language.Haskell.Syntax.Type@@ -200,7 +198,7 @@ type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon -type instance XHsPS GhcPs = NoExtField+type instance XHsPS GhcPs = EpAnn EpaLocation type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn @@ -249,9 +247,9 @@ mkHsWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = noExtField } -mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs-mkHsPatSigType x = HsPS { hsps_ext = noExtField- , hsps_body = x }+mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs+mkHsPatSigType ann x = HsPS { hsps_ext = ann+ , hsps_body = x } mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x@@ -664,7 +662,7 @@ -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass)) splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))- = (ctxt, body)+ = (Just ctxt, body) splitLHsQualTy_KP body = (Nothing, body) -- | Decompose a type class instance type (of the form@@ -825,6 +823,10 @@ pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc +instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where+ pprInfixOcc = pprInfixOcc . unLoc+ pprPrefixOcc = pprPrefixOcc . unLoc+ mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr @@ -981,13 +983,12 @@ pprLHsContext Nothing = empty pprLHsContext (Just lctxt) | null (unLoc lctxt) = empty- | otherwise = pprLHsContextAlways (Just lctxt)+ | otherwise = pprLHsContextAlways lctxt -- For use in a HsQualTy, which always gets printed if it exists. pprLHsContextAlways :: (OutputableBndrId p)- => Maybe (LHsContext (GhcPass p)) -> SDoc-pprLHsContextAlways Nothing = parens empty <+> darrow-pprLHsContextAlways (Just (L _ ctxt))+ => LHsContext (GhcPass p) -> SDoc+pprLHsContextAlways (L _ ctxt) = case ctxt of [] -> parens empty <+> darrow [L _ ty] -> ppr_mono_ty ty <+> darrow@@ -1175,7 +1176,7 @@ go (HsForAllTy{}) = False go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})- | Just (L _ (c:_)) <- ctxt = goL c+ | (L _ (c:_)) <- ctxt = goL c | otherwise = goL body go (HsBangTy{}) = False go (HsRecTy{}) = False@@ -1241,4 +1242,6 @@ type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA type instance Anno HsIPName = SrcSpan type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA+ type instance Anno (FieldOcc (GhcPass p)) = SrcSpan+type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcSpan
compiler/GHC/Hs/Utils.hs view
@@ -20,7 +20,7 @@ -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}@@ -44,7 +44,7 @@ mkHsDictLet, mkHsLams, mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,- mkHsCmdIf,+ mkHsCmdIf, mkConLikeTc, nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,@@ -111,8 +111,6 @@ lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Hs.Decls@@ -170,7 +168,7 @@ -- | @e => (e)@ mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsPar e = L (getLoc e) (HsPar noAnn e)+mkHsPar e = L (getLoc e) (gHsPar e) mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA,@@ -215,7 +213,8 @@ , mg_alts = matches , mg_origin = origin } -mkLocatedList :: Semigroup a => [GenLocated (SrcSpanAnn' a) e2] -> LocatedAn an [GenLocated (SrcSpanAnn' a) e2]+mkLocatedList :: Semigroup a+ => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2] mkLocatedList [] = noLocA [] mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms @@ -285,17 +284,13 @@ -- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them -- So @f x@ becomes @(f x)@, but @3@ stays as @3@. mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkLHsPar le@(L loc e)- | hsExprNeedsParens appPrec e = L loc (HsPar noAnn le)- | otherwise = le+mkLHsPar = parenthesizeHsExpr appPrec mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)-mkParPat lp@(L loc p)- | patNeedsParens appPrec p = L loc (ParPat noAnn lp)- | otherwise = lp+mkParPat = parenthesizePat appPrec nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)-nlParPat p = noLocA (ParPat noAnn p)+nlParPat p = noLocA (gParPat p) ------------------------------- -- These are the bits of syntax that contain rebindable names@@ -363,12 +358,12 @@ last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn [AddEpAnn]+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf -> HsExpr GhcPs mkHsIf c a b anns = HsIf anns c a b -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn [AddEpAnn]+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf -> HsCmd GhcPs mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b @@ -467,6 +462,8 @@ mkHsCharPrimLit :: Char -> HsLit (GhcPass p) mkHsCharPrimLit c = HsChar NoSourceText c +mkConLikeTc :: ConLike -> HsExpr GhcTc+mkConLikeTc con = XExpr (ConLikeTc con [] []) {- ************************************************************************@@ -486,7 +483,7 @@ -- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc-nlHsDataCon con = noLocA (HsConLikeOut noExtField (RealDataCon con))+nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con)) nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) nlHsLit n = noLocA (HsLit noComments n)@@ -593,7 +590,7 @@ -- AZ:Is this used? nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))-nlHsPar e = noLocA (HsPar noAnn e)+nlHsPar e = noLocA (gHsPar e) -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is False. (#12080)@@ -794,7 +791,7 @@ mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrap co_fn (XExpr (WrapExpr (HsWrap co_fn' e))) = mkHsWrap (co_fn <.> co_fn') e-mkHsWrap co_fn (HsPar x (L l e)) = HsPar x (L l (mkHsWrap co_fn e))+mkHsWrap co_fn (HsPar x lpar (L l e) rpar) = HsPar x lpar (L l (mkHsWrap co_fn e)) rpar mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e) mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b@@ -924,13 +921,8 @@ mkMatch ctxt pats expr binds = noLocA (Match { m_ext = noAnn , m_ctxt = ctxt- , m_pats = map paren pats+ , m_pats = map mkParPat pats , m_grhss = GRHSs noExtField (unguardedRHS noAnn noSrcSpan expr) binds })- where- paren :: LPat (GhcPass p) -> LPat (GhcPass p)- paren lp@(L l p)- | patNeedsParens appPrec p = L l (ParPat noAnn lp)- | otherwise = lp {- ************************************************************************@@ -1208,7 +1200,7 @@ BangPat _ pat -> collect_lpat flag pat bndrs AsPat _ a pat -> unXRec @p a : collect_lpat flag pat bndrs ViewPat _ _ pat -> collect_lpat flag pat bndrs- ParPat _ pat -> collect_lpat flag pat bndrs+ ParPat _ _ pat _ -> collect_lpat flag pat bndrs ListPat _ pats -> foldr (collect_lpat flag) bndrs pats TuplePat _ pats _ -> foldr (collect_lpat flag) bndrs pats SumPat _ pat _ _ -> collect_lpat flag pat bndrs@@ -1341,7 +1333,7 @@ foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]- getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs+ getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs ------------------- hsLTyClDeclBinders :: IsPass p@@ -1490,7 +1482,7 @@ where fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) remSeen' = foldr (.) remSeen- [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v+ [deleteBy ((==) `on` unLoc . foLabel . unLoc) v | v <- fld_names] {-@@ -1583,7 +1575,7 @@ hs_pat (BangPat _ pat) = hs_lpat pat hs_pat (AsPat _ _ pat) = hs_lpat pat hs_pat (ViewPat _ _ pat) = hs_lpat pat- hs_pat (ParPat _ pat) = hs_lpat pat+ hs_pat (ParPat _ _ pat _) = hs_lpat pat hs_pat (ListPat _ pats) = hs_lpats pats hs_pat (TuplePat _ pats _) = hs_lpats pats @@ -1599,8 +1591,8 @@ [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] ++ hs_lpats explicit_pats - where implicit_pats = map (hsRecFieldArg . unLoc) implicit- explicit_pats = map (hsRecFieldArg . unLoc) explicit+ where implicit_pats = map (hfbRHS . unLoc) implicit+ explicit_pats = map (hfbRHS . unLoc) explicit (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
compiler/GHC/HsToCore/Errors/Ppr.hs view
@@ -1,4 +1,3 @@- {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where@@ -9,3 +8,4 @@ instance Diagnostic DsMessage where diagnosticMessage (DsUnknownMessage m) = diagnosticMessage m diagnosticReason (DsUnknownMessage m) = diagnosticReason m+ diagnosticHints (DsUnknownMessage m) = diagnosticHints m
compiler/GHC/Iface/Recomp/Binary.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + -- | Computing fingerprints of values serializeable with GHC's \"Binary\" module. module GHC.Iface.Recomp.Binary ( -- * Computing fingerprints@@ -8,15 +8,12 @@ , putNameLiterally ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Utils.Fingerprint import GHC.Utils.Binary import GHC.Types.Name import GHC.Utils.Panic.Plain-import GHC.Utils.Misc fingerprintBinMem :: BinHandle -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f@@ -43,6 +40,6 @@ -- | Used when we want to fingerprint a structure without depending on the -- fingerprints of external Names that it refers to. putNameLiterally :: BinHandle -> Name -> IO ()-putNameLiterally bh name = ASSERT( isExternalName name ) do+putNameLiterally bh name = assert (isExternalName name) $ do put_ bh $! nameModule name put_ bh $! nameOccName name
compiler/GHC/Iface/Syntax.hs view
@@ -3,7 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-} module GHC.Iface.Syntax (@@ -41,8 +41,6 @@ AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey )@@ -76,7 +74,7 @@ import GHC.Utils.Binary.Typeable () import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn,+import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, seqList, zipWithEqual ) import Control.Monad@@ -657,7 +655,7 @@ , ifaxbLHS = pat_tys , ifaxbRHS = rhs , ifaxbIncomps = incomps })- = ASSERT2( null _cvs, pp_tc $$ ppr _cvs )+ = assertPpr (null _cvs) (pp_tc $$ ppr _cvs) $ hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) $+$ nest 4 maybe_incomps@@ -806,7 +804,7 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi--- See Note [Pretty-printing TyThings] in GHC.Types.TyThing.Ppr+-- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ifCtxt = context, ifResKind = kind, ifRoles = roles, ifCons = condecls,@@ -1025,19 +1023,26 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,- ifPatArgs = arg_tys,+ ifPatArgs = arg_tys, ifFieldLabels = pat_fldlbls, ifPatTy = pat_ty} ) = sdocWithContext mk_msg where+ pat_keywrd = text "pattern" mk_msg sdocCtx- = hang (text "pattern" <+> pprPrefixOcc name)- 2 (dcolon <+> sep [univ_msg- , pprIfaceContextArr req_ctxt- , ppWhen insert_empty_ctxt $ parens empty <+> darrow- , ex_msg- , pprIfaceContextArr prov_ctxt- , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ])+ = vcat [ ppr_pat_ty+ -- only print this for record pattern synonyms+ , if null pat_fldlbls then Outputable.empty+ else pat_keywrd <+> pprPrefixOcc name <+> pat_body] where+ ppr_pat_ty =+ hang (pat_keywrd <+> pprPrefixOcc name)+ 2 (dcolon <+> sep [univ_msg+ , pprIfaceContextArr req_ctxt+ , ppWhen insert_empty_ctxt $ parens empty <+> darrow+ , ex_msg+ , pprIfaceContextArr prov_ctxt+ , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ])+ pat_body = braces $ sep $ punctuate comma $ map ppr pat_fldlbls univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs @@ -1690,6 +1695,7 @@ freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _) = emptyNameSet+freeNamesIfProv (IfaceCorePrepProv _) = emptyNameSet freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
compiler/GHC/Iface/Type.hs view
@@ -6,7 +6,7 @@ This module defines interface types and binders -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleInstances #-} -- FlexibleInstances for Binary (DefMethSpec IfaceType) {-# LANGUAGE BangPatterns #-}@@ -67,8 +67,6 @@ many_ty ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types@@ -396,6 +394,7 @@ = IfacePhantomProv IfaceCoercion | IfaceProofIrrelProv IfaceCoercion | IfacePluginProv String+ | IfaceCorePrepProv Bool -- See defn of CorePrepProv {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -595,7 +594,8 @@ go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)- go_prov (IfacePluginProv str) = IfacePluginProv str+ go_prov co@(IfacePluginProv _) = co+ go_prov co@(IfaceCorePrepProv _) = co substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args@@ -1744,6 +1744,8 @@ = text "irrel" <+> pprParendIfaceCoercion co pprIfaceUnivCoProv (IfacePluginProv s) = text "plugin" <+> doubleQuotes (text s)+pprIfaceUnivCoProv (IfaceCorePrepProv _)+ = text "CorePrep" ------------------- instance Outputable IfaceTyCon where@@ -2101,6 +2103,9 @@ put_ bh (IfacePluginProv a) = do putByte bh 3 put_ bh a+ put_ bh (IfaceCorePrepProv a) = do+ putByte bh 4+ put_ bh a get bh = do tag <- getByte bh@@ -2111,6 +2116,8 @@ return $ IfaceProofIrrelProv a 3 -> do a <- get bh return $ IfacePluginProv a+ 4 -> do a <- get bh+ return (IfaceCorePrepProv a) _ -> panic ("get IfaceUnivCoProv " ++ show tag)
compiler/GHC/Parser/Annotation.hs view
@@ -28,7 +28,8 @@ -- ** Annotations in 'GenLocated' LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,- SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, SrcSpanAnn'(..),+ SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,+ SrcSpanAnn'(..), SrcAnn, -- ** Annotation data types used in 'GenLocated' @@ -68,7 +69,8 @@ combineSrcSpansA, addCLocA, addCLocAA, - -- ** Constructing 'GenLocated' annotation types when we do not care about annotations.+ -- ** Constructing 'GenLocated' annotation types when we do not care+ -- about annotations. noLocA, getLocA, noSrcSpanA, noAnnSrcSpan,@@ -76,7 +78,7 @@ -- ** Working with comments in annotations noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn, addCommentsToEpAnn, setCommentsEpAnn,- transferComments,+ transferAnnsA, commentsOnlyA, removeCommentsA, placeholderRealSpan, ) where@@ -93,6 +95,7 @@ import GHC.Utils.Binary import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic+import qualified GHC.Data.Strict as Strict {- Note [exact print annotations]@@ -183,11 +186,8 @@ -- | Exact print annotations exist so that tools can perform source to -- source conversions of Haskell code. They are used to keep track of--- the various syntactic keywords that are not captured in the--- existing AST.------ The annotations, together with original source comments are made available in--- the @'pm_parsed_source@ field of @'GHC.Driver.Env.HsParsedModule'@.+-- the various syntactic keywords that are not otherwise captured in the+-- AST. -- -- The wiki page describing this feature is -- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations@@ -310,49 +310,6 @@ instance Outputable AnnKeywordId where ppr x = text (show x) --- -----------------------------------------------------------------------data EpaComment =- EpaComment- { ac_tok :: EpaCommentTok- , ac_prior_tok :: RealSrcSpan- -- ^ The location of the prior token, used in exact printing. The- -- 'EpaComment' appears as an 'LEpaComment' containing its- -- location. The difference between the end of the prior token- -- and the start of this location is used for the spacing when- -- exact printing the comment.- }- deriving (Eq, Ord, Data, Show)--data EpaCommentTok =- -- Documentation annotations- EpaDocCommentNext String -- ^ something beginning '-- |'- | EpaDocCommentPrev String -- ^ something beginning '-- ^'- | EpaDocCommentNamed String -- ^ something beginning '-- $'- | EpaDocSection Int String -- ^ a section heading- | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc)- | EpaLineComment String -- ^ comment starting by "--"- | EpaBlockComment String -- ^ comment in {- -}- | EpaEofComment -- ^ empty comment, capturing- -- location of EOF-- -- See #19697 for a discussion of its use and how it should be- -- removed in favour of capturing it in the location for- -- 'Located HsModule' in the parser.-- deriving (Eq, Ord, Data, Show)--- Note: these are based on the Token versions, but the Token type is--- defined in GHC.Parser.Lexer and bringing it in here would create a loop--instance Outputable EpaComment where- ppr x = text (show x)---- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',--- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma',--- 'GHC.Parser.Annotation.AnnRarrow'--- 'GHC.Parser.Annotation.AnnTilde'--- - May have 'GHC.Parser.Annotation.AnnComma' when in a list- -- | Certain tokens can have alternate representations when unicode syntax is -- enabled. This flag is attached to those tokens in the lexer so that the -- original source representation can be reproduced in the corresponding@@ -390,6 +347,43 @@ -- --------------------------------------------------------------------- +data EpaComment =+ EpaComment+ { ac_tok :: EpaCommentTok+ , ac_prior_tok :: RealSrcSpan+ -- ^ The location of the prior token, used in exact printing. The+ -- 'EpaComment' appears as an 'LEpaComment' containing its+ -- location. The difference between the end of the prior token+ -- and the start of this location is used for the spacing when+ -- exact printing the comment.+ }+ deriving (Eq, Ord, Data, Show)++data EpaCommentTok =+ -- Documentation annotations+ EpaDocCommentNext String -- ^ something beginning '-- |'+ | EpaDocCommentPrev String -- ^ something beginning '-- ^'+ | EpaDocCommentNamed String -- ^ something beginning '-- $'+ | EpaDocSection Int String -- ^ a section heading+ | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc)+ | EpaLineComment String -- ^ comment starting by "--"+ | EpaBlockComment String -- ^ comment in {- -}+ | EpaEofComment -- ^ empty comment, capturing+ -- location of EOF++ -- See #19697 for a discussion of EpaEofComment's use and how it+ -- should be removed in favour of capturing it in the location for+ -- 'Located HsModule' in the parser.++ deriving (Eq, Ord, Data, Show)+-- Note: these are based on the Token versions, but the Token type is+-- defined in GHC.Parser.Lexer and bringing it in here would create a loop++instance Outputable EpaComment where+ ppr x = text (show x)++-- ---------------------------------------------------------------------+ -- | Captures an annotation, storing the @'AnnKeywordId'@ and its -- location. The parser only ever inserts @'EpaLocation'@ fields with a -- RealSrcSpan being the original location of the annotation in the@@ -411,12 +405,16 @@ | EpaDelta DeltaPos deriving (Data,Show,Eq,Ord) --- | Relative position, line then column. If 'deltaLine' is zero then--- 'deltaColumn' gives the number of spaces between the end of the--- preceding output element and the start of the one this is attached--- to, on the same line. If 'deltaLine' is > 0, then it is the number--- of lines to advance, and 'deltaColumn' is the start column on the--- new line.+-- | Spacing between output items when exact printing. It captures+-- the spacing from the current print position on the page to the+-- position required for the thing about to be printed. This is+-- either on the same line in which case is is simply the number of+-- spaces to emit, or it is some number of lines down, with a given+-- column offset. The exact printing algorithm keeps track of the+-- column offset pertaining to the current anchor position, so the+-- `deltaColumn` is the additional spaces to add in this case. See+-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for+-- details. data DeltaPos = SameLine { deltaColumn :: !Int } | DifferentLine@@ -424,6 +422,8 @@ deltaColumn :: !Int } deriving (Show,Eq,Ord,Data) +-- | Smart constructor for a 'DeltaPos'. It preserves the invariant+-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0. deltaPos :: Int -> Int -> DeltaPos deltaPos l c = case l of 0 -> SameLine c@@ -449,40 +449,10 @@ -- --------------------------------------------------------------------- -{--Note [In-tree Api annotations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--GHC 7.10 brought in the concept of API Annotations,-https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations:-- The hsSyn AST does not directly capture the locations of certain- keywords and punctuation, such as 'let', 'in', 'do', etc.-- These locations are required by any tools wanting to parse a haskell- file, transform the AST in some way, and then regenerate the- original layout for the unchaged parts."--These were returned in a separate data structure, linked to the main-AST via a combination of SrcSpan and constructor name.--This indirect linkage kept the AST uncluttered, but made working with-the annotations complex, as two separate data structures had to be-changed at the same time in a coherent way.--From GHC 9.2.1, these annotations are captured directly in the AST,-using the types in this file, and the Trees That Grow (TTG) extension-points for GhcPs.--See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations--See Note [XRec and Anno in the AST] for details of how this is done.--}---- | The API Annotations are now kept in the HsSyn AST for the GhcPs--- phase. We do not always have API Annotations though, only for--- parsed code. This type captures that, and allows the--- representation decision to be easily revisited as it evolves.+-- | The exact print annotations (EPAs) are kept in the HsSyn AST for+-- the GhcPs phase. We do not always have EPAs though, only for code+-- that has been parsed as they do not exist for generated+-- code. This type captures that they may be missing. -- -- A goal of the annotations is that an AST can be edited, including -- moving subtrees from one place to another, duplicating them, and so@@ -495,8 +465,8 @@ -- fragment are also captured here. -- -- The 'ann' type parameter allows this general structure to be--- specialised to the specific set of locations of original API--- Annotation elements. So for 'HsLet' we have+-- specialised to the specific set of locations of original exact+-- print annotation elements. So for 'HsLet' we have -- -- type instance XLet GhcPs = EpAnn AnnsLet -- data AnnsLet@@ -506,11 +476,12 @@ -- } deriving Data -- -- The spacing between the items under the scope of a given EpAnn is--- derived from the original 'Anchor'. But there is no requirement--- that the items included in the sub-element have a "matching"--- location in their relative anchors. This allows us to freely move--- elements around, and stitch together new AST fragments out of old--- ones, and have them still printed out in a reasonable way.+-- normally derived from the original 'Anchor'. But if a sub-element+-- is not in its original position, the required spacing can be+-- directly captured in the 'anchor_op' field of the 'entry' Anchor.+-- This allows us to freely move elements around, and stitch together+-- new AST fragments out of old ones, and have them still printed out+-- in a precise way. data EpAnn ann = EpAnn { entry :: Anchor -- ^ Base location for the start of the syntactic element@@ -527,8 +498,11 @@ -- | An 'Anchor' records the base location for the start of the -- syntactic element holding the annotations, and is used as the point -- of reference for calculating delta positions for contained--- annotations. If an AST element is moved or deleted, the original--- location is also tracked, for printing the source without gaps.+-- annotations.+-- It is also normally used as the reference point for the spacing of+-- the element relative to its container. If it is moved, that+-- relationship is tracked in the 'anchor_op' instead.+ data Anchor = Anchor { anchor :: RealSrcSpan -- ^ Base location for the start of -- the syntactic element holding@@ -556,8 +530,8 @@ -- | When we are parsing we add comments that belong a particular AST -- element, and print them together with the element, interleaving--- them into the output stream. But when editin the AST, to move--- fragments around, it is useful to be able to first separate the+-- them into the output stream. But when editing the AST to move+-- fragments around it is useful to be able to first separate the -- comments into those occuring before the AST element and those -- following it. The 'EpaCommentsBalanced' constructor is used to do -- this. The GHC parser will only insert the 'EpaComments' form.@@ -586,14 +560,7 @@ -- | We mostly use 'SrcSpanAnn\'' with an 'EpAnn\'' type SrcAnn ann = SrcSpanAnn' (EpAnn ann)--- AZ: is SrcAnn the right abbreviation here? Any better suggestions? --- AZ: should we rename LocatedA to LocatedL? The name comes from--- this being the most common usage, and hence being the default--- annotation. It also has a matching set if utility functions such as--- locA, noLocA, etc. LocatedL would then need a new name, but it is--- relatively rare, and captures a list having an openinc and closing--- adorment, such as parens, braces, etc. type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN @@ -616,7 +583,7 @@ Note [XRec and Anno in the AST] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The API annotations are now captured directly inside the AST, using+The exact print annotations are captured directly inside the AST, using TTG extension points. However certain annotations need to be captured on the Located versions too. While there is a general form for these, captured in the type SrcSpanAnn', there are also specific usages in@@ -656,6 +623,7 @@ | AddVbarAnn EpaLocation -- ^ Trailing '|' | AddRarrowAnn EpaLocation -- ^ Trailing '->' | AddRarrowAnnU EpaLocation -- ^ Trailing '->', unicode variant+ | AddLollyAnnU EpaLocation -- ^ Trailing '⊸' deriving (Data,Show,Eq, Ord) instance Outputable TrailingAnn where@@ -664,6 +632,7 @@ ppr (AddVbarAnn ss) = text "AddVbarAnn" <+> ppr ss ppr (AddRarrowAnn ss) = text "AddRarrowAnn" <+> ppr ss ppr (AddRarrowAnnU ss) = text "AddRarrowAnnU" <+> ppr ss+ ppr (AddLollyAnnU ss) = text "AddLollyAnnU" <+> ppr ss -- | Annotation for items appearing in a list. They can have one or -- more trailing punctuations items, such as commas or semicolons.@@ -682,20 +651,20 @@ -- keywords such as 'where'. data AnnList = AnnList {- -- TODO:AZ: should we distinguish AnnList variants for lists- -- with layout and without? al_anchor :: Maybe Anchor, -- ^ start point of a list having layout al_open :: Maybe AddEpAnn, al_close :: Maybe AddEpAnn, al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword- al_trailing :: [TrailingAnn]+ al_trailing :: [TrailingAnn] -- ^ items appearing after the+ -- list, such as '=>' for a+ -- context } deriving (Data,Eq) -- --------------------------------------------------------------------- -- Annotations for parenthesised elements, such as tuples, lists -- --------------------------------------------------------------------- --- | API Annotation for an item having surrounding "brackets", such as+-- | exact print annotation for an item having surrounding "brackets", such as -- tuples or lists data AnnParen = AnnParen {@@ -704,7 +673,7 @@ ap_close :: EpaLocation } deriving (Data) --- | Detail of the "brackets" used in an 'AnnParen' API Annotation.+-- | Detail of the "brackets" used in an 'AnnParen' exact print annotation. data ParenType = AnnParens -- ^ '(', ')' | AnnParensHash -- ^ '(#', '#)'@@ -720,7 +689,7 @@ -- --------------------------------------------------------------------- --- | API Annotation for the 'Context' data type.+-- | Exact print annotation for the 'Context' data type. data AnnContext = AnnContext { ac_darrow :: Maybe (IsUnicodeSyntax, EpaLocation),@@ -734,7 +703,7 @@ -- Annotations for names -- --------------------------------------------------------------------- --- | API Annotations for a 'RdrName'. There are many kinds of+-- | exact print annotations for a 'RdrName'. There are many kinds of -- adornment that can be attached to a given 'RdrName'. This type -- captures them, as detailed on the individual constructors. data NameAnn@@ -792,8 +761,8 @@ -- --------------------------------------------------------------------- --- | API Annotation used for capturing the locations of annotations in--- pragmas.+-- | exact print annotation used for capturing the locations of+-- annotations in pragmas. data AnnPragma = AnnPragma { apr_open :: AddEpAnn,@@ -960,7 +929,7 @@ widenSpan s as = foldl combineSrcSpans s (go as) where go [] = []- go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Nothing : go rest+ go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest go (AddEpAnn _ (EpaDelta _):rest) = go rest -- | The annotations need to all come after the anchor. Make sure@@ -1010,12 +979,15 @@ -- AZ:TODO: move this somewhere sane -combineLocsA :: Semigroup a => GenLocated (SrcSpanAnn' a) e1 -> GenLocated (SrcSpanAnn' a) e2 -> SrcSpanAnn' a+combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a combineLocsA (L a _) (L b _) = combineSrcSpansA a b -combineSrcSpansA :: Semigroup a => SrcSpanAnn' a -> SrcSpanAnn' a -> SrcSpanAnn' a+combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)- = SrcSpanAnn (aa <> ab) (combineSrcSpans la lb)+ = case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of+ SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l+ SrcSpanAnn (EpAnn anc an cs) l ->+ SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l -- | Combine locations from two 'Located' things and add them to a third thing addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3@@ -1096,15 +1068,31 @@ = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs --- | Transfer comments from the annotations in one 'SrcAnn' to those--- in another. The originals are not changed. This is used when--- manipulating an AST prior to exact printing,-transferComments :: (Monoid ann)- => SrcAnn ann -> SrcAnn ann -> (SrcAnn ann, SrcAnn ann)-transferComments from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)-transferComments (SrcSpanAnn (EpAnn a an cs) l) to- = ((SrcSpanAnn (EpAnn a an emptyComments) l), addCommentsToSrcAnn to cs)+-- | Transfer comments and trailing items from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)+transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)+transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to+ = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to')+ where+ to' = case to of+ (SrcSpanAnn EpAnnNotUsed loc)+ -> SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc+ (SrcSpanAnn (EpAnn a an' cs') loc)+ -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc +-- | Remove the exact print annotations payload, leaving only the+-- anchor and comments.+commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann+commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc+commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc)++-- | Remove the comments, leaving the exact print annotations payload+removeCommentsA :: SrcAnn ann -> SrcAnn ann+removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc+removeCommentsA (SrcSpanAnn (EpAnn a an _) loc)+ = (SrcSpanAnn (EpAnn a an emptyComments) loc)+ -- --------------------------------------------------------------------- -- Semigroup instances, to allow easy combination of annotaion elements -- ---------------------------------------------------------------------@@ -1225,6 +1213,11 @@ instance (Outputable a, Outputable e) => Outputable (GenLocated (SrcSpanAnn' a) e) where ppr = pprLocated++instance (Outputable a, OutputableBndr e)+ => OutputableBndr (GenLocated (SrcSpanAnn' a) e) where+ pprInfixOcc = pprInfixOcc . unLoc+ pprPrefixOcc = pprPrefixOcc . unLoc instance Outputable AnnListItem where ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts
compiler/GHC/Parser/CharClass.hs view
@@ -1,5 +1,5 @@ -- Character classification-{-# LANGUAGE CPP #-}+ module GHC.Parser.CharClass ( is_ident -- Char# -> Bool , is_symbol -- Char# -> Bool@@ -13,8 +13,6 @@ , is_decdigit, is_hexdigit, is_octdigit, is_bindigit , hexDigit, octDecDigit ) where--#include "GhclibHsVersions.h" import GHC.Prelude
− compiler/GHC/Parser/Errors.hs
@@ -1,433 +0,0 @@-module GHC.Parser.Errors- ( PsWarning(..)- , TransLayoutReason(..)- , OperatorWhitespaceSymbol(..)- , OperatorWhitespaceOccurrence(..)- , NumUnderscoreReason(..)- , PsError(..)- , PsErrorDesc(..)- , LexErr(..)- , CmmParserError(..)- , LexErrKind(..)- , PsHint(..)- , StarIsType (..)- )-where--import GHC.Prelude-import GHC.Types.SrcLoc-import GHC.Types.Name.Reader (RdrName)-import GHC.Types.Name.Occurrence (OccName)-import GHC.Parser.Types-import Language.Haskell.Syntax.Extension-import GHC.Hs.Extension-import GHC.Hs.Expr-import GHC.Hs.Pat-import GHC.Hs.Type-import GHC.Hs.Lit-import GHC.Hs.Decls-import GHC.Core.Coercion.Axiom (Role)-import GHC.Utils.Outputable (SDoc)-import GHC.Data.FastString-import GHC.Unit.Module.Name---- | A warning that might arise during parsing.-data PsWarning-- -- | Warn when tabulations are found- = PsWarnTab- { tabFirst :: !SrcSpan -- ^ First occurrence of a tab- , tabCount :: !Word -- ^ Number of other occurrences- }-- | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason- -- ^ Transitional layout warnings-- | PsWarnUnrecognisedPragma !SrcSpan- -- ^ Unrecognised pragma-- | PsWarnHaddockInvalidPos !SrcSpan- -- ^ Invalid Haddock comment position-- | PsWarnHaddockIgnoreMulti !SrcSpan- -- ^ Multiple Haddock comment for the same entity-- | PsWarnStarBinder !SrcSpan- -- ^ Found binding occurrence of "*" while StarIsType is enabled-- | PsWarnStarIsType !SrcSpan- -- ^ Using "*" for "Type" without StarIsType enabled-- | PsWarnImportPreQualified !SrcSpan- -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled-- | PsWarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol- | PsWarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence---- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning.-data OperatorWhitespaceSymbol- = OperatorWhitespaceSymbol_PrefixPercent- | OperatorWhitespaceSymbol_PrefixDollar- | OperatorWhitespaceSymbol_PrefixDollarDollar---- | The operator occurrence type in the 'WarnOperatorWhitespace' warning.-data OperatorWhitespaceOccurrence- = OperatorWhitespaceOccurrence_Prefix- | OperatorWhitespaceOccurrence_Suffix- | OperatorWhitespaceOccurrence_TightInfix--data TransLayoutReason- = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"- | TransLayout_Pipe -- ^ "`|' at the same depth as implicit layout block")--data PsError = PsError- { errDesc :: !PsErrorDesc -- ^ Error description- , errHints :: ![PsHint] -- ^ Hints- , errLoc :: !SrcSpan -- ^ Error position- }--data PsErrorDesc- = PsErrLambdaCase- -- ^ LambdaCase syntax used without the extension enabled-- | PsErrEmptyLambda- -- ^ A lambda requires at least one parameter-- | PsErrNumUnderscores !NumUnderscoreReason- -- ^ Underscores in literals without the extension enabled-- | PsErrPrimStringInvalidChar- -- ^ Invalid character in primitive string-- | PsErrMissingBlock- -- ^ Missing block-- | PsErrLexer !LexErr !LexErrKind- -- ^ Lexer error-- | PsErrSuffixAT- -- ^ Suffix occurrence of `@`-- | PsErrParse !String- -- ^ Parse errors-- | PsErrCmmLexer- -- ^ Cmm lexer error-- | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))- -- ^ Unsupported boxed sum in expression-- | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))- -- ^ Unsupported boxed sum in pattern-- | PsErrUnexpectedQualifiedConstructor !RdrName- -- ^ Unexpected qualified constructor-- | PsErrTupleSectionInPat- -- ^ Tuple section in pattern context-- | PsErrIllegalBangPattern !(Pat GhcPs)- -- ^ Bang-pattern without BangPattterns enabled-- | PsErrOpFewArgs !StarIsType !RdrName- -- ^ Operator applied to too few arguments-- | PsErrImportQualifiedTwice- -- ^ Import: multiple occurrences of 'qualified'-- | PsErrImportPostQualified- -- ^ Post qualified import without 'ImportQualifiedPost'-- | PsErrIllegalExplicitNamespace- -- ^ Explicit namespace keyword without 'ExplicitNamespaces'-- | PsErrVarForTyCon !RdrName- -- ^ Expecting a type constructor but found a variable-- | PsErrIllegalPatSynExport- -- ^ Illegal export form allowed by PatternSynonyms-- | PsErrMalformedEntityString- -- ^ Malformed entity string-- | PsErrDotsInRecordUpdate- -- ^ Dots used in record update-- | PsErrPrecedenceOutOfRange !Int- -- ^ Precedence out of range-- | PsErrOverloadedRecordDotInvalid- -- ^ Invalid use of record dot syntax `.'-- | PsErrOverloadedRecordUpdateNotEnabled- -- ^ `OverloadedRecordUpdate` is not enabled.-- | PsErrOverloadedRecordUpdateNoQualifiedFields- -- ^ Can't use qualified fields when OverloadedRecordUpdate is enabled.-- | PsErrInvalidDataCon !(HsType GhcPs)- -- ^ Cannot parse data constructor in a data/newtype declaration-- | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)- -- ^ Cannot parse data constructor in a data/newtype declaration-- | PsErrUnpackDataCon- -- ^ UNPACK applied to a data constructor-- | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)- -- ^ Unexpected kind application in data/newtype declaration-- | PsErrInvalidRecordCon !(PatBuilder GhcPs)- -- ^ Not a record constructor-- | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)- -- ^ Illegal unboxed string literal in pattern-- | PsErrDoNotationInPat- -- ^ Do-notation in pattern-- | PsErrIfTheElseInPat- -- ^ If-then-else syntax in pattern-- | PsErrLambdaCaseInPat- -- ^ Lambda-case in pattern-- | PsErrCaseInPat- -- ^ case..of in pattern-- | PsErrLetInPat- -- ^ let-syntax in pattern-- | PsErrLambdaInPat- -- ^ Lambda-syntax in pattern-- | PsErrArrowExprInPat !(HsExpr GhcPs)- -- ^ Arrow expression-syntax in pattern-- | PsErrArrowCmdInPat !(HsCmd GhcPs)- -- ^ Arrow command-syntax in pattern-- | PsErrArrowCmdInExpr !(HsCmd GhcPs)- -- ^ Arrow command-syntax in expression-- | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)- -- ^ View-pattern in expression-- | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)- -- ^ Type-application without space before '@'-- | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs)- -- ^ Lazy-pattern ('~') without space after it-- | PsErrBangPatWithoutSpace !(LHsExpr GhcPs)- -- ^ Bang-pattern ('!') without space after it-- | PsErrUnallowedPragma !(HsPragE GhcPs)- -- ^ Pragma not allowed in this position-- | PsErrQualifiedDoInCmd !ModuleName- -- ^ Qualified do block in command-- | PsErrInvalidInfixHole- -- ^ Invalid infix hole, expected an infix operator-- | PsErrSemiColonsInCondExpr- -- ^ Unexpected semi-colons in conditional expression- !(HsExpr GhcPs) -- ^ conditional expr- !Bool -- ^ "then" semi-colon?- !(HsExpr GhcPs) -- ^ "then" expr- !Bool -- ^ "else" semi-colon?- !(HsExpr GhcPs) -- ^ "else" expr-- | PsErrSemiColonsInCondCmd- -- ^ Unexpected semi-colons in conditional command- !(HsExpr GhcPs) -- ^ conditional expr- !Bool -- ^ "then" semi-colon?- !(HsCmd GhcPs) -- ^ "then" expr- !Bool -- ^ "else" semi-colon?- !(HsCmd GhcPs) -- ^ "else" expr-- | PsErrAtInPatPos- -- ^ @-operator in a pattern position-- | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)- -- ^ Unexpected lambda command in function application-- | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)- -- ^ Unexpected case command in function application-- | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)- -- ^ Unexpected if command in function application-- | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs)- -- ^ Unexpected let command in function application-- | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs)- -- ^ Unexpected do command in function application-- | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)- -- ^ Unexpected do block in function application-- | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)- -- ^ Unexpected mdo block in function application-- | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)- -- ^ Unexpected lambda expression in function application-- | PsErrCaseInFunAppExpr !(LHsExpr GhcPs)- -- ^ Unexpected case expression in function application-- | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)- -- ^ Unexpected lambda-case expression in function application-- | PsErrLetInFunAppExpr !(LHsExpr GhcPs)- -- ^ Unexpected let expression in function application-- | PsErrIfInFunAppExpr !(LHsExpr GhcPs)- -- ^ Unexpected if expression in function application-- | PsErrProcInFunAppExpr !(LHsExpr GhcPs)- -- ^ Unexpected proc expression in function application-- | PsErrMalformedTyOrClDecl !(LHsType GhcPs)- -- ^ Malformed head of type or class declaration-- | PsErrIllegalWhereInDataDecl- -- ^ Illegal 'where' keyword in data declaration-- | PsErrIllegalDataTypeContext !(LHsContext GhcPs)- -- ^ Illegal datatyp context-- | PsErrParseErrorOnInput !OccName- -- ^ Parse error on input-- | PsErrMalformedDecl !SDoc !RdrName- -- ^ Malformed ... declaration for ...-- | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName- -- ^ Unexpected type application in a declaration-- | PsErrNotADataCon !RdrName- -- ^ Not a data constructor-- | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs)- -- ^ Record syntax used in pattern synonym declaration-- | PsErrEmptyWhereInPatSynDecl !RdrName- -- ^ Empty 'where' clause in pattern-synonym declaration-- | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)- -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration-- | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)- -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration-- | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)- -- ^ Declaration splice not a top-level-- | PsErrInferredTypeVarNotAllowed- -- ^ Inferred type variables not allowed here-- | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]- -- ^ Multiple names in standalone kind signatures-- | PsErrIllegalImportBundleForm- -- ^ Illegal import bundle form-- | PsErrIllegalRoleName !FastString [Role]- -- ^ Illegal role name-- | PsErrInvalidTypeSignature !(LHsExpr GhcPs)- -- ^ Invalid type signature-- | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc- -- ^ Unexpected type in declaration-- | PsErrExpectedHyphen- -- ^ Expected a hyphen-- | PsErrSpaceInSCC- -- ^ Found a space in a SCC-- | PsErrEmptyDoubleQuotes !Bool-- Is TH on?- -- ^ Found two single quotes-- | PsErrInvalidPackageName !FastString- -- ^ Invalid package name-- | PsErrInvalidRuleActivationMarker- -- ^ Invalid rule activation marker-- | PsErrLinearFunction- -- ^ Linear function found but LinearTypes not enabled-- | PsErrMultiWayIf- -- ^ Multi-way if-expression found but MultiWayIf not enabled-- | PsErrExplicitForall !Bool -- is Unicode forall?- -- ^ Explicit forall found but no extension allowing it is enabled-- | PsErrIllegalQualifiedDo !SDoc- -- ^ Found qualified-do without QualifiedDo enabled-- | PsErrCmmParser !CmmParserError- -- ^ Cmm parser error-- | PsErrIllegalTraditionalRecordSyntax !SDoc- -- ^ Illegal traditional record syntax- --- -- TODO: distinguish errors without using SDoc-- | PsErrParseErrorInCmd !SDoc- -- ^ Parse error in command- --- -- TODO: distinguish errors without using SDoc-- | PsErrParseErrorInPat !SDoc- -- ^ Parse error in pattern- --- -- TODO: distinguish errors without using SDoc---newtype StarIsType = StarIsType Bool--data NumUnderscoreReason- = NumUnderscore_Integral- | NumUnderscore_Float- deriving (Show,Eq,Ord)--data PsHint- = SuggestTH- | SuggestRecursiveDo- | SuggestDo- | SuggestMissingDo- | SuggestLetInDo- | SuggestPatternSynonyms- | SuggestInfixBindMaybeAtPat !RdrName- | TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors---data LexErrKind- = LexErrKind_EOF -- ^ End of input- | LexErrKind_UTF8 -- ^ UTF-8 decoding error- | LexErrKind_Char !Char -- ^ Error at given character- deriving (Show,Eq,Ord)--data LexErr- = LexError -- ^ Lexical error- | LexUnknownPragma -- ^ Unknown pragma- | LexErrorInPragma -- ^ Lexical error in pragma- | LexNumEscapeRange -- ^ Numeric escape sequence out of range- | LexStringCharLit -- ^ Llexical error in string/character literal- | LexStringCharLitEOF -- ^ Unexpected end-of-file in string/character literal- | LexUnterminatedComment -- ^ Unterminated `{-'- | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma- | LexUnterminatedQQ -- ^ Unterminated quasiquotation---- | Errors from the Cmm parser-data CmmParserError- = CmmUnknownPrimitive !FastString -- ^ Unknown Cmm primitive- | CmmUnknownMacro !FastString -- ^ Unknown macro- | CmmUnknownCConv !String -- ^ Unknown calling convention- | CmmUnrecognisedSafety !String -- ^ Unrecognised safety- | CmmUnrecognisedHint !String -- ^ Unrecognised hint
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -1,638 +1,771 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage--module GHC.Parser.Errors.Ppr- ( mkParserWarn- , mkParserErr- , pprPsError- )-where--import GHC.Prelude-import GHC.Driver.Flags-import GHC.Parser.Errors-import GHC.Parser.Errors.Types-import GHC.Parser.Types-import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.SrcLoc-import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual)-import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Data.FastString-import GHC.Hs.Expr (prependQualified,HsExpr(..))-import GHC.Hs.Type (pprLHsContext)-import GHC.Builtin.Names (allNameStrings)-import GHC.Builtin.Types (filterCTuple)-import GHC.Driver.Session (DynFlags)-import GHC.Utils.Error (diagReasonSeverity)--instance Diagnostic PsMessage where- diagnosticMessage (PsUnknownMessage m) = diagnosticMessage m- diagnosticReason (PsUnknownMessage m) = diagnosticReason m--mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope PsMessage-mk_parser_err span doc = MsgEnvelope- { errMsgSpan = span- , errMsgContext = alwaysQualify- , errMsgDiagnostic = PsUnknownMessage $ DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag- , errMsgSeverity = SevError- }--mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope PsMessage-mk_parser_warn df flag span doc = MsgEnvelope- { errMsgSpan = span- , errMsgContext = alwaysQualify- , errMsgDiagnostic = PsUnknownMessage $ DiagnosticMessage (mkDecorated [doc]) reason- , errMsgSeverity = diagReasonSeverity df reason- }- where- reason :: DiagnosticReason- reason = WarningWithFlag flag--mkParserWarn :: DynFlags -> PsWarning -> MsgEnvelope PsMessage-mkParserWarn df = \case- PsWarnTab loc tc- -> mk_parser_warn df Opt_WarnTabs loc $- text "Tab character found here"- <> (if tc == 1- then text ""- else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))- <> text "."- $+$ text "Please use spaces instead."-- PsWarnTransitionalLayout loc reason- -> mk_parser_warn df Opt_WarnAlternativeLayoutRuleTransitional loc $- text "transitional layout will not be accepted in the future:"- $$ text (case reason of- TransLayout_Where -> "`where' clause at the same depth as implicit layout block"- TransLayout_Pipe -> "`|' at the same depth as implicit layout block"- )-- PsWarnUnrecognisedPragma loc- -> mk_parser_warn df Opt_WarnUnrecognisedPragmas loc $- text "Unrecognised pragma"-- PsWarnHaddockInvalidPos loc- -> mk_parser_warn df Opt_WarnInvalidHaddock loc $- text "A Haddock comment cannot appear in this position and will be ignored."-- PsWarnHaddockIgnoreMulti loc- -> mk_parser_warn df Opt_WarnInvalidHaddock loc $- text "Multiple Haddock comments for a single entity are not allowed." $$- text "The extraneous comment will be ignored."-- PsWarnStarBinder loc- -> mk_parser_warn df Opt_WarnStarBinder loc $- text "Found binding occurrence of" <+> quotes (text "*")- <+> text "yet StarIsType is enabled."- $$ text "NB. To use (or export) this operator in"- <+> text "modules with StarIsType,"- $$ text " including the definition module, you must qualify it."-- PsWarnStarIsType loc- -> mk_parser_warn df Opt_WarnStarIsType loc $- text "Using" <+> quotes (text "*")- <+> text "(or its Unicode variant) to mean"- <+> quotes (text "Data.Kind.Type")- $$ text "relies on the StarIsType extension, which will become"- $$ text "deprecated in the future."- $$ text "Suggested fix: use" <+> quotes (text "Type")- <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."-- PsWarnImportPreQualified loc- -> mk_parser_warn df Opt_WarnPrepositiveQualifiedModule loc $- text "Found" <+> quotes (text "qualified")- <+> text "in prepositive position"- $$ text "Suggested fix: place " <+> quotes (text "qualified")- <+> text "after the module name instead."- $$ text "To allow this, enable language extension 'ImportQualifiedPost'"-- PsWarnOperatorWhitespaceExtConflict loc sym- -> mk_parser_warn df Opt_WarnOperatorWhitespaceExtConflict loc $- let mk_prefix_msg operator_symbol extension_name syntax_meaning =- text "The prefix use of a" <+> quotes (text operator_symbol)- <+> text "would denote" <+> text syntax_meaning- $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")- $$ text "Suggested fix: add whitespace after the"- <+> quotes (text operator_symbol) <> char '.'- in- case sym of- OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "%" "LinearTypes" "a multiplicity annotation"- OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "$" "TemplateHaskell" "an untyped splice"- OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice"--- PsWarnOperatorWhitespace loc sym occ_type- -> mk_parser_warn df Opt_WarnOperatorWhitespace loc $- let mk_msg occ_type_str =- text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)- <+> text "might be repurposed as special syntax"- $$ nest 2 (text "by a future language extension.")- $$ text "Suggested fix: add whitespace around it."- in- case occ_type of- OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"- OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"- OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"--mkParserErr :: PsError -> MsgEnvelope PsMessage-mkParserErr err = mk_parser_err (errLoc err) $- pprPsError (errDesc err) (errHints err)---- | Render a 'PsErrorDesc' into an 'SDoc', with its 'PsHint's.-pprPsError :: PsErrorDesc -> [PsHint] -> SDoc-pprPsError desc hints = vcat (pp_err desc : map pp_hint hints)--pp_err :: PsErrorDesc -> SDoc-pp_err = \case- PsErrLambdaCase- -> text "Illegal lambda-case (use LambdaCase)"-- PsErrEmptyLambda- -> text "A lambda requires at least one parameter"-- PsErrNumUnderscores reason- -> text $ case reason of- NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals"- NumUnderscore_Float -> "Use NumericUnderscores to allow underscores in floating literals"-- PsErrPrimStringInvalidChar- -> text "primitive string literal must contain only characters <= \'\\xFF\'"-- PsErrMissingBlock- -> text "Missing block"-- PsErrLexer err kind- -> hcat- [ text $ case err of- LexError -> "lexical error"- LexUnknownPragma -> "unknown pragma"- LexErrorInPragma -> "lexical error in pragma"- LexNumEscapeRange -> "numeric escape sequence out of range"- LexStringCharLit -> "lexical error in string/character literal"- LexStringCharLitEOF -> "unexpected end-of-file in string/character literal"- LexUnterminatedComment -> "unterminated `{-'"- LexUnterminatedOptions -> "unterminated OPTIONS pragma"- LexUnterminatedQQ -> "unterminated quasiquotation"--- , text $ case kind of- LexErrKind_EOF -> " at end of input"- LexErrKind_UTF8 -> " (UTF-8 decoding error)"- LexErrKind_Char c -> " at character " ++ show c- ]-- PsErrSuffixAT- -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."-- PsErrParse token- | null token- -> text "parse error (possibly incorrect indentation or mismatched brackets)"-- | otherwise- -> text "parse error on input" <+> quotes (text token)-- PsErrCmmLexer- -> text "Cmm lexical error"-- PsErrUnsupportedBoxedSumExpr s- -> hang (text "Boxed sums not supported:") 2- (pprSumOrTuple Boxed s)-- PsErrUnsupportedBoxedSumPat s- -> hang (text "Boxed sums not supported:") 2- (pprSumOrTuple Boxed s)-- PsErrUnexpectedQualifiedConstructor v- -> hang (text "Expected an unqualified type constructor:") 2- (ppr v)-- PsErrTupleSectionInPat- -> text "Tuple section in pattern context"-- PsErrIllegalBangPattern e- -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e-- PsErrOpFewArgs (StarIsType star_is_type) op- -> text "Operator applied to too few arguments:" <+> ppr op- $$ starInfo star_is_type op-- PsErrImportQualifiedTwice- -> text "Multiple occurrences of 'qualified'"-- PsErrImportPostQualified- -> text "Found" <+> quotes (text "qualified")- <+> text "in postpositive position. "- $$ text "To allow this, enable language extension 'ImportQualifiedPost'"-- PsErrIllegalExplicitNamespace- -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"-- PsErrVarForTyCon name- -> text "Expecting a type constructor but found a variable,"- <+> quotes (ppr name) <> text "."- $$ if isSymOcc $ rdrNameOcc name- then text "If" <+> quotes (ppr name) <+> text "is a type constructor"- <+> text "then enable ExplicitNamespaces and use the 'type' keyword."- else empty-- PsErrIllegalPatSynExport- -> text "Illegal export form (use PatternSynonyms to enable)"-- PsErrMalformedEntityString- -> text "Malformed entity string"-- PsErrDotsInRecordUpdate- -> text "You cannot use `..' in a record update"-- PsErrPrecedenceOutOfRange i- -> text "Precedence out of range: " <> int i-- PsErrOverloadedRecordDotInvalid- -> text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)"-- PsErrOverloadedRecordUpdateNoQualifiedFields- -> text "Fields cannot be qualified when OverloadedRecordUpdate is enabled"-- PsErrOverloadedRecordUpdateNotEnabled- -> text "OverloadedRecordUpdate needs to be enabled"-- PsErrInvalidDataCon t- -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2- (ppr t)-- PsErrInvalidInfixDataCon lhs tc rhs- -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")- 2 (ppr lhs <+> ppr tc <+> ppr rhs)-- PsErrUnpackDataCon- -> text "{-# UNPACK #-} cannot be applied to a data constructor."-- PsErrUnexpectedKindAppInDataCon lhs ki- -> hang (text "Unexpected kind application in a data/newtype declaration:") 2- (ppr lhs <+> text "@" <> ppr ki)-- PsErrInvalidRecordCon p- -> text "Not a record constructor:" <+> ppr p-- PsErrIllegalUnboxedStringInPat lit- -> text "Illegal unboxed string literal in pattern:" $$ ppr lit-- PsErrDoNotationInPat- -> text "do-notation in pattern"-- PsErrIfTheElseInPat- -> text "(if ... then ... else ...)-syntax in pattern"-- PsErrLambdaCaseInPat- -> text "(\\case ...)-syntax in pattern"-- PsErrCaseInPat- -> text "(case ... of ...)-syntax in pattern"-- PsErrLetInPat- -> text "(let ... in ...)-syntax in pattern"-- PsErrLambdaInPat- -> text "Lambda-syntax in pattern."- $$ text "Pattern matching on functions is not possible."-- PsErrArrowExprInPat e- -> text "Expression syntax in pattern:" <+> ppr e-- PsErrArrowCmdInPat c- -> text "Command syntax in pattern:" <+> ppr c-- PsErrArrowCmdInExpr c- -> vcat- [ text "Arrow command found where an expression was expected:"- , nest 2 (ppr c)- ]-- PsErrViewPatInExpr a b- -> sep [ text "View pattern in expression context:"- , nest 4 (ppr a <+> text "->" <+> ppr b)- ]-- PsErrTypeAppWithoutSpace v e- -> sep [ text "@-pattern in expression context:"- , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)- ]- $$ text "Type application syntax requires a space before '@'"--- PsErrLazyPatWithoutSpace e- -> sep [ text "Lazy pattern in expression context:"- , nest 4 (text "~" <> ppr e)- ]- $$ text "Did you mean to add a space after the '~'?"-- PsErrBangPatWithoutSpace e- -> sep [ text "Bang pattern in expression context:"- , nest 4 (text "!" <> ppr e)- ]- $$ text "Did you mean to add a space after the '!'?"-- PsErrUnallowedPragma prag- -> hang (text "A pragma is not allowed in this position:") 2- (ppr prag)-- PsErrQualifiedDoInCmd m- -> hang (text "Parse error in command:") 2 $- text "Found a qualified" <+> ppr m <> text ".do block in a command, but"- $$ text "qualified 'do' is not supported in commands."-- PsErrParseErrorInCmd s- -> hang (text "Parse error in command:") 2 s-- PsErrParseErrorInPat s- -> text "Parse error in pattern:" <+> s--- PsErrInvalidInfixHole- -> text "Invalid infix hole, expected an infix operator"-- PsErrSemiColonsInCondExpr c st t se e- -> text "Unexpected semi-colons in conditional:"- $$ nest 4 expr- $$ text "Perhaps you meant to use DoAndIfThenElse?"- where- pprOptSemi True = semi- pprOptSemi False = empty- expr = text "if" <+> ppr c <> pprOptSemi st <+>- text "then" <+> ppr t <> pprOptSemi se <+>- text "else" <+> ppr e-- PsErrSemiColonsInCondCmd c st t se e- -> text "Unexpected semi-colons in conditional:"- $$ nest 4 expr- $$ text "Perhaps you meant to use DoAndIfThenElse?"- where- pprOptSemi True = semi- pprOptSemi False = empty- expr = text "if" <+> ppr c <> pprOptSemi st <+>- text "then" <+> ppr t <> pprOptSemi se <+>- text "else" <+> ppr e--- PsErrAtInPatPos- -> text "Found a binding for the"- <+> quotes (text "@")- <+> text "operator in a pattern position."- $$ perhaps_as_pat-- PsErrLambdaCmdInFunAppCmd a- -> pp_unexpected_fun_app (text "lambda command") a-- PsErrCaseCmdInFunAppCmd a- -> pp_unexpected_fun_app (text "case command") a-- PsErrIfCmdInFunAppCmd a- -> pp_unexpected_fun_app (text "if command") a-- PsErrLetCmdInFunAppCmd a- -> pp_unexpected_fun_app (text "let command") a-- PsErrDoCmdInFunAppCmd a- -> pp_unexpected_fun_app (text "do command") a-- PsErrDoInFunAppExpr m a- -> pp_unexpected_fun_app (prependQualified m (text "do block")) a-- PsErrMDoInFunAppExpr m a- -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a-- PsErrLambdaInFunAppExpr a- -> pp_unexpected_fun_app (text "lambda expression") a-- PsErrCaseInFunAppExpr a- -> pp_unexpected_fun_app (text "case expression") a-- PsErrLambdaCaseInFunAppExpr a- -> pp_unexpected_fun_app (text "lambda-case expression") a-- PsErrLetInFunAppExpr a- -> pp_unexpected_fun_app (text "let expression") a-- PsErrIfInFunAppExpr a- -> pp_unexpected_fun_app (text "if expression") a-- PsErrProcInFunAppExpr a- -> pp_unexpected_fun_app (text "proc expression") a-- PsErrMalformedTyOrClDecl ty- -> text "Malformed head of type or class declaration:"- <+> ppr ty-- PsErrIllegalWhereInDataDecl- -> vcat- [ text "Illegal keyword 'where' in data declaration"- , text "Perhaps you intended to use GADTs or a similar language"- , text "extension to enable syntax: data T where"- ]-- PsErrIllegalTraditionalRecordSyntax s- -> text "Illegal record syntax (use TraditionalRecordSyntax):"- <+> s-- PsErrParseErrorOnInput occ- -> text "parse error on input" <+> ftext (occNameFS occ)-- PsErrIllegalDataTypeContext c- -> text "Illegal datatype context (use DatatypeContexts):"- <+> pprLHsContext (Just c)-- PsErrMalformedDecl what for- -> text "Malformed" <+> what- <+> text "declaration for" <+> quotes (ppr for)-- PsErrUnexpectedTypeAppInDecl ki what for- -> vcat [ text "Unexpected type application"- <+> text "@" <> ppr ki- , text "In the" <+> what- <+> text "declaration for"- <+> quotes (ppr for)- ]-- PsErrNotADataCon name- -> text "Not a data constructor:" <+> quotes (ppr name)-- PsErrRecordSyntaxInPatSynDecl pat- -> text "record syntax not supported for pattern synonym declarations:"- $$ ppr pat-- PsErrEmptyWhereInPatSynDecl patsyn_name- -> text "pattern synonym 'where' clause cannot be empty"- $$ text "In the pattern synonym declaration for: "- <+> ppr (patsyn_name)-- PsErrInvalidWhereBindInPatSynDecl patsyn_name decl- -> text "pattern synonym 'where' clause must bind the pattern synonym's name"- <+> quotes (ppr patsyn_name) $$ ppr decl-- PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl- -> text "pattern synonym 'where' clause must contain a single binding:"- $$ ppr decl-- PsErrDeclSpliceNotAtTopLevel d- -> hang (text "Declaration splices are allowed only"- <+> text "at the top level:")- 2 (ppr d)-- PsErrInferredTypeVarNotAllowed- -> text "Inferred type variables are not allowed here"-- PsErrIllegalRoleName role nearby- -> text "Illegal role name" <+> quotes (ppr role)- $$ case nearby of- [] -> empty- [r] -> text "Perhaps you meant" <+> quotes (ppr r)- -- will this last case ever happen??- _ -> hang (text "Perhaps you meant one of these:")- 2 (pprWithCommas (quotes . ppr) nearby)-- PsErrMultipleNamesInStandaloneKindSignature vs- -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")- 2 (pprWithCommas ppr vs)- , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."- ]-- PsErrIllegalImportBundleForm- -> text "Illegal import form, this syntax can only be used to bundle"- $+$ text "pattern synonyms with types in module exports."-- PsErrInvalidTypeSignature lhs- -> text "Invalid type signature:"- <+> ppr lhs- <+> text ":: ..."- $$ text hint- where- hint | foreign_RDR `looks_like` lhs- = "Perhaps you meant to use ForeignFunctionInterface?"- | default_RDR `looks_like` lhs- = "Perhaps you meant to use DefaultSignatures?"- | pattern_RDR `looks_like` lhs- = "Perhaps you meant to use PatternSynonyms?"- | otherwise- = "Should be of form <variable> :: <type>"-- -- A common error is to forget the ForeignFunctionInterface flag- -- so check for that, and suggest. cf #3805- -- Sadly 'foreign import' still barfs 'parse error' because- -- 'import' is a keyword- -- looks_like :: RdrName -> LHsExpr GhcPs -> Bool -- AZ- looks_like s (L _ (HsVar _ (L _ v))) = v == s- looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs- looks_like _ _ = False-- foreign_RDR = mkUnqual varName (fsLit "foreign")- default_RDR = mkUnqual varName (fsLit "default")- pattern_RDR = mkUnqual varName (fsLit "pattern")-- PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where- -> vcat [ text "Unexpected type" <+> quotes (ppr t)- , text "In the" <+> what- <+> text "declaration for" <+> quotes tc'- , vcat[ (text "A" <+> what- <+> text "declaration should have form")- , nest 2- (what- <+> tc'- <+> hsep (map text (takeList tparms allNameStrings))- <+> equals_or_where) ] ]- where- -- Avoid printing a constraint tuple in the error message. Print- -- a plain old tuple instead (since that's what the user probably- -- wrote). See #14907- tc' = ppr $ filterCTuple tc-- PsErrCmmParser cmm_err -> case cmm_err of- CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name- CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun- CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv- CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety- CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint-- PsErrExpectedHyphen- -> text "Expected a hyphen"-- PsErrSpaceInSCC- -> text "Spaces are not allowed in SCCs"-- PsErrEmptyDoubleQuotes th_on- -> if th_on then vcat (msg ++ th_msg) else vcat msg- where- msg = [ text "Parser error on `''`"- , text "Character literals may not be empty"- ]- th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"- , text "but the type variable or constructor is missing"- ]-- PsErrInvalidPackageName pkg- -> vcat- [ text "Parse error" <> colon <+> quotes (ftext pkg)- , text "Version number or non-alphanumeric" <+>- text "character in package name"- ]-- PsErrInvalidRuleActivationMarker- -> text "Invalid rule activation marker"-- PsErrLinearFunction- -> text "Enable LinearTypes to allow linear functions"-- PsErrMultiWayIf- -> text "Multi-way if-expressions need MultiWayIf turned on"-- PsErrExplicitForall is_unicode- -> vcat- [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"- , text "Perhaps you intended to use RankNTypes or a similar language"- , text "extension to enable explicit-forall syntax:" <+>- forallSym is_unicode <+> text "<tvs>. <type>"- ]- where- forallSym True = text "∀"- forallSym False = text "forall"-- PsErrIllegalQualifiedDo qdoDoc- -> vcat- [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"- , text "Perhaps you intended to use QualifiedDo"- ]--pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc-pp_unexpected_fun_app e a =- text "Unexpected " <> e <> text " in function application:"- $$ nest 4 (ppr a)- $$ text "You could write it with parentheses"- $$ text "Or perhaps you meant to enable BlockArguments?"--pp_hint :: PsHint -> SDoc-pp_hint = \case- SuggestTH -> text "Perhaps you intended to use TemplateHaskell"- SuggestDo -> text "Perhaps this statement should be within a 'do' block?"- SuggestMissingDo -> text "Possibly caused by a missing 'do'?"- SuggestRecursiveDo -> text "Perhaps you intended to use RecursiveDo"- SuggestLetInDo -> text "Perhaps you need a 'let' in a 'do' block?"- $$ text "e.g. 'let x = 5' instead of 'x = 5'"- SuggestPatternSynonyms -> text "Perhaps you intended to use PatternSynonyms"-- SuggestInfixBindMaybeAtPat fun- -> text "In a function binding for the"- <+> quotes (ppr fun)- <+> text "operator."- $$ if opIsAt fun- then perhaps_as_pat- else empty- TypeApplicationsInPatternsOnlyDataCons ->- text "Type applications in patterns are only allowed on data constructors."--perhaps_as_pat :: SDoc-perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage++module GHC.Parser.Errors.Ppr where++import GHC.Prelude+import GHC.Driver.Flags+import GHC.Parser.Errors.Types+import GHC.Parser.Types+import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader (opIsAt, starInfo, rdrNameOcc, mkUnqual)+import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Data.FastString+import GHC.Data.Maybe (catMaybes)+import GHC.Hs.Expr (prependQualified,HsExpr(..))+import GHC.Hs.Type (pprLHsContext)+import GHC.Builtin.Names (allNameStrings)+import GHC.Builtin.Types (filterCTuple)+import qualified GHC.LanguageExtensions as LangExt+++instance Diagnostic PsMessage where+ diagnosticMessage = \case+ PsUnknownMessage m+ -> diagnosticMessage m++ PsWarnHaddockInvalidPos+ -> mkSimpleDecorated $ text "A Haddock comment cannot appear in this position and will be ignored."+ PsWarnHaddockIgnoreMulti+ -> mkSimpleDecorated $+ text "Multiple Haddock comments for a single entity are not allowed." $$+ text "The extraneous comment will be ignored."+ PsWarnTab tc+ -> mkSimpleDecorated $+ text "Tab character found here"+ <> (if tc == 1+ then text ""+ else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))+ <> text "."+ PsWarnTransitionalLayout reason+ -> mkSimpleDecorated $+ text "transitional layout will not be accepted in the future:"+ $$ text (case reason of+ TransLayout_Where -> "`where' clause at the same depth as implicit layout block"+ TransLayout_Pipe -> "`|' at the same depth as implicit layout block"+ )+ PsWarnOperatorWhitespaceExtConflict sym+ -> let mk_prefix_msg operator_symbol extension_name syntax_meaning =+ text "The prefix use of a" <+> quotes (text operator_symbol)+ <+> text "would denote" <+> text syntax_meaning+ $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")+ $$ text "Suggested fix: add whitespace after the"+ <+> quotes (text operator_symbol) <> char '.'+ in mkSimpleDecorated $+ case sym of+ OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "%" "LinearTypes" "a multiplicity annotation"+ OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "$" "TemplateHaskell" "an untyped splice"+ OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice"+ PsWarnOperatorWhitespace sym occ_type+ -> let mk_msg occ_type_str =+ text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)+ <+> text "might be repurposed as special syntax"+ $$ nest 2 (text "by a future language extension.")+ $$ text "Suggested fix: add whitespace around it."+ in mkSimpleDecorated $+ case occ_type of+ OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"+ OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"+ OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"+ PsWarnStarBinder+ -> mkSimpleDecorated $+ text "Found binding occurrence of" <+> quotes (text "*")+ <+> text "yet StarIsType is enabled."+ $$ text "NB. To use (or export) this operator in"+ <+> text "modules with StarIsType,"+ $$ text " including the definition module, you must qualify it."+ PsWarnStarIsType+ -> mkSimpleDecorated $+ text "Using" <+> quotes (text "*")+ <+> text "(or its Unicode variant) to mean"+ <+> quotes (text "Data.Kind.Type")+ $$ text "relies on the StarIsType extension, which will become"+ $$ text "deprecated in the future."+ $$ text "Suggested fix: use" <+> quotes (text "Type")+ <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."+ PsWarnUnrecognisedPragma+ -> mkSimpleDecorated $ text "Unrecognised pragma"+ PsWarnImportPreQualified+ -> mkSimpleDecorated $+ text "Found" <+> quotes (text "qualified")+ <+> text "in prepositive position"+ $$ text "Suggested fix: place " <+> quotes (text "qualified")+ <+> text "after the module name instead."+ $$ text "To allow this, enable language extension 'ImportQualifiedPost'"++ PsErrLexer err kind+ -> mkSimpleDecorated $ hcat+ [ text $ case err of+ LexError -> "lexical error"+ LexUnknownPragma -> "unknown pragma"+ LexErrorInPragma -> "lexical error in pragma"+ LexNumEscapeRange -> "numeric escape sequence out of range"+ LexStringCharLit -> "lexical error in string/character literal"+ LexStringCharLitEOF -> "unexpected end-of-file in string/character literal"+ LexUnterminatedComment -> "unterminated `{-'"+ LexUnterminatedOptions -> "unterminated OPTIONS pragma"+ LexUnterminatedQQ -> "unterminated quasiquotation"++ , text $ case kind of+ LexErrKind_EOF -> " at end of input"+ LexErrKind_UTF8 -> " (UTF-8 decoding error)"+ LexErrKind_Char c -> " at character " ++ show c+ ]+ PsErrParse token _details+ | null token+ -> mkSimpleDecorated $ text "parse error (possibly incorrect indentation or mismatched brackets)"+ | otherwise+ -> mkSimpleDecorated $ text "parse error on input" <+> quotes (text token)+ PsErrCmmLexer+ -> mkSimpleDecorated $ text "Cmm lexical error"+ PsErrCmmParser cmm_err -> mkSimpleDecorated $ case cmm_err of+ CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name+ CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun+ CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv+ CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety+ CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint++ PsErrTypeAppWithoutSpace v e+ -> mkSimpleDecorated $+ sep [ text "@-pattern in expression context:"+ , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)+ ]+ $$ text "Type application syntax requires a space before '@'"+ PsErrLazyPatWithoutSpace e+ -> mkSimpleDecorated $+ sep [ text "Lazy pattern in expression context:"+ , nest 4 (text "~" <> ppr e)+ ]+ $$ text "Did you mean to add a space after the '~'?"+ PsErrBangPatWithoutSpace e+ -> mkSimpleDecorated $+ sep [ text "Bang pattern in expression context:"+ , nest 4 (text "!" <> ppr e)+ ]+ $$ text "Did you mean to add a space after the '!'?"+ PsErrInvalidInfixHole+ -> mkSimpleDecorated $ text "Invalid infix hole, expected an infix operator"+ PsErrExpectedHyphen+ -> mkSimpleDecorated $ text "Expected a hyphen"+ PsErrSpaceInSCC+ -> mkSimpleDecorated $ text "Spaces are not allowed in SCCs"+ PsErrEmptyDoubleQuotes th_on+ -> mkSimpleDecorated $ if th_on then vcat (msg ++ th_msg) else vcat msg+ where+ msg = [ text "Parser error on `''`"+ , text "Character literals may not be empty"+ ]+ th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"+ , text "but the type variable or constructor is missing"+ ]++ PsErrLambdaCase+ -> mkSimpleDecorated $ text "Illegal lambda-case (use LambdaCase)"+ PsErrEmptyLambda+ -> mkSimpleDecorated $ text "A lambda requires at least one parameter"+ PsErrLinearFunction+ -> mkSimpleDecorated $ text "Enable LinearTypes to allow linear functions"+ PsErrOverloadedRecordUpdateNotEnabled+ -> mkSimpleDecorated $ text "OverloadedRecordUpdate needs to be enabled"+ PsErrMultiWayIf+ -> mkSimpleDecorated $ text "Multi-way if-expressions need MultiWayIf turned on"+ PsErrNumUnderscores reason+ -> mkSimpleDecorated $+ text $ case reason of+ NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals"+ NumUnderscore_Float -> "Use NumericUnderscores to allow underscores in floating literals"+ PsErrIllegalBangPattern e+ -> mkSimpleDecorated $ text "Illegal bang-pattern (use BangPatterns):" $$ ppr e+ PsErrOverloadedRecordDotInvalid+ -> mkSimpleDecorated $+ text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)"+ PsErrIllegalPatSynExport+ -> mkSimpleDecorated $ text "Illegal export form (use PatternSynonyms to enable)"+ PsErrOverloadedRecordUpdateNoQualifiedFields+ -> mkSimpleDecorated $ text "Fields cannot be qualified when OverloadedRecordUpdate is enabled"+ PsErrExplicitForall is_unicode+ -> mkSimpleDecorated $ vcat+ [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"+ , text "Perhaps you intended to use RankNTypes or a similar language"+ , text "extension to enable explicit-forall syntax:" <+>+ forallSym is_unicode <+> text "<tvs>. <type>"+ ]+ where+ forallSym True = text "∀"+ forallSym False = text "forall"+ PsErrIllegalQualifiedDo qdoDoc+ -> mkSimpleDecorated $ vcat+ [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"+ , text "Perhaps you intended to use QualifiedDo"+ ]+ PsErrQualifiedDoInCmd m+ -> mkSimpleDecorated $+ hang (text "Parse error in command:") 2 $+ text "Found a qualified" <+> ppr m <> text ".do block in a command, but"+ $$ text "qualified 'do' is not supported in commands."+ PsErrRecordSyntaxInPatSynDecl pat+ -> mkSimpleDecorated $+ text "record syntax not supported for pattern synonym declarations:"+ $$ ppr pat+ PsErrEmptyWhereInPatSynDecl patsyn_name+ -> mkSimpleDecorated $+ text "pattern synonym 'where' clause cannot be empty"+ $$ text "In the pattern synonym declaration for: "+ <+> ppr (patsyn_name)+ PsErrInvalidWhereBindInPatSynDecl patsyn_name decl+ -> mkSimpleDecorated $+ text "pattern synonym 'where' clause must bind the pattern synonym's name"+ <+> quotes (ppr patsyn_name) $$ ppr decl+ PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl+ -> mkSimpleDecorated $+ text "pattern synonym 'where' clause must contain a single binding:"+ $$ ppr decl+ PsErrDeclSpliceNotAtTopLevel d+ -> mkSimpleDecorated $+ hang (text "Declaration splices are allowed only"+ <+> text "at the top level:")+ 2 (ppr d)+ PsErrMultipleNamesInStandaloneKindSignature vs+ -> mkSimpleDecorated $+ vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")+ 2 (pprWithCommas ppr vs)+ , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."+ ]+ PsErrIllegalExplicitNamespace+ -> mkSimpleDecorated $+ text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"++ PsErrUnallowedPragma prag+ -> mkSimpleDecorated $+ hang (text "A pragma is not allowed in this position:") 2+ (ppr prag)+ PsErrImportPostQualified+ -> mkSimpleDecorated $+ text "Found" <+> quotes (text "qualified")+ <+> text "in postpositive position. "+ $$ text "To allow this, enable language extension 'ImportQualifiedPost'"+ PsErrImportQualifiedTwice+ -> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'"+ PsErrIllegalImportBundleForm+ -> mkSimpleDecorated $+ text "Illegal import form, this syntax can only be used to bundle"+ $+$ text "pattern synonyms with types in module exports."+ PsErrInvalidRuleActivationMarker+ -> mkSimpleDecorated $ text "Invalid rule activation marker"++ PsErrMissingBlock+ -> mkSimpleDecorated $ text "Missing block"+ PsErrUnsupportedBoxedSumExpr s+ -> mkSimpleDecorated $+ hang (text "Boxed sums not supported:") 2+ (pprSumOrTuple Boxed s)+ PsErrUnsupportedBoxedSumPat s+ -> mkSimpleDecorated $+ hang (text "Boxed sums not supported:") 2+ (pprSumOrTuple Boxed s)+ PsErrUnexpectedQualifiedConstructor v+ -> mkSimpleDecorated $+ hang (text "Expected an unqualified type constructor:") 2+ (ppr v)+ PsErrTupleSectionInPat+ -> mkSimpleDecorated $ text "Tuple section in pattern context"+ PsErrOpFewArgs (StarIsType star_is_type) op+ -> mkSimpleDecorated $+ text "Operator applied to too few arguments:" <+> ppr op+ $$ starInfo star_is_type op+ PsErrVarForTyCon name+ -> mkSimpleDecorated $+ text "Expecting a type constructor but found a variable,"+ <+> quotes (ppr name) <> text "."+ $$ if isSymOcc $ rdrNameOcc name+ then text "If" <+> quotes (ppr name) <+> text "is a type constructor"+ <+> text "then enable ExplicitNamespaces and use the 'type' keyword."+ else empty+ PsErrMalformedEntityString+ -> mkSimpleDecorated $ text "Malformed entity string"+ PsErrDotsInRecordUpdate+ -> mkSimpleDecorated $ text "You cannot use `..' in a record update"+ PsErrInvalidDataCon t+ -> mkSimpleDecorated $+ hang (text "Cannot parse data constructor in a data/newtype declaration:") 2+ (ppr t)+ PsErrInvalidInfixDataCon lhs tc rhs+ -> mkSimpleDecorated $+ hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") 2+ (ppr lhs <+> ppr tc <+> ppr rhs)+ PsErrUnpackDataCon+ -> mkSimpleDecorated $ text "{-# UNPACK #-} cannot be applied to a data constructor."+ PsErrUnexpectedKindAppInDataCon lhs ki+ -> mkSimpleDecorated $+ hang (text "Unexpected kind application in a data/newtype declaration:") 2+ (ppr lhs <+> text "@" <> ppr ki)+ PsErrInvalidRecordCon p+ -> mkSimpleDecorated $ text "Not a record constructor:" <+> ppr p+ PsErrIllegalUnboxedStringInPat lit+ -> mkSimpleDecorated $ text "Illegal unboxed string literal in pattern:" $$ ppr lit+ PsErrDoNotationInPat+ -> mkSimpleDecorated $ text "do-notation in pattern"+ PsErrIfThenElseInPat+ -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"+ PsErrLambdaCaseInPat+ -> mkSimpleDecorated $ text "(\\case ...)-syntax in pattern"+ PsErrCaseInPat+ -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"+ PsErrLetInPat+ -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern"+ PsErrLambdaInPat+ -> mkSimpleDecorated $+ text "Lambda-syntax in pattern."+ $$ text "Pattern matching on functions is not possible."+ PsErrArrowExprInPat e+ -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e+ PsErrArrowCmdInPat c+ -> mkSimpleDecorated $ text "Command syntax in pattern:" <+> ppr c+ PsErrArrowCmdInExpr c+ -> mkSimpleDecorated $+ vcat+ [ text "Arrow command found where an expression was expected:"+ , nest 2 (ppr c)+ ]+ PsErrViewPatInExpr a b+ -> mkSimpleDecorated $+ sep [ text "View pattern in expression context:"+ , nest 4 (ppr a <+> text "->" <+> ppr b)+ ]+ PsErrLambdaCmdInFunAppCmd a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a+ PsErrCaseCmdInFunAppCmd a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a+ PsErrIfCmdInFunAppCmd a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a+ PsErrLetCmdInFunAppCmd a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let command") a+ PsErrDoCmdInFunAppCmd a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "do command") a+ PsErrDoInFunAppExpr m a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a+ PsErrMDoInFunAppExpr m a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a+ PsErrLambdaInFunAppExpr a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a+ PsErrCaseInFunAppExpr a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a+ PsErrLambdaCaseInFunAppExpr a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda-case expression") a+ PsErrLetInFunAppExpr a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a+ PsErrIfInFunAppExpr a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if expression") a+ PsErrProcInFunAppExpr a+ -> mkSimpleDecorated $ pp_unexpected_fun_app (text "proc expression") a+ PsErrMalformedTyOrClDecl ty+ -> mkSimpleDecorated $+ text "Malformed head of type or class declaration:" <+> ppr ty+ PsErrIllegalWhereInDataDecl+ -> mkSimpleDecorated $+ vcat+ [ text "Illegal keyword 'where' in data declaration"+ , text "Perhaps you intended to use GADTs or a similar language"+ , text "extension to enable syntax: data T where"+ ]+ PsErrIllegalDataTypeContext c+ -> mkSimpleDecorated $+ text "Illegal datatype context (use DatatypeContexts):"+ <+> pprLHsContext (Just c)+ PsErrPrimStringInvalidChar+ -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'"+ PsErrSuffixAT+ -> mkSimpleDecorated $+ text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."+ PsErrPrecedenceOutOfRange i+ -> mkSimpleDecorated $ text "Precedence out of range: " <> int i+ PsErrSemiColonsInCondExpr c st t se e+ -> mkSimpleDecorated $+ text "Unexpected semi-colons in conditional:"+ $$ nest 4 expr+ $$ text "Perhaps you meant to use DoAndIfThenElse?"+ where+ pprOptSemi True = semi+ pprOptSemi False = empty+ expr = text "if" <+> ppr c <> pprOptSemi st <+>+ text "then" <+> ppr t <> pprOptSemi se <+>+ text "else" <+> ppr e+ PsErrSemiColonsInCondCmd c st t se e+ -> mkSimpleDecorated $+ text "Unexpected semi-colons in conditional:"+ $$ nest 4 expr+ $$ text "Perhaps you meant to use DoAndIfThenElse?"+ where+ pprOptSemi True = semi+ pprOptSemi False = empty+ expr = text "if" <+> ppr c <> pprOptSemi st <+>+ text "then" <+> ppr t <> pprOptSemi se <+>+ text "else" <+> ppr e+ PsErrAtInPatPos+ -> mkSimpleDecorated $+ text "Found a binding for the"+ <+> quotes (text "@")+ <+> text "operator in a pattern position."+ $$ perhapsAsPat+ PsErrParseErrorOnInput occ+ -> mkSimpleDecorated $ text "parse error on input" <+> ftext (occNameFS occ)+ PsErrMalformedDecl what for+ -> mkSimpleDecorated $+ text "Malformed" <+> what+ <+> text "declaration for" <+> quotes (ppr for)+ PsErrUnexpectedTypeAppInDecl ki what for+ -> mkSimpleDecorated $+ vcat [ text "Unexpected type application"+ <+> text "@" <> ppr ki+ , text "In the" <+> what+ <+> text "declaration for"+ <+> quotes (ppr for)+ ]+ PsErrNotADataCon name+ -> mkSimpleDecorated $ text "Not a data constructor:" <+> quotes (ppr name)+ PsErrInferredTypeVarNotAllowed+ -> mkSimpleDecorated $ text "Inferred type variables are not allowed here"+ PsErrIllegalTraditionalRecordSyntax s+ -> mkSimpleDecorated $+ text "Illegal record syntax (use TraditionalRecordSyntax):" <+> s+ PsErrParseErrorInCmd s+ -> mkSimpleDecorated $ hang (text "Parse error in command:") 2 s+ PsErrInPat s details+ -> let msg = parse_error_in_pat+ body = case details of+ PEIP_NegApp -> text "-" <> ppr s+ PEIP_TypeArgs peipd_tyargs+ | not (null peipd_tyargs) -> ppr s <+> vcat [+ hsep [text "@" <> ppr t | t <- peipd_tyargs]+ , text "Type applications in patterns are only allowed on data constructors."+ ]+ | otherwise -> ppr s+ PEIP_OtherPatDetails (ParseContext (Just fun) _)+ -> ppr s <+> text "In a function binding for the"+ <+> quotes (ppr fun)+ <+> text "operator."+ $$ if opIsAt fun+ then perhapsAsPat+ else empty+ _ -> ppr s+ in mkSimpleDecorated $ msg <+> body+ PsErrParseRightOpSectionInPat infixOcc s+ -> mkSimpleDecorated $ parse_error_in_pat <+> pprInfixOcc infixOcc <> ppr s+ PsErrIllegalRoleName role nearby+ -> mkSimpleDecorated $+ text "Illegal role name" <+> quotes (ppr role)+ $$ case nearby of+ [] -> empty+ [r] -> text "Perhaps you meant" <+> quotes (ppr r)+ -- will this last case ever happen??+ _ -> hang (text "Perhaps you meant one of these:")+ 2 (pprWithCommas (quotes . ppr) nearby)+ PsErrInvalidTypeSignature lhs+ -> mkSimpleDecorated $+ text "Invalid type signature:"+ <+> ppr lhs+ <+> text ":: ..."+ $$ text hint+ where+ hint | foreign_RDR `looks_like` lhs+ = "Perhaps you meant to use ForeignFunctionInterface?"+ | default_RDR `looks_like` lhs+ = "Perhaps you meant to use DefaultSignatures?"+ | pattern_RDR `looks_like` lhs+ = "Perhaps you meant to use PatternSynonyms?"+ | otherwise+ = "Should be of form <variable> :: <type>"++ -- A common error is to forget the ForeignFunctionInterface flag+ -- so check for that, and suggest. cf #3805+ -- Sadly 'foreign import' still barfs 'parse error' because+ -- 'import' is a keyword+ -- looks_like :: RdrName -> LHsExpr GhcPsErr -> Bool -- AZ+ looks_like s (L _ (HsVar _ (L _ v))) = v == s+ looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs+ looks_like _ _ = False++ foreign_RDR = mkUnqual varName (fsLit "foreign")+ default_RDR = mkUnqual varName (fsLit "default")+ pattern_RDR = mkUnqual varName (fsLit "pattern")+ PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where+ -> mkSimpleDecorated $+ vcat [ text "Unexpected type" <+> quotes (ppr t)+ , text "In the" <+> what+ <+> text "declaration for" <+> quotes tc'+ , vcat[ (text "A" <+> what+ <+> text "declaration should have form")+ , nest 2+ (what+ <+> tc'+ <+> hsep (map text (takeList tparms allNameStrings))+ <+> equals_or_where) ] ]+ where+ -- Avoid printing a constraint tuple in the error message. Print+ -- a plain old tuple instead (since that's what the user probably+ -- wrote). See #14907+ tc' = ppr $ filterCTuple tc+ PsErrInvalidPackageName pkg+ -> mkSimpleDecorated $ vcat+ [ text "Parse error" <> colon <+> quotes (ftext pkg)+ , text "Version number or non-alphanumeric" <+>+ text "character in package name"+ ]++ diagnosticReason = \case+ PsUnknownMessage m -> diagnosticReason m+ PsWarnTab{} -> WarningWithFlag Opt_WarnTabs+ PsWarnTransitionalLayout{} -> WarningWithFlag Opt_WarnAlternativeLayoutRuleTransitional+ PsWarnOperatorWhitespaceExtConflict{} -> WarningWithFlag Opt_WarnOperatorWhitespaceExtConflict+ PsWarnOperatorWhitespace{} -> WarningWithFlag Opt_WarnOperatorWhitespace+ PsWarnHaddockInvalidPos -> WarningWithFlag Opt_WarnInvalidHaddock+ PsWarnHaddockIgnoreMulti -> WarningWithFlag Opt_WarnInvalidHaddock+ PsWarnStarBinder -> WarningWithFlag Opt_WarnStarBinder+ PsWarnStarIsType -> WarningWithFlag Opt_WarnStarIsType+ PsWarnUnrecognisedPragma -> WarningWithFlag Opt_WarnUnrecognisedPragmas+ PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule+ PsErrLexer{} -> ErrorWithoutFlag+ PsErrCmmLexer -> ErrorWithoutFlag+ PsErrCmmParser{} -> ErrorWithoutFlag+ PsErrParse{} -> ErrorWithoutFlag+ PsErrTypeAppWithoutSpace{} -> ErrorWithoutFlag+ PsErrLazyPatWithoutSpace{} -> ErrorWithoutFlag+ PsErrBangPatWithoutSpace{} -> ErrorWithoutFlag+ PsErrInvalidInfixHole -> ErrorWithoutFlag+ PsErrExpectedHyphen -> ErrorWithoutFlag+ PsErrSpaceInSCC -> ErrorWithoutFlag+ PsErrEmptyDoubleQuotes{} -> ErrorWithoutFlag+ PsErrLambdaCase{} -> ErrorWithoutFlag+ PsErrEmptyLambda{} -> ErrorWithoutFlag+ PsErrLinearFunction{} -> ErrorWithoutFlag+ PsErrMultiWayIf{} -> ErrorWithoutFlag+ PsErrOverloadedRecordUpdateNotEnabled{} -> ErrorWithoutFlag+ PsErrNumUnderscores{} -> ErrorWithoutFlag+ PsErrIllegalBangPattern{} -> ErrorWithoutFlag+ PsErrOverloadedRecordDotInvalid{} -> ErrorWithoutFlag+ PsErrIllegalPatSynExport -> ErrorWithoutFlag+ PsErrOverloadedRecordUpdateNoQualifiedFields -> ErrorWithoutFlag+ PsErrExplicitForall{} -> ErrorWithoutFlag+ PsErrIllegalQualifiedDo{} -> ErrorWithoutFlag+ PsErrQualifiedDoInCmd{} -> ErrorWithoutFlag+ PsErrRecordSyntaxInPatSynDecl{} -> ErrorWithoutFlag+ PsErrEmptyWhereInPatSynDecl{} -> ErrorWithoutFlag+ PsErrInvalidWhereBindInPatSynDecl{} -> ErrorWithoutFlag+ PsErrNoSingleWhereBindInPatSynDecl{} -> ErrorWithoutFlag+ PsErrDeclSpliceNotAtTopLevel{} -> ErrorWithoutFlag+ PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag+ PsErrIllegalExplicitNamespace -> ErrorWithoutFlag+ PsErrUnallowedPragma{} -> ErrorWithoutFlag+ PsErrImportPostQualified -> ErrorWithoutFlag+ PsErrImportQualifiedTwice -> ErrorWithoutFlag+ PsErrIllegalImportBundleForm -> ErrorWithoutFlag+ PsErrInvalidRuleActivationMarker -> ErrorWithoutFlag+ PsErrMissingBlock -> ErrorWithoutFlag+ PsErrUnsupportedBoxedSumExpr{} -> ErrorWithoutFlag+ PsErrUnsupportedBoxedSumPat{} -> ErrorWithoutFlag+ PsErrUnexpectedQualifiedConstructor{} -> ErrorWithoutFlag+ PsErrTupleSectionInPat{} -> ErrorWithoutFlag+ PsErrOpFewArgs{} -> ErrorWithoutFlag+ PsErrVarForTyCon{} -> ErrorWithoutFlag+ PsErrMalformedEntityString -> ErrorWithoutFlag+ PsErrDotsInRecordUpdate -> ErrorWithoutFlag+ PsErrInvalidDataCon{} -> ErrorWithoutFlag+ PsErrInvalidInfixDataCon{} -> ErrorWithoutFlag+ PsErrUnpackDataCon -> ErrorWithoutFlag+ PsErrUnexpectedKindAppInDataCon{} -> ErrorWithoutFlag+ PsErrInvalidRecordCon{} -> ErrorWithoutFlag+ PsErrIllegalUnboxedStringInPat{} -> ErrorWithoutFlag+ PsErrDoNotationInPat{} -> ErrorWithoutFlag+ PsErrIfThenElseInPat -> ErrorWithoutFlag+ PsErrLambdaCaseInPat -> ErrorWithoutFlag+ PsErrCaseInPat -> ErrorWithoutFlag+ PsErrLetInPat -> ErrorWithoutFlag+ PsErrLambdaInPat -> ErrorWithoutFlag+ PsErrArrowExprInPat{} -> ErrorWithoutFlag+ PsErrArrowCmdInPat{} -> ErrorWithoutFlag+ PsErrArrowCmdInExpr{} -> ErrorWithoutFlag+ PsErrViewPatInExpr{} -> ErrorWithoutFlag+ PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag+ PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag+ PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag+ PsErrLetCmdInFunAppCmd{} -> ErrorWithoutFlag+ PsErrDoCmdInFunAppCmd{} -> ErrorWithoutFlag+ PsErrDoInFunAppExpr{} -> ErrorWithoutFlag+ PsErrMDoInFunAppExpr{} -> ErrorWithoutFlag+ PsErrLambdaInFunAppExpr{} -> ErrorWithoutFlag+ PsErrCaseInFunAppExpr{} -> ErrorWithoutFlag+ PsErrLambdaCaseInFunAppExpr{} -> ErrorWithoutFlag+ PsErrLetInFunAppExpr{} -> ErrorWithoutFlag+ PsErrIfInFunAppExpr{} -> ErrorWithoutFlag+ PsErrProcInFunAppExpr{} -> ErrorWithoutFlag+ PsErrMalformedTyOrClDecl{} -> ErrorWithoutFlag+ PsErrIllegalWhereInDataDecl -> ErrorWithoutFlag+ PsErrIllegalDataTypeContext{} -> ErrorWithoutFlag+ PsErrPrimStringInvalidChar -> ErrorWithoutFlag+ PsErrSuffixAT -> ErrorWithoutFlag+ PsErrPrecedenceOutOfRange{} -> ErrorWithoutFlag+ PsErrSemiColonsInCondExpr{} -> ErrorWithoutFlag+ PsErrSemiColonsInCondCmd{} -> ErrorWithoutFlag+ PsErrAtInPatPos -> ErrorWithoutFlag+ PsErrParseErrorOnInput{} -> ErrorWithoutFlag+ PsErrMalformedDecl{} -> ErrorWithoutFlag+ PsErrUnexpectedTypeAppInDecl{} -> ErrorWithoutFlag+ PsErrNotADataCon{} -> ErrorWithoutFlag+ PsErrInferredTypeVarNotAllowed -> ErrorWithoutFlag+ PsErrIllegalTraditionalRecordSyntax{} -> ErrorWithoutFlag+ PsErrParseErrorInCmd{} -> ErrorWithoutFlag+ PsErrInPat{} -> ErrorWithoutFlag+ PsErrIllegalRoleName{} -> ErrorWithoutFlag+ PsErrInvalidTypeSignature{} -> ErrorWithoutFlag+ PsErrUnexpectedTypeInDecl{} -> ErrorWithoutFlag+ PsErrInvalidPackageName{} -> ErrorWithoutFlag+ PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag++ diagnosticHints = \case+ PsUnknownMessage m -> diagnosticHints m+ PsWarnTab{} -> [SuggestUseSpaces]+ PsWarnTransitionalLayout{} -> noHints+ PsWarnOperatorWhitespaceExtConflict{} -> noHints+ PsWarnOperatorWhitespace{} -> noHints+ PsWarnHaddockInvalidPos -> noHints+ PsWarnHaddockIgnoreMulti -> noHints+ PsWarnStarBinder -> noHints+ PsWarnStarIsType -> noHints+ PsWarnUnrecognisedPragma -> noHints+ PsWarnImportPreQualified -> noHints+ PsErrLexer{} -> noHints+ PsErrCmmLexer -> noHints+ PsErrCmmParser{} -> noHints+ PsErrParse token PsErrParseDetails{..} -> case token of+ "" -> []+ "$" | not ped_th_enabled -> [SuggestExtension LangExt.TemplateHaskell] -- #7396+ "<-" | ped_mdo_in_last_100 -> [SuggestExtension LangExt.RecursiveDo]+ | otherwise -> [SuggestMissingDo]+ "=" | ped_do_in_last_100 -> [SuggestLetInDo] -- #15849+ _ | not ped_pat_syn_enabled+ , ped_pattern_parsed -> [SuggestExtension LangExt.PatternSynonyms] -- #12429+ | otherwise -> []+ PsErrTypeAppWithoutSpace{} -> noHints+ PsErrLazyPatWithoutSpace{} -> noHints+ PsErrBangPatWithoutSpace{} -> noHints+ PsErrInvalidInfixHole -> noHints+ PsErrExpectedHyphen -> noHints+ PsErrSpaceInSCC -> noHints+ PsErrEmptyDoubleQuotes{} -> noHints+ PsErrLambdaCase{} -> noHints+ PsErrEmptyLambda{} -> noHints+ PsErrLinearFunction{} -> noHints+ PsErrMultiWayIf{} -> noHints+ PsErrOverloadedRecordUpdateNotEnabled{} -> noHints+ PsErrNumUnderscores{} -> noHints+ PsErrIllegalBangPattern{} -> noHints+ PsErrOverloadedRecordDotInvalid{} -> noHints+ PsErrIllegalPatSynExport -> noHints+ PsErrOverloadedRecordUpdateNoQualifiedFields -> noHints+ PsErrExplicitForall{} -> noHints+ PsErrIllegalQualifiedDo{} -> noHints+ PsErrQualifiedDoInCmd{} -> noHints+ PsErrRecordSyntaxInPatSynDecl{} -> noHints+ PsErrEmptyWhereInPatSynDecl{} -> noHints+ PsErrInvalidWhereBindInPatSynDecl{} -> noHints+ PsErrNoSingleWhereBindInPatSynDecl{} -> noHints+ PsErrDeclSpliceNotAtTopLevel{} -> noHints+ PsErrMultipleNamesInStandaloneKindSignature{} -> noHints+ PsErrIllegalExplicitNamespace -> noHints+ PsErrUnallowedPragma{} -> noHints+ PsErrImportPostQualified -> noHints+ PsErrImportQualifiedTwice -> noHints+ PsErrIllegalImportBundleForm -> noHints+ PsErrInvalidRuleActivationMarker -> noHints+ PsErrMissingBlock -> noHints+ PsErrUnsupportedBoxedSumExpr{} -> noHints+ PsErrUnsupportedBoxedSumPat{} -> noHints+ PsErrUnexpectedQualifiedConstructor{} -> noHints+ PsErrTupleSectionInPat{} -> noHints+ PsErrOpFewArgs{} -> noHints+ PsErrVarForTyCon{} -> noHints+ PsErrMalformedEntityString -> noHints+ PsErrDotsInRecordUpdate -> noHints+ PsErrInvalidDataCon{} -> noHints+ PsErrInvalidInfixDataCon{} -> noHints+ PsErrUnpackDataCon -> noHints+ PsErrUnexpectedKindAppInDataCon{} -> noHints+ PsErrInvalidRecordCon{} -> noHints+ PsErrIllegalUnboxedStringInPat{} -> noHints+ PsErrDoNotationInPat{} -> noHints+ PsErrIfThenElseInPat -> noHints+ PsErrLambdaCaseInPat -> noHints+ PsErrCaseInPat -> noHints+ PsErrLetInPat -> noHints+ PsErrLambdaInPat -> noHints+ PsErrArrowExprInPat{} -> noHints+ PsErrArrowCmdInPat{} -> noHints+ PsErrArrowCmdInExpr{} -> noHints+ PsErrViewPatInExpr{} -> noHints+ PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs+ PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs+ PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs+ PsErrLetCmdInFunAppCmd{} -> suggestParensAndBlockArgs+ PsErrDoCmdInFunAppCmd{} -> suggestParensAndBlockArgs+ PsErrDoInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrMDoInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrLambdaInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrCaseInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrLambdaCaseInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrLetInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrIfInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrProcInFunAppExpr{} -> suggestParensAndBlockArgs+ PsErrMalformedTyOrClDecl{} -> noHints+ PsErrIllegalWhereInDataDecl -> noHints+ PsErrIllegalDataTypeContext{} -> noHints+ PsErrPrimStringInvalidChar -> noHints+ PsErrSuffixAT -> noHints+ PsErrPrecedenceOutOfRange{} -> noHints+ PsErrSemiColonsInCondExpr{} -> noHints+ PsErrSemiColonsInCondCmd{} -> noHints+ PsErrAtInPatPos -> noHints+ PsErrParseErrorOnInput{} -> noHints+ PsErrMalformedDecl{} -> noHints+ PsErrUnexpectedTypeAppInDecl{} -> noHints+ PsErrNotADataCon{} -> noHints+ PsErrInferredTypeVarNotAllowed -> noHints+ PsErrIllegalTraditionalRecordSyntax{} -> noHints+ PsErrParseErrorInCmd{} -> noHints+ PsErrInPat _ details -> case details of+ PEIP_RecPattern args YesPatIsRecursive ctx+ | length args /= 0 -> catMaybes [sug_recdo, sug_missingdo ctx]+ | otherwise -> catMaybes [sug_missingdo ctx]+ PEIP_OtherPatDetails ctx -> catMaybes [sug_missingdo ctx]+ _ -> []+ where+ sug_recdo = Just (SuggestExtension LangExt.RecursiveDo)+ sug_missingdo (ParseContext _ YesIncompleteDoBlock) = Just SuggestMissingDo+ sug_missingdo _ = Nothing+ PsErrParseRightOpSectionInPat{} -> noHints+ PsErrIllegalRoleName{} -> noHints+ PsErrInvalidTypeSignature{} -> noHints+ PsErrUnexpectedTypeInDecl{} -> noHints+ PsErrInvalidPackageName{} -> noHints++suggestParensAndBlockArgs :: [GhcHint]+suggestParensAndBlockArgs =+ [SuggestParentheses, SuggestExtension LangExt.BlockArguments]++pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc+pp_unexpected_fun_app e a =+ text "Unexpected " <> e <> text " in function application:"+ $$ nest 4 (ppr a)++parse_error_in_pat :: SDoc+parse_error_in_pat = text "Parse error in pattern:"++perhapsAsPat :: SDoc+perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
compiler/GHC/Parser/Errors/Types.hs view
@@ -1,9 +1,502 @@+{-# LANGUAGE ExistentialQuantification #-} module GHC.Parser.Errors.Types where +import GHC.Prelude++import Data.Typeable++import GHC.Core.TyCon (Role)+import GHC.Data.FastString+import GHC.Hs+import GHC.Parser.Types import GHC.Types.Error+import GHC.Types.Name.Occurrence (OccName)+import GHC.Types.Name.Reader+import GHC.Unit.Module.Name+import GHC.Utils.Outputable +-- The type aliases below are useful to make some type signatures a bit more+-- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'.++type PsWarning = PsMessage -- /INVARIANT/: The diagnosticReason is a Warning reason+type PsError = PsMessage -- /INVARIANT/: The diagnosticReason is ErrorWithoutFlag+ data PsMessage- = PsUnknownMessage !DiagnosticMessage- -- ^ Simply rewraps a generic 'DiagnosticMessage'. More- -- constructors will be added in the future (#18516).+ =+ {-| An \"unknown\" message from the parser. This type constructor allows+ arbitrary messages to be embedded. The typical use case would be GHC plugins+ willing to emit custom diagnostics.+ -}+ forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a++ {-| PsWarnTab is a warning (controlled by the -Wwarn-tabs flag) that occurs+ when tabulations (tabs) are found within a file.++ Test case(s): parser/should_fail/T12610+ parser/should_compile/T9723b+ parser/should_compile/T9723a+ parser/should_compile/read043+ parser/should_fail/T16270+ warnings/should_compile/T9230++ -}+ | PsWarnTab !Word -- ^ Number of other occurrences other than the first one++ {-| PsWarnTransitionalLayout is a warning (controlled by the+ -Walternative-layout-rule-transitional flag) that occurs when pipes ('|')+ or 'where' are at the same depth of an implicit layout block.++ Example(s):++ f :: IO ()+ f+ | True = do+ let x = ()+ y = ()+ return ()+ | True = return ()++ Test case(s): layout/layout006+ layout/layout003+ layout/layout001++ -}+ | PsWarnTransitionalLayout !TransLayoutReason++ -- | Unrecognised pragma+ | PsWarnUnrecognisedPragma++ -- | Invalid Haddock comment position+ | PsWarnHaddockInvalidPos++ -- | Multiple Haddock comment for the same entity+ | PsWarnHaddockIgnoreMulti++ -- | Found binding occurrence of "*" while StarIsType is enabled+ | PsWarnStarBinder++ -- | Using "*" for "Type" without StarIsType enabled+ | PsWarnStarIsType++ -- | Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled+ | PsWarnImportPreQualified++ | PsWarnOperatorWhitespaceExtConflict !OperatorWhitespaceSymbol++ | PsWarnOperatorWhitespace !FastString !OperatorWhitespaceOccurrence++ -- | LambdaCase syntax used without the extension enabled+ | PsErrLambdaCase++ -- | A lambda requires at least one parameter+ | PsErrEmptyLambda++ -- | Underscores in literals without the extension enabled+ | PsErrNumUnderscores !NumUnderscoreReason++ -- | Invalid character in primitive string+ | PsErrPrimStringInvalidChar++ -- | Missing block+ | PsErrMissingBlock++ -- | Lexer error+ | PsErrLexer !LexErr !LexErrKind++ -- | Suffix occurrence of `@`+ | PsErrSuffixAT++ -- | Parse errors+ | PsErrParse !String !PsErrParseDetails++ -- | Cmm lexer error+ | PsErrCmmLexer++ -- | Unsupported boxed sum in expression+ | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))++ -- | Unsupported boxed sum in pattern+ | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))++ -- | Unexpected qualified constructor+ | PsErrUnexpectedQualifiedConstructor !RdrName++ -- | Tuple section in pattern context+ | PsErrTupleSectionInPat++ -- | Bang-pattern without BangPattterns enabled+ | PsErrIllegalBangPattern !(Pat GhcPs)++ -- | Operator applied to too few arguments+ | PsErrOpFewArgs !StarIsType !RdrName++ -- | Import: multiple occurrences of 'qualified'+ | PsErrImportQualifiedTwice++ -- | Post qualified import without 'ImportQualifiedPost'+ | PsErrImportPostQualified++ -- | Explicit namespace keyword without 'ExplicitNamespaces'+ | PsErrIllegalExplicitNamespace++ -- | Expecting a type constructor but found a variable+ | PsErrVarForTyCon !RdrName++ -- | Illegal export form allowed by PatternSynonyms+ | PsErrIllegalPatSynExport++ -- | Malformed entity string+ | PsErrMalformedEntityString++ -- | Dots used in record update+ | PsErrDotsInRecordUpdate++ -- | Precedence out of range+ | PsErrPrecedenceOutOfRange !Int++ -- | Invalid use of record dot syntax `.'+ | PsErrOverloadedRecordDotInvalid++ -- | `OverloadedRecordUpdate` is not enabled.+ | PsErrOverloadedRecordUpdateNotEnabled++ -- | Can't use qualified fields when OverloadedRecordUpdate is enabled.+ | PsErrOverloadedRecordUpdateNoQualifiedFields++ -- | Cannot parse data constructor in a data/newtype declaration+ | PsErrInvalidDataCon !(HsType GhcPs)++ -- | Cannot parse data constructor in a data/newtype declaration+ | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)++ -- | UNPACK applied to a data constructor+ | PsErrUnpackDataCon++ -- | Unexpected kind application in data/newtype declaration+ | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)++ -- | Not a record constructor+ | PsErrInvalidRecordCon !(PatBuilder GhcPs)++ -- | Illegal unboxed string literal in pattern+ | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)++ -- | Do-notation in pattern+ | PsErrDoNotationInPat++ -- | If-then-else syntax in pattern+ | PsErrIfThenElseInPat++ -- | Lambda-case in pattern+ | PsErrLambdaCaseInPat++ -- | case..of in pattern+ | PsErrCaseInPat++ -- | let-syntax in pattern+ | PsErrLetInPat++ -- | Lambda-syntax in pattern+ | PsErrLambdaInPat++ -- | Arrow expression-syntax in pattern+ | PsErrArrowExprInPat !(HsExpr GhcPs)++ -- | Arrow command-syntax in pattern+ | PsErrArrowCmdInPat !(HsCmd GhcPs)++ -- | Arrow command-syntax in expression+ | PsErrArrowCmdInExpr !(HsCmd GhcPs)++ -- | View-pattern in expression+ | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)++ -- | Type-application without space before '@'+ | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)++ -- | Lazy-pattern ('~') without space after it+ | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs)++ -- | Bang-pattern ('!') without space after it+ | PsErrBangPatWithoutSpace !(LHsExpr GhcPs)++ -- | Pragma not allowed in this position+ | PsErrUnallowedPragma !(HsPragE GhcPs)++ -- | Qualified do block in command+ | PsErrQualifiedDoInCmd !ModuleName++ -- | Invalid infix hole, expected an infix operator+ | PsErrInvalidInfixHole++ -- | Unexpected semi-colons in conditional expression+ | PsErrSemiColonsInCondExpr+ !(HsExpr GhcPs) -- ^ conditional expr+ !Bool -- ^ "then" semi-colon?+ !(HsExpr GhcPs) -- ^ "then" expr+ !Bool -- ^ "else" semi-colon?+ !(HsExpr GhcPs) -- ^ "else" expr++ -- | Unexpected semi-colons in conditional command+ | PsErrSemiColonsInCondCmd+ !(HsExpr GhcPs) -- ^ conditional expr+ !Bool -- ^ "then" semi-colon?+ !(HsCmd GhcPs) -- ^ "then" expr+ !Bool -- ^ "else" semi-colon?+ !(HsCmd GhcPs) -- ^ "else" expr++ -- | @-operator in a pattern position+ | PsErrAtInPatPos++ -- | Unexpected lambda command in function application+ | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)++ -- | Unexpected case command in function application+ | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)++ -- | Unexpected if command in function application+ | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)++ -- | Unexpected let command in function application+ | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs)++ -- | Unexpected do command in function application+ | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs)++ -- | Unexpected do block in function application+ | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)++ -- | Unexpected mdo block in function application+ | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)++ -- | Unexpected lambda expression in function application+ | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)++ -- | Unexpected case expression in function application+ | PsErrCaseInFunAppExpr !(LHsExpr GhcPs)++ -- | Unexpected lambda-case expression in function application+ | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)++ -- | Unexpected let expression in function application+ | PsErrLetInFunAppExpr !(LHsExpr GhcPs)++ -- | Unexpected if expression in function application+ | PsErrIfInFunAppExpr !(LHsExpr GhcPs)++ -- | Unexpected proc expression in function application+ | PsErrProcInFunAppExpr !(LHsExpr GhcPs)++ -- | Malformed head of type or class declaration+ | PsErrMalformedTyOrClDecl !(LHsType GhcPs)++ -- | Illegal 'where' keyword in data declaration+ | PsErrIllegalWhereInDataDecl++ -- | Illegal datatype context+ | PsErrIllegalDataTypeContext !(LHsContext GhcPs)++ -- | Parse error on input+ | PsErrParseErrorOnInput !OccName++ -- | Malformed ... declaration for ...+ | PsErrMalformedDecl !SDoc !RdrName++ -- | Unexpected type application in a declaration+ | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName++ -- | Not a data constructor+ | PsErrNotADataCon !RdrName++ -- | Record syntax used in pattern synonym declaration+ | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs)++ -- | Empty 'where' clause in pattern-synonym declaration+ | PsErrEmptyWhereInPatSynDecl !RdrName++ -- | Invalid binding name in 'where' clause of pattern-synonym declaration+ | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)++ -- | Multiple bindings in 'where' clause of pattern-synonym declaration+ | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)++ -- | Declaration splice not a top-level+ | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)++ -- | Inferred type variables not allowed here+ | PsErrInferredTypeVarNotAllowed++ -- | Multiple names in standalone kind signatures+ | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]++ -- | Illegal import bundle form+ | PsErrIllegalImportBundleForm++ -- | Illegal role name+ | PsErrIllegalRoleName !FastString [Role]++ -- | Invalid type signature+ | PsErrInvalidTypeSignature !(LHsExpr GhcPs)++ -- | Unexpected type in declaration+ | PsErrUnexpectedTypeInDecl !(LHsType GhcPs)+ !SDoc+ !RdrName+ [LHsTypeArg GhcPs]+ !SDoc++ -- | Expected a hyphen+ | PsErrExpectedHyphen++ -- | Found a space in a SCC+ | PsErrSpaceInSCC++ -- | Found two single quotes+ | PsErrEmptyDoubleQuotes !Bool+ -- ^ Is TH on?++ -- | Invalid package name+ | PsErrInvalidPackageName !FastString++ -- | Invalid rule activation marker+ | PsErrInvalidRuleActivationMarker++ -- | Linear function found but LinearTypes not enabled+ | PsErrLinearFunction++ -- | Multi-way if-expression found but MultiWayIf not enabled+ | PsErrMultiWayIf++ -- | Explicit forall found but no extension allowing it is enabled+ | PsErrExplicitForall !Bool+ -- ^ is Unicode forall?++ -- | Found qualified-do without QualifiedDo enabled+ | PsErrIllegalQualifiedDo !SDoc++ -- | Cmm parser error+ | PsErrCmmParser !CmmParserError++ -- | Illegal traditional record syntax+ --+ -- TODO: distinguish errors without using SDoc+ | PsErrIllegalTraditionalRecordSyntax !SDoc++ -- | Parse error in command+ --+ -- TODO: distinguish errors without using SDoc+ | PsErrParseErrorInCmd !SDoc++ -- | Parse error in pattern+ | PsErrInPat !(PatBuilder GhcPs) !PsErrInPatDetails++ -- | Parse error in right operator section pattern+ -- TODO: embed the proper operator, if possible+ | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs)++newtype StarIsType = StarIsType Bool++-- | Extra details about a parse error, which helps+-- us in determining which should be the hints to+-- suggest.+data PsErrParseDetails+ = PsErrParseDetails+ { ped_th_enabled :: !Bool+ -- Is 'TemplateHaskell' enabled?+ , ped_do_in_last_100 :: !Bool+ -- ^ Is there a 'do' in the last 100 characters?+ , ped_mdo_in_last_100 :: !Bool+ -- ^ Is there an 'mdo' in the last 100 characters?+ , ped_pat_syn_enabled :: !Bool+ -- ^ Is 'PatternSynonyms' enabled?+ , ped_pattern_parsed :: !Bool+ -- ^ Did we parse a \"pattern\" keyword?+ }++-- | Is the parsed pattern recursive?+data PatIsRecursive+ = YesPatIsRecursive+ | NoPatIsRecursive++data PatIncompleteDoBlock+ = YesIncompleteDoBlock+ | NoIncompleteDoBlock+ deriving Eq++-- | Extra information for the expression GHC is currently inspecting/parsing.+-- It can be used to generate more informative parser diagnostics and hints.+data ParseContext+ = ParseContext+ { is_infix :: !(Maybe RdrName)+ -- ^ If 'Just', this is an infix+ -- pattern with the binded operator name+ , incomplete_do_block :: !PatIncompleteDoBlock+ -- ^ Did the parser likely fail due to an incomplete do block?+ } deriving Eq++data PsErrInPatDetails+ = PEIP_NegApp+ -- ^ Negative application pattern?+ | PEIP_TypeArgs [HsPatSigType GhcPs]+ -- ^ The list of type arguments for the pattern+ | PEIP_RecPattern [LPat GhcPs] -- ^ The pattern arguments+ !PatIsRecursive -- ^ Is the parsed pattern recursive?+ !ParseContext+ | PEIP_OtherPatDetails !ParseContext++noParseContext :: ParseContext+noParseContext = ParseContext Nothing NoIncompleteDoBlock++incompleteDoBlock :: ParseContext+incompleteDoBlock = ParseContext Nothing YesIncompleteDoBlock++-- | Builds a 'PsErrInPatDetails' with the information provided by the 'ParseContext'.+fromParseContext :: ParseContext -> PsErrInPatDetails+fromParseContext = PEIP_OtherPatDetails++data NumUnderscoreReason+ = NumUnderscore_Integral+ | NumUnderscore_Float+ deriving (Show,Eq,Ord)++data LexErrKind+ = LexErrKind_EOF -- ^ End of input+ | LexErrKind_UTF8 -- ^ UTF-8 decoding error+ | LexErrKind_Char !Char -- ^ Error at given character+ deriving (Show,Eq,Ord)++data LexErr+ = LexError -- ^ Lexical error+ | LexUnknownPragma -- ^ Unknown pragma+ | LexErrorInPragma -- ^ Lexical error in pragma+ | LexNumEscapeRange -- ^ Numeric escape sequence out of range+ | LexStringCharLit -- ^ Lexical error in string/character literal+ | LexStringCharLitEOF -- ^ Unexpected end-of-file in string/character literal+ | LexUnterminatedComment -- ^ Unterminated `{-'+ | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma+ | LexUnterminatedQQ -- ^ Unterminated quasiquotation++-- | Errors from the Cmm parser+data CmmParserError+ = CmmUnknownPrimitive !FastString -- ^ Unknown Cmm primitive+ | CmmUnknownMacro !FastString -- ^ Unknown macro+ | CmmUnknownCConv !String -- ^ Unknown calling convention+ | CmmUnrecognisedSafety !String -- ^ Unrecognised safety+ | CmmUnrecognisedHint !String -- ^ Unrecognised hint++-- | The operator symbol in the 'PsOperatorWhitespaceExtConflictMessage' diagnostic.+data OperatorWhitespaceSymbol+ = OperatorWhitespaceSymbol_PrefixPercent+ | OperatorWhitespaceSymbol_PrefixDollar+ | OperatorWhitespaceSymbol_PrefixDollarDollar++-- | The operator occurrence type in the 'PsOperatorWhitespaceMessage' diagnostic.+data OperatorWhitespaceOccurrence+ = OperatorWhitespaceOccurrence_Prefix+ | OperatorWhitespaceOccurrence_Suffix+ | OperatorWhitespaceOccurrence_TightInfix++data TransLayoutReason+ = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"+ | TransLayout_Pipe -- ^ "`|' at the same depth as implicit layout block")
compiler/GHC/Parser/Header.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE TypeFamilies #-} -----------------------------------------------------------------------------@@ -21,8 +21,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform@@ -32,8 +30,6 @@ import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! import GHC.Parser.Errors.Types-import GHC.Parser.Errors.Ppr-import GHC.Parser.Errors import GHC.Parser ( parseHeader ) import GHC.Parser.Lexer @@ -55,8 +51,8 @@ import GHC.Data.StringBuffer import GHC.Data.Maybe-import GHC.Data.Bag (Bag, isEmptyBag ) import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict import Control.Monad import System.IO@@ -80,7 +76,7 @@ -> FilePath -- ^ The original source filename (used for locations -- in the function result) -> IO (Either- (Bag PsError)+ (Messages PsMessage) ([(Maybe FastString, Located ModuleName)], [(Maybe FastString, Located ModuleName)], Located ModuleName))@@ -96,8 +92,8 @@ let (_warns, errs) = getMessages pst -- don't log warnings: they'll be reported when we parse the file -- for real. See #2500.- if not (isEmptyBag errs)- then throwErrors $ foldPsMessages mkParserErr errs+ if not (isEmptyMessages errs)+ then throwErrors (GhcPsMessage <$> errs) else let hsmod = unLoc rdr_module mb_mod = hsmodName hsmod@@ -349,7 +345,7 @@ advance_src_loc_many = foldl' advanceSrcLoc locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a- locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Nothing) x+ locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x toArgs' :: RealSrcLoc -> String -> Either String [Located String] -- Remove outer quotes:@@ -427,7 +423,7 @@ liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags where mkMsg (L loc flag) = mkPlainErrorMsgEnvelope loc $- GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag @@ -471,5 +467,5 @@ throwErr :: SrcSpan -> SDoc -> a -- #15053 throwErr loc doc =- let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage $ PsUnknownMessage $ mkPlainError doc+ let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints doc in throw $ mkSrcErr $ singleMessage msg
compiler/GHC/Parser/PostProcess.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -57,7 +58,9 @@ checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat- checkPattern_hints,+ checkPattern_details,+ incompleteDoBlock,+ ParseContext(..), checkMonadComp, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs,@@ -118,11 +121,13 @@ import GHC.Types.Name import GHC.Unit.Module (ModuleName) import GHC.Types.Basic+import GHC.Types.Error import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Parser.Types import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( isLexCon ) import GHC.Types.TyThing import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) )@@ -136,14 +141,15 @@ import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe-import GHC.Data.Bag+import GHC.Utils.Error import GHC.Utils.Misc import Data.Either import Data.List ( findIndex ) import Data.Foldable-import GHC.Driver.Flags ( WarningFlag(..) ) import qualified Data.Semigroup as Semi import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import qualified GHC.Data.Strict as Strict import Control.Monad import Text.ParserCombinators.ReadP as ReadP@@ -151,8 +157,6 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) import Data.Kind ( Type ) -#include "GhclibHsVersions.h"- {- ********************************************************************** Construction functions for Rdr stuff@@ -216,8 +220,8 @@ ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) (ann ++ anns) cs- ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns'- ; return (L loc (DataDecl { tcdDExt = anns', -- AZ: do we need these?+ ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+ ; return (L loc (DataDecl { tcdDExt = anns', tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn })) }@@ -228,11 +232,10 @@ -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs- -> EpAnn [AddEpAnn] -> P (HsDataDefn GhcPs)-mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ann+mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt- ; return (HsDataDefn { dd_ext = ann+ ; return (HsDataDefn { dd_ext = noExtField , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = mcxt , dd_cons = data_cons@@ -273,12 +276,14 @@ check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v- else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v)+ else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $+ (PsErrUnexpectedQualifiedConstructor (unLoc v)) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v- _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)+ _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $+ (PsErrMultipleNamesInStandaloneKindSignature vs) mkTyFamInstEqn :: SrcSpan -> HsOuterFamEqnTyVarBndrs GhcPs@@ -310,12 +315,11 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) ksig data_cons (L _ maybe_deriv) anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr- ; -- AZ:TODO: deal with these comments- ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]+ ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments- ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns'+ ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl- (FamEqn { feqn_ext = noAnn -- AZ: get anns+ (FamEqn { feqn_ext = anns' , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams@@ -408,7 +412,8 @@ let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in- addFatalError $ PsError (PsErrIllegalRoleName role nearby) [] loc_role+ addFatalError $ mkPlainErrorMsgEnvelope loc_role $+ (PsErrIllegalRoleName role nearby) -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if@@ -428,7 +433,8 @@ where check_spec :: Specificity -> SrcSpanAnnA -> P () check_spec SpecifiedSpec _ = return ()- check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc)+ check_spec InferredSpec loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+ PsErrInferredTypeVarNotAllowed -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ annBinds :: AddEpAnn -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs@@ -478,8 +484,8 @@ cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts , dfam_insts, _) <- cvBindsAndSigs binding- ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)- return $ ValBinds NoAnnSortKey mbs sigs }+ ; massert (null fam_ds && null tfam_insts && null dfam_insts)+ ; return $ ValBinds NoAnnSortKey mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]@@ -507,7 +513,7 @@ -- called on top-level declarations. drop_bad_decls [] = return [] drop_bad_decls (L l (SpliceD _ d) : ds) = do- addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l)+ addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d drop_bad_decls ds drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -531,13 +537,11 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) , fun_matches =- MG { mg_alts = (L _ mtchs1) } }))+ MG { mg_alts = (L _ m1@[L _ mtchs1]) } })) binds- | has_args mtchs1- = go mtchs1 loc1 binds []+ | has_args m1+ = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds [] where- -- TODO:AZ may have to preserve annotations. Although they should- -- only be AnnSemi, and meaningless in this context? go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ@@ -547,7 +551,7 @@ MG { mg_alts = (L _ [L lm2 mtchs2]) } }))) : binds) _ | f1 == f2 =- let (loc2', lm2') = transferComments loc2 lm2+ let (loc2', lm2') = transferAnnsA loc2 lm2 in go (L lm2' mtchs2 : mtchs) (combineSrcSpansA loc loc2') binds [] go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls@@ -619,14 +623,14 @@ -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard]-tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName)+tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) tyConToDataCon (L loc tc) | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise- = Left $ PsError (PsErrNotADataCon tc) [] (locA loc)+ = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc) where occ = rdrNameOcc tc @@ -667,17 +671,21 @@ fromDecl (L loc decl) = extraDeclErr (locA loc) decl extraDeclErr loc decl =- addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc+ addFatalError $ mkPlainErrorMsgEnvelope loc $+ (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) wrongNameBindingErr loc decl =- addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc+ addFatalError $ mkPlainErrorMsgEnvelope loc $+ (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) wrongNumberErr loc =- addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc+ addFatalError $ mkPlainErrorMsgEnvelope loc $+ (PsErrEmptyWhereInPatSynDecl patsyn_name) recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat =- addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc+ addFatalError $ mkPlainErrorMsgEnvelope loc $+ (PsErrRecordSyntaxInPatSynDecl pat) mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs@@ -818,7 +826,7 @@ really doesn't matter! -} -eitherToP :: MonadP m => Either PsError a -> m a+eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a -- Adapts the Either monad to the P monad eitherToP (Left err) = addFatalError err eitherToP (Right thing) = return thing@@ -832,9 +840,11 @@ = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where- check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc)+ check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+ (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) check (HsValArg ty) = chkParens [] emptyComments ty- check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp+ check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $+ (PsErrMalformedDecl pp_what (unLoc tc)) -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddEpAnn])@@ -854,7 +864,8 @@ | isRdrTyVar tv = return (L (widenLocatedAn l an) (UserTyVar (addAnns ann an cs) () (L ltv tv))) chk _ _ t@(L loc _)- = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc)+ = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+ (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) whereDots, equalsDots :: SDoc@@ -866,7 +877,8 @@ checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit- unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c)+ unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $+ (PsErrIllegalDataTypeContext c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))@@ -877,7 +889,7 @@ mkRuleBndrs = fmap (fmap cvt_one) where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v cvt_one (RuleTyTmVar ann v (Just sig)) =- RuleBndrSig ann v (mkHsPatSigType sig)+ RuleBndrSig ann v (mkHsPatSigType noAnn sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]@@ -896,13 +908,15 @@ where check (L loc (Unqual occ)) = -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"])- (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc))+ (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+ (PsErrParseErrorOnInput occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit- unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc)+ unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $+ (PsErrIllegalTraditionalRecordSyntax (ppr r)) return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for@@ -911,7 +925,8 @@ -> P (Located ([AddEpAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax- unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span+ unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $+ PsErrIllegalWhereInDataDecl return gadts checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. @@ -934,7 +949,7 @@ -- workaround to define '*' despite StarIsType go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix- = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l))+ = do { addPsMessage (locA l) PsWarnStarBinder ; let name = mkOccName tcClsName (starSym isUni) ; let a' = newAnns l an ; return (L a' (Unqual name), acc, fix@@ -956,7 +971,8 @@ | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) go l _ _ _ _- = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l+ = addFatalError $ mkPlainErrorMsgEnvelope l $+ (PsErrMalformedTyOrClDecl ty) -- Combine the annotations from the HsParTy and HsStarTy into a -- new one for the LocatedN RdrName@@ -966,13 +982,13 @@ lr = combineRealSrcSpans (realSrcSpan l) (anchor as) -- lr = widenAnchorR as (realSrcSpan l) an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)- in SrcSpanAnn an (RealSrcSpan lr Nothing)+ in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) newAnns _ EpAnnNotUsed = panic "missing AnnParen" newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) = let lr = combineRealSrcSpans (anchor ap) (anchor as) an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs))- in SrcSpanAnn an (RealSrcSpan lr Nothing)+ in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled.@@ -1004,7 +1020,7 @@ check err a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $- addError $ PsError (err a) [] (getLocA a)+ addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a) -- | Validate the context constraints and break up a context into a list -- of predicates.@@ -1056,18 +1072,18 @@ -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $- failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)+ failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $- failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)+ failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. whenJust mPre $ \pre ->- warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Nothing)+ warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing) -- ------------------------------------------------------------------------- -- Checking Patterns.@@ -1078,8 +1094,8 @@ checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [PsHint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)-checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)+checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)+checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat) checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] []@@ -1093,12 +1109,11 @@ , pat_args = PrefixCon tyargs args } | not (null tyargs) =- add_hint TypeApplicationsInPatternsOnlyDataCons $- patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs])- | not (null args) && patIsRec c =- add_hint SuggestRecursiveDo $- patFail (locA l) (ppr e)-checkPat loc (L _ (PatBuilderAppType f _ t)) tyargs args =+ patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs+ | (not (null args) && patIsRec c) = do+ ctx <- askParseContext+ patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx+checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = checkPat loc f (t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do p <- checkLPat e@@ -1106,7 +1121,9 @@ checkPat loc (L l e) [] [] = do p <- checkAPat loc e return (L l p)-checkPat loc e _ _ = patFail (locA loc) (ppr e)+checkPat loc e _ _ = do+ details <- fromParseContext <$> askParseContext+ patFail (locA loc) (PsErrInPat (unLoc e) details) checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do@@ -1131,7 +1148,7 @@ -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do- addError $ PsError PsErrAtInPatPos [] (getLocA op)+ addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos return (WildPat noExtField) PatBuilderOpApp l (L cl c) r anns@@ -1144,13 +1161,14 @@ , pat_args = InfixCon l r } - PatBuilderPar e an@(AnnParen pt o c) -> do- (L l p) <- checkLPat e- let aa = [AddEpAnn ai o, AddEpAnn ac c]- (ai,ac) = parenTypeKws pt- return (ParPat (EpAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an emptyComments) (L l p))- _ -> patFail (locA loc) (ppr e0)+ PatBuilderPar lpar e rpar -> do+ p <- checkLPat e+ return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar) + _ -> do+ details <- fromParseContext <$> askParseContext+ patFail (locA loc) (PsErrInPat e0 details)+ placeHolderPunRhs :: DisambECP b => PV (LocatedA b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when@@ -1163,11 +1181,11 @@ checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs))-checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)- return (L l (fld { hsRecFieldArg = p }))+checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)+ return (L l (fld { hfbRHS = p })) -patFail :: SrcSpan -> SDoc -> PV a-patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc+patFail :: SrcSpan -> PsMessage -> PV a+patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec")@@ -1187,12 +1205,12 @@ >>= checkLPat checkPatBind loc [] lhs' grhss -checkValDef loc lhs Nothing g@(L l grhss)+checkValDef loc lhs Nothing g = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) ->- checkFunBind NoSrcStrict loc ann (getLocA lhs)- fun is_infix pats (L l grhss)+ checkFunBind NoSrcStrict loc ann+ fun is_infix pats g Nothing -> do lhs' <- checkPattern lhs checkPatBind loc [] lhs' g }@@ -1200,15 +1218,14 @@ checkFunBind :: SrcStrictness -> SrcSpan -> [AddEpAnn]- -> SrcSpan -> LocatedN RdrName -> LexicalFixity -> [LocatedA (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs)-checkFunBind strictness locF ann lhs_loc fun is_infix pats (L rhs_span grhss)- = do ps <- runPV_hints param_hints (mapM checkLPat pats)- let match_span = noAnnSrcSpan $ combineSrcSpans lhs_loc rhs_span+checkFunBind strictness locF ann fun is_infix pats (L _ grhss)+ = do ps <- runPV_details extraDetails (mapM checkLPat pats)+ let match_span = noAnnSrcSpan $ locF cs <- getCommentsFor locF return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) [L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs@@ -1221,9 +1238,9 @@ -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. where- param_hints- | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)]- | otherwise = []+ extraDetails+ | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock+ | otherwise = noParseContext makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs@@ -1263,11 +1280,11 @@ = return lrdr checkValSigLhs lhs@(L l _)- = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l)+ = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c)- => (a -> Bool -> b -> Bool -> c -> PsErrorDesc)+ => (a -> Bool -> b -> Bool -> c -> PsMessage) -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do@@ -1277,7 +1294,7 @@ semiElse (unLoc elseExpr) loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) - unless doAndIfThenElse $ addError (PsError e [] loc)+ unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e) | otherwise = return () isFunLhs :: LocatedA (PatBuilder GhcPs)@@ -1290,7 +1307,7 @@ go (L _ (PatBuilderVar (L loc f))) es ann | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann- go (L l (PatBuilderPar e _an)) es@(_:_) ann+ go (L l (PatBuilderPar _ e _)) es@(_:_) ann = go e es (ann ++ mkParensEpAnn (locA l)) go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ann | not (isRdrDataCon op) -- We have found the function!@@ -1393,7 +1410,7 @@ instance DisambInfixOp RdrName where mkHsConOpPV (L l v) = return $ L l v mkHsVarOpPV (L l v) = return $ L l v- mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l+ mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole type AnnoBody b = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan@@ -1414,7 +1431,7 @@ ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b) -- | Return an expression without ambiguity, or fail in a non-expression context. ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)- mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)]+ mkHsProjUpdatePV :: SrcSpan -> Located [Located (DotFieldOcc GhcPs)] -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b)) -- | Disambiguate "\... -> ..." (lambda) mkHsLamPV@@ -1453,7 +1470,7 @@ -> LocatedA b -> Bool -- semicolon? -> LocatedA b- -> [AddEpAnn]+ -> AnnsIf -> PV (LocatedA b) -- | Disambiguate "do { ... }" (do notation) mkHsDoPV ::@@ -1463,7 +1480,7 @@ AnnList -> PV (LocatedA b) -- | Disambiguate "( ... )" (parentheses)- mkHsParPV :: SrcSpan -> LocatedA b -> AnnParen -> PV (LocatedA b)+ mkHsParPV :: SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b) -- | Disambiguate a variable "f" or a data constructor "MkF". mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) -- | Disambiguate a monomorphic literal@@ -1557,7 +1574,8 @@ type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)- mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+ mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $+ PsErrOverloadedRecordDotInvalid mkHsLamPV l mg = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))@@ -1593,10 +1611,10 @@ mkHsDoPV l Nothing stmts anns = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts)- mkHsDoPV l (Just m) _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l- mkHsParPV l c ann = do+ mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m+ mkHsParPV l lpar c rpar = do cs <- getCommentsFor l- return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) ann cs) c)+ return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar) mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a) mkHsOverLitPV (L l a) = cmdFail l (ppr a)@@ -1608,7 +1626,7 @@ mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do let (fs, ps) = partitionEithers fbinds if not (null ps)- then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+ then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $@@ -1627,17 +1645,17 @@ rejectPragmaPV _ = return () cmdFail :: SrcSpan -> SDoc -> PV a-cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc+cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV () checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do- when (null (hsLMatchPats matches)) $ addError $ PsError PsErrEmptyLambda [] l+ when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda checkLamMatchGroup _ _ = return () instance DisambECP (HsExpr GhcPs) where type Body (HsExpr GhcPs) = HsExpr ecpFromCmd' (L l c) = do- addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l)+ addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c return (L l (hsHoleExpr noAnn)) ecpFromExp' = return mkHsProjUpdatePV l fields arg isPun anns = do@@ -1681,9 +1699,9 @@ mkHsDoPV l mod stmts anns = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts)- mkHsParPV l e ann = do+ mkHsParPV l lpar e rpar = do cs <- getCommentsFor l- return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) ann cs) e)+ return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar) mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v) mkHsLitPV (L l a) = do cs <- getCommentsFor l@@ -1711,19 +1729,20 @@ mkHsSectionR_PV l op e = do cs <- getCommentsFor l return $ L l (SectionR (comment (realSrcSpan l) cs) op e)- mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l)+ mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))- mkHsAsPatPV l v e _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l)+ mkHsAsPatPV l v e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))- mkHsLazyPatPV l e _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l)+ mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))- mkHsBangPatPV l e _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l)+ mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkSumOrTuplePV = mkSumOrTupleExpr rejectPragmaPV (L _ (OpApp _ _ _ e)) = -- assuming left-associative parsing of operators rejectPragmaPV e- rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l)+ rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $+ (PsErrUnallowedPragma prag) rejectPragmaPV _ = return () hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs@@ -1736,26 +1755,29 @@ instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder- ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l)- ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l)- mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l- mkHsLetPV l _ _ _ = addFatalError $ PsError PsErrLetInPat [] l- mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+ ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c+ ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e+ mkHsLamPV l _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat+ mkHsLetPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat+ mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = do cs <- getCommentsFor l let anns = EpAnn (spanAsAnchor l) [] cs return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns- mkHsCasePV l _ _ _ = addFatalError $ PsError PsErrCaseInPat [] l- mkHsLamCasePV l _ _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l+ mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat+ mkHsLamCasePV l _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaCaseInPat type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)- mkHsAppTypePV l p la t = return $ L l (PatBuilderAppType p la (mkHsPatSigType t))- mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l- mkHsDoPV l _ _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l- mkHsParPV l p an = return $ L (noAnnSrcSpan l) (PatBuilderPar p an)+ mkHsAppTypePV l p la t = do+ cs <- getCommentsFor (locA l)+ let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs+ return $ L l (PatBuilderAppType p (mkHsPatSigType anns t))+ mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat+ mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat+ mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do checkUnboxedStringLitPat lit@@ -1765,7 +1787,7 @@ mkHsTySigPV l b sig anns = do p <- checkLPat b cs <- getCommentsFor (locA l)- return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType sig)))+ return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig))) mkHsExplicitListPV l xs anns = do ps <- traverse checkLPat xs cs <- getCommentsFor l@@ -1774,7 +1796,7 @@ mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps)- then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+ then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid else do cs <- getCommentsFor l r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs)@@ -1782,11 +1804,11 @@ mkHsNegAppPV l (L lp p) anns = do lit <- case p of PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit)- _ -> patFail l (text "-" <> ppr p)+ _ -> patFail l $ PsErrInPat p PEIP_NegApp cs <- getCommentsFor l let an = EpAnn (spanAsAnchor l) anns cs return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))- mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)+ mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) mkHsViewPatPV l a b anns = do p <- checkLPat b cs <- getCommentsFor l@@ -1812,7 +1834,8 @@ checkUnboxedStringLitPat (L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260- -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc+ -> addFatalError $ mkPlainErrorMsgEnvelope loc $+ (PsErrIllegalUnboxedStringInPat lit) _ -> return () mkPatRec ::@@ -1829,7 +1852,8 @@ , pat_args = RecCon (HsRecFields fs dd) } mkPatRec p _ _ =- addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p)+ addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $+ (PsErrInvalidRecordCon (unLoc p)) -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor.@@ -1892,7 +1916,8 @@ panic "mkHsAppTyPV: InfixDataConBuilder" mkHsAppKindTyPV lhs l_at ki =- addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at+ addFatalError $ mkPlainErrorMsgEnvelope l_at $+ (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) mkHsOpTyPV lhs tc rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative@@ -1902,7 +1927,8 @@ l = combineLocsA lhs rhs check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) check_no_ops (HsOpTy{}) =- addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l)+ addError $ mkPlainErrorMsgEnvelope (locA l) $+ (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) check_no_ops _ = return () mkUnpackednessPV unpk constr_stuff@@ -1913,7 +1939,7 @@ let l = combineLocsA (reLocA unpk) constr_stuff return $ L l (InfixDataConBuilder lhs' data_con rhs) | otherwise =- do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk)+ do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon return constr_stuff tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)@@ -1924,7 +1950,8 @@ let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t =- addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t)+ addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $+ (PsErrInvalidDataCon (unLoc t)) {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2373,7 +2400,7 @@ checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure ()- | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l+ | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i) where -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs specialOp op = unLoc op `elem` [ eqTyCon_RDR@@ -2391,10 +2418,12 @@ = do let (fs, ps) = partitionEithers fbinds if not (null ps)- then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps))+ then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $+ PsErrOverloadedRecordDotInvalid else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns- | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc+ | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $+ PsErrDotsInRecordUpdate | otherwise = mkRdrRecordUpd overloaded_update exp fs anns mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)@@ -2408,7 +2437,7 @@ case overloaded_on of False | not $ null ps -> -- A '.' was found in an update and OverloadedRecordUpdate isn't on.- addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc)+ addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled False -> -- This is just a regular record update. return RecordUpd {@@ -2417,12 +2446,13 @@ , rupd_flds = Left fs' } True -> do let qualifiedFields =- [ L l lbl | L _ (HsRecField _ (L l lbl) _ _) <- fs'+ [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' , isQual . rdrNameAmbiguousFieldOcc $ lbl ] if not $ null qualifiedFields then- addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields))+ addFatalError $ mkPlainErrorMsgEnvelope (getLoc (head qualifiedFields)) $+ PsErrOverloadedRecordUpdateNoQualifiedFields else -- This is a RecordDotSyntax update. return RecordUpd { rupd_ext = anns@@ -2435,10 +2465,10 @@ -- Convert a top-level field update like {foo=2} or {bar} (punned) -- to a projection update. recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs- recFieldToProjUpdate (L l (HsRecField anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =+ recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = -- The idea here is to convert the label to a singleton [FastString]. let f = occNameFS . rdrNameOcc $ rdr- fl = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann?+ fl = DotFieldOcc noAnn (L lf f) -- AZ: what about the ann? lf = locA loc in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns where@@ -2460,8 +2490,8 @@ , rec_dotdot = Just (L s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs-mk_rec_upd_field (HsRecField noAnn (L loc (FieldOcc _ rdr)) arg pun)- = HsRecField noAnn (L loc (Unambiguous noExtField rdr)) arg pun+mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)+ = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma@@ -2505,7 +2535,8 @@ mkCImport = do let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of- Nothing -> addFatalError $ PsError PsErrMalformedEntityString [] loc+ Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $+ PsErrMalformedEntityString Just importSpec -> returnSpec importSpec -- currently, all the other import conventions only support a symbol name in@@ -2646,12 +2677,14 @@ in (\newName -> IEThingWith ann (L l newName) pos ies) <$> nameT- else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l)+ else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+ PsErrIllegalPatSynExport where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name)- then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l)+ then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+ (PsErrVarForTyCon name) else return $ ieNameFromSpec specname ieNameVal (ImpExpQcName ln) = unLoc ln@@ -2668,7 +2701,8 @@ -> P (LocatedN RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit- unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name)+ unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $+ PsErrIllegalExplicitNamespace return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])@@ -2678,7 +2712,7 @@ (l:_) -> importSpecError (locA l) where importSpecError l =- addFatalError $ PsError PsErrIllegalImportBundleForm [] l+ addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm -- In the correct order mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)@@ -2699,21 +2733,24 @@ warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span =- addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span)+ addPsMessage span PsWarnImportPreQualified failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()-failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc+failOpNotEnabledImportQualifiedPost loc =+ addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified failOpImportQualifiedTwice :: SrcSpan -> P ()-failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc+failOpImportQualifiedTwice loc =+ addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice warnStarIsType :: SrcSpan -> P ()-warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span)+warnStarIsType span = addPsMessage span PsWarnStarIsType failOpFewArgs :: MonadP m => LocatedN RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit- ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) }+ ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+ (PsErrOpFewArgs (StarIsType star_is_type) op) } ----------------------------------------------------------------------------- -- Misc utils@@ -2721,14 +2758,14 @@ data PV_Context = PV_Context { pv_options :: ParserOpts- , pv_hints :: [PsHint] -- See Note [Parser-Validator Hint]+ , pv_details :: ParseContext -- See Note [Parser-Validator Details] } data PV_Accum = PV_Accum- { pv_warnings :: Bag PsWarning- , pv_errors :: Bag PsError- , pv_header_comments :: Maybe [LEpaComment]+ { pv_warnings :: Messages PsMessage+ , pv_errors :: Messages PsMessage+ , pv_header_comments :: Strict.Maybe [LEpaComment] , pv_comment_q :: [LEpaComment] } @@ -2769,15 +2806,18 @@ PV_Failed acc' -> PV_Failed acc' runPV :: PV a -> P a-runPV = runPV_hints []+runPV = runPV_details noParseContext -runPV_hints :: [PsHint] -> PV a -> P a-runPV_hints hints m =+askParseContext :: PV ParseContext+askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details++runPV_details :: ParseContext -> PV a -> P a+runPV_details details m = P $ \s -> let pv_ctx = PV_Context { pv_options = options s- , pv_hints = hints }+ , pv_details = details } pv_acc = PV_Accum { pv_warnings = warnings s , pv_errors = errors s@@ -2792,22 +2832,14 @@ PV_Ok acc' a -> POk (mkPState acc') a PV_Failed acc' -> PFailed (mkPState acc') -add_hint :: PsHint -> PV a -> PV a-add_hint hint m =- let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in- PV (\ctx acc -> unPV m (modifyHint ctx) acc)- instance MonadP PV where- addError err@(PsError e hints loc) =- PV $ \ctx acc ->- let err' | null (pv_hints ctx) = err- | otherwise = PsError e (hints ++ pv_hints ctx) loc- in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} ()- addWarning option w =- PV $ \ctx acc ->- if warnopt option (pv_options ctx)- then PV_Ok acc{pv_warnings= w `consBag` pv_warnings acc} ()- else PV_Ok acc ()+ addError err =+ PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()+ addWarning w =+ PV $ \_ctx acc ->+ -- No need to check for the warning flag to be set, GHC will correctly discard suppressed+ -- diagnostics.+ PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} () addFatalError err = addError err >> PV (const PV_Failed) getBit ext =@@ -2832,11 +2864,11 @@ PV_Ok s { pv_header_comments = header_comments', pv_comment_q = comment_q'- } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))+ } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns)) -{- Note [Parser-Validator Hint]+{- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A PV computation is parametrized by a hint for error messages, which can be set+A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set depending on validation context. We use this in checkPattern to fix #984. Consider this example, where the user has forgotten a 'do':@@ -2863,16 +2895,17 @@ _ -> result -We attempt to detect such cases and add a hint to the error messages:+We attempt to detect such cases and add a hint to the diagnostic messages: T984.hs:6:9: Parse error in pattern: case () of { _ -> result } Possibly caused by a missing 'do'? -The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed-as the 'pv_hints' field 'PV_Context'. When validating in a context other than-'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has-no effect on the error messages.+The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed+out of the 'ParseContext', which are read by functions like 'patFail' when+constructing the 'PsParseErrorInPatDetails' data structure. When validating in a+context other than 'bindpat' (a pattern to the left of <-), we set the+details to 'noParseContext' and it has no effect on the diagnostic messages. -} @@ -2881,7 +2914,7 @@ hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $- addError $ PsError (PsErrIllegalBangPattern e) [] span+ addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) -> [AddEpAnn]@@ -2907,7 +2940,7 @@ cs <- getCommentsFor (locA l) return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} _ =- addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l)+ addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a mkSumOrTuplePat :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]@@ -2923,7 +2956,8 @@ -- Ignore the element location so that the error message refers to the -- entire tuple. See #19504 (and the discussion) for details. toTupPat p = case p of- Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l)+ Left _ -> addFatalError $+ mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat Right p' -> checkLPat p' -- Sum@@ -2933,7 +2967,8 @@ let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs return $ L l (PatBuilderPat (SumPat an p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} _ =- addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l)+ addFatalError $+ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y =@@ -2956,7 +2991,7 @@ ----------------------------------------- -- Bits and pieces for RecordDotSyntax. -mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs)+mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (DotFieldOcc GhcPs) -> EpAnnCO -> LHsExpr GhcPs mkRdrGetField loc arg field anns = L loc HsGetField {@@ -2965,7 +3000,7 @@ , gf_field = field } -mkRdrProjection :: [Located (HsFieldLabel GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs+mkRdrProjection :: [Located (DotFieldOcc GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!" mkRdrProjection flds anns = HsProjection {@@ -2973,14 +3008,14 @@ , proj_flds = flds } -mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)]+mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (DotFieldOcc GhcPs)] -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn] -> LHsRecProj GhcPs (LHsExpr GhcPs) mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" mkRdrProjUpdate loc (L l flds) arg isPun anns =- L loc HsRecField {- hsRecFieldAnn = anns- , hsRecFieldLbl = L l (FieldLabelStrings flds)- , hsRecFieldArg = arg- , hsRecPun = isPun+ L loc HsFieldBind {+ hfbAnn = anns+ , hfbLHS = L l (FieldLabelStrings flds)+ , hfbRHS = arg+ , hfbPun = isPun }
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -54,7 +54,6 @@ import GHC.Hs import GHC.Types.SrcLoc-import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic import GHC.Data.Bag @@ -71,8 +70,9 @@ import qualified Data.Monoid import GHC.Parser.Lexer-import GHC.Parser.Errors+import GHC.Parser.Errors.Types import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))+import qualified GHC.Data.Strict as Strict {- Note [Adding Haddock comments to the syntax tree] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -192,9 +192,9 @@ reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L l _)) =- addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockInvalidPos (mkSrcSpanPs l)+ addPsMessage (mkSrcSpanPs l) PsWarnHaddockInvalidPos reportHdkWarning (HdkWarnExtraComment (L l _)) =- addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockIgnoreMulti l+ addPsMessage l PsWarnHaddockIgnoreMulti collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =@@ -979,10 +979,10 @@ pure $ L l (HsForAllTy x tele body') -- (Eq a, Num a) => t- HsQualTy x mlhs rhs -> do- traverse_ registerHdkA mlhs+ HsQualTy x lhs rhs -> do+ registerHdkA lhs rhs' <- addHaddock rhs- pure $ L l (HsQualTy x mlhs rhs')+ pure $ L l (HsQualTy x lhs rhs') -- arg -> res HsFunTy u mult lhs rhs -> do@@ -1023,7 +1023,8 @@ -- which it is used. data HdkA a = HdkA- !(Maybe BufSpan) -- Just b <=> BufSpan occupied by the processed AST element.+ !(Strict.Maybe BufSpan)+ -- Just b <=> BufSpan occupied by the processed AST element. -- The surrounding computations will not look inside. -- -- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA').@@ -1056,9 +1057,9 @@ -- These delim1/delim2 are key to how HdkA operates. where -- Delimit the LHS by the location information from the RHS- delim1 = inLocRange (locRangeTo (fmap @Maybe bufSpanStart l2))+ delim1 = inLocRange (locRangeTo (fmap @Strict.Maybe bufSpanStart l2)) -- Delimit the RHS by the location information from the LHS- delim2 = inLocRange (locRangeFrom (fmap @Maybe bufSpanEnd l1))+ delim2 = inLocRange (locRangeFrom (fmap @Strict.Maybe bufSpanEnd l1)) pure a = -- Return a value without performing any stateful computation, and without@@ -1377,14 +1378,14 @@ mempty = LocRange mempty mempty mempty -- The location range from the specified position to the end of the file.-locRangeFrom :: Maybe BufPos -> LocRange-locRangeFrom (Just l) = mempty { loc_range_from = StartLoc l }-locRangeFrom Nothing = mempty+locRangeFrom :: Strict.Maybe BufPos -> LocRange+locRangeFrom (Strict.Just l) = mempty { loc_range_from = StartLoc l }+locRangeFrom Strict.Nothing = mempty -- The location range from the start of the file to the specified position.-locRangeTo :: Maybe BufPos -> LocRange-locRangeTo (Just l) = mempty { loc_range_to = EndLoc l }-locRangeTo Nothing = mempty+locRangeTo :: Strict.Maybe BufPos -> LocRange+locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l }+locRangeTo Strict.Nothing = mempty -- Represents a predicate on BufPos: --
compiler/GHC/Parser/Types.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-} module GHC.Parser.Types ( SumOrTuple(..)@@ -52,9 +53,9 @@ -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p = PatBuilderPat (Pat p)- | PatBuilderPar (LocatedA (PatBuilder p)) AnnParen+ | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p) | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))- | PatBuilderAppType (LocatedA (PatBuilder p)) SrcSpan (HsPatSigType GhcPs)+ | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) | PatBuilderVar (LocatedN RdrName)@@ -62,9 +63,9 @@ instance Outputable (PatBuilder GhcPs) where ppr (PatBuilderPat p) = ppr p- ppr (PatBuilderPar (L _ p) _) = parens (ppr p)+ ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p) ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2- ppr (PatBuilderAppType (L _ p) _ t) = ppr p <+> text "@" <> ppr t+ ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2 ppr (PatBuilderVar v) = ppr v ppr (PatBuilderOverLit l) = ppr l
compiler/GHC/Platform/Ways.hs view
@@ -49,8 +49,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform import GHC.Driver.Flags
compiler/GHC/Runtime/Heap/Layout.hs view
@@ -3,7 +3,8 @@ -- -- Storage manager representation of closures -{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Runtime.Heap.Layout ( -- * Words and bytes
compiler/GHC/Runtime/Interpreter.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}
compiler/GHC/Settings.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ -- | Run-time settings module GHC.Settings
compiler/GHC/Stg/Syntax.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -65,8 +65,6 @@ pprGenStgTopBindings, pprStgTopBindings ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core ( AltCon )@@ -90,8 +88,7 @@ import GHC.Core.TyCon ( PrimRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Types.RepType ( typePrimRep1 )-import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain {- ************************************************************************@@ -503,7 +500,7 @@ stgRhsArity :: StgRhs -> Int stgRhsArity (StgRhsClosure _ _ _ bndrs _)- = ASSERT( all isId bndrs ) length bndrs+ = assert (all isId bndrs) $ length bndrs -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon _ _ _ _ _) = 0
compiler/GHC/StgToCmm/Types.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.StgToCmm.Types ( CgInfos (..) , LambdaFormInfo (..)@@ -9,8 +9,6 @@ , StandardFormInfo (..) , WordOff ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/SysTools/BaseDir.hs view
@@ -17,8 +17,6 @@ , tryFindTopDir ) where -#include "GhclibHsVersions.h"- import GHC.Prelude -- See note [Base Dir] for why some of this logic is shared with ghc-pkg.
compiler/GHC/SysTools/Terminal.hs view
@@ -11,7 +11,7 @@ setupTermFromEnv, termColors) import System.Posix (queryTerminal, stdError) #elif defined(mingw32_HOST_OS)-import Control.Exception (try)+import GHC.Utils.Exception (try) -- import Data.Bits ((.|.), (.&.)) import Foreign (Ptr, peek, with) import qualified Graphics.Win32 as Win32
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -1,10 +1,75 @@+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage -module GHC.Tc.Errors.Ppr where+module GHC.Tc.Errors.Ppr (+ ) where +import GHC.Prelude+ import GHC.Tc.Errors.Types import GHC.Types.Error+import GHC.Driver.Flags+import GHC.Hs+import GHC.Utils.Outputable instance Diagnostic TcRnMessage where- diagnosticMessage (TcRnUnknownMessage m) = diagnosticMessage m- diagnosticReason (TcRnUnknownMessage m) = diagnosticReason m+ diagnosticMessage = \case+ TcRnUnknownMessage m+ -> diagnosticMessage m+ TcRnImplicitLift id_or_name errInfo+ -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+>+ text "is implicitly lifted in the TH quotation"+ , getErrInfo errInfo+ ]+ TcRnUnusedPatternBinds bind+ -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]+ TcRnDodgyImports name+ -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)]+ TcRnDodgyExports name+ -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)]+ TcRnMissingImportList ie+ -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+>+ text "does not have an explicit import list"+ ]++ diagnosticReason = \case+ TcRnUnknownMessage m+ -> diagnosticReason m+ TcRnImplicitLift{}+ -> WarningWithFlag Opt_WarnImplicitLift+ TcRnUnusedPatternBinds{}+ -> WarningWithFlag Opt_WarnUnusedPatternBinds+ TcRnDodgyImports{}+ -> WarningWithFlag Opt_WarnDodgyImports+ TcRnDodgyExports{}+ -> WarningWithFlag Opt_WarnDodgyExports+ TcRnMissingImportList{}+ -> WarningWithFlag Opt_WarnMissingImportList++ diagnosticHints = \case+ TcRnUnknownMessage m+ -> diagnosticHints m+ TcRnImplicitLift{}+ -> noHints+ TcRnUnusedPatternBinds{}+ -> noHints+ TcRnDodgyImports{}+ -> noHints+ TcRnDodgyExports{}+ -> noHints+ TcRnMissingImportList{}+ -> noHints++dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc+dodgy_msg kind tc ie+ = sep [ text "The" <+> kind <+> text "item"+ <+> quotes (ppr ie)+ <+> text "suggests that",+ quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",+ text "but it has none" ]++dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)+dodgy_msg_insert tc = IEThingAll noAnn ii+ where+ ii :: LIEWrappedName (IdP (GhcPass p))+ ii = noLocA (IEName $ noLocA tc)
compiler/GHC/Tc/Errors/Types.hs view
@@ -1,12 +1,78 @@+{-# LANGUAGE GADTs #-} module GHC.Tc.Errors.Types ( -- * Main types TcRnMessage(..)+ , ErrInfo(..) ) where +import GHC.Hs import GHC.Types.Error+import GHC.Types.Name (Name)+import GHC.Types.Name.Reader+import GHC.Utils.Outputable+import Data.Typeable +-- The majority of TcRn messages come with extra context about the error,+-- and this newtype captures it.+newtype ErrInfo = ErrInfo { getErrInfo :: SDoc }+ -- | An error which might arise during typechecking/renaming.-data TcRnMessage- = TcRnUnknownMessage !DiagnosticMessage- -- ^ Simply rewraps a generic 'DiagnosticMessage'. More- -- constructors will be added in the future (#18516).+data TcRnMessage where+ {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins+ to provide custom diagnostic messages originated during typechecking/renaming.+ -}+ TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage+ {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when+ a Template Haskell quote implicitly uses 'lift'.++ Example:+ warning1 :: Lift t => t -> Q Exp+ warning1 x = [| x |]++ Test cases: th/T17804+ -}+ TcRnImplicitLift :: Outputable var => var -> !ErrInfo -> TcRnMessage+ {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds)+ that occurs if a pattern binding binds no variables at all, unless it is a+ lone wild-card pattern, or a banged pattern.++ Example:+ Just _ = rhs3 -- Warning: unused pattern binding+ (_, _) = rhs4 -- Warning: unused pattern binding+ _ = rhs3 -- No warning: lone wild-card pattern+ !() = rhs4 -- No warning: banged pattern; behaves like seq++ Test cases: rename/{T13646,T17c,T17e,T7085}+ -}+ TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage+ {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when+ a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported+ abstractly, i.e. 'T'.++ Test cases: rename/should_compile/T7167+ -}+ TcRnDodgyImports :: RdrName -> TcRnMessage+ {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype+ 'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a+ type/data family.++ Example:+ module Foo (+ T(..) -- Warning: T is a type synonym+ , A(..) -- Warning: A is a type family+ , C(..) -- Warning: C is a data family+ ) where++ type T = Int+ type family A :: * -> *+ data family C :: * -> *++ Test cases: warnings/should_compile/DodgyExports01+ -}+ TcRnDodgyExports :: Name -> TcRnMessage+ {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when+ an import declaration does not explicitly list all the names brought into scope.++ Test cases: rename/should_compile/T4489+ -}+ TcRnMissingImportList :: IE GhcPs -> TcRnMessage
compiler/GHC/Tc/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -87,8 +87,6 @@ TcRnMessage ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Platform @@ -1348,38 +1346,35 @@ -- different packages. (currently not the case, but might be in the -- future). - imp_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot,- -- ^ Home-package modules needed by the module being compiled- --- -- It doesn't matter whether any of these dependencies- -- are actually /used/ when compiling the module; they- -- are listed if they are below it at all. For- -- example, suppose M imports A which imports X. Then- -- compiling M might not need to consult X.hi, but X- -- is still listed in M's dependencies.+ imp_direct_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot,+ -- ^ Home-package modules directly imported by the module being compiled. - imp_dep_pkgs :: Set UnitId,- -- ^ Packages needed by the module being compiled, whether directly,- -- or via other modules in this package, or via modules imported- -- from other packages.+ imp_dep_direct_pkgs :: Set UnitId,+ -- ^ Packages directly needed by the module being compiled + imp_trust_own_pkg :: Bool,+ -- ^ Do we require that our own package is trusted?+ -- This is to handle efficiently the case where a Safe module imports+ -- a Trustworthy module that resides in the same package as it.+ -- See Note [Trust Own Package] in "GHC.Rename.Names"++ -- Transitive information below here+ imp_trust_pkgs :: Set UnitId,- -- ^ This is strictly a subset of imp_dep_pkgs and records the+ -- ^ This records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if -- we are dependent on a trustworthy module in that package.- -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool)- -- where True for the bool indicates the package is required to be- -- trusted is the more logical design, doing so complicates a lot- -- of code not concerned with Safe Haskell. -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names" - imp_trust_own_pkg :: Bool,- -- ^ Do we require that our own package is trusted?- -- This is to handle efficiently the case where a Safe module imports- -- a Trustworthy module that resides in the same package as it.- -- See Note [Trust Own Package] in "GHC.Rename.Names"+ imp_boot_mods :: ModuleNameEnv ModuleNameWithIsBoot,+ -- ^ Domain is all modules which have hs-boot files, and whether+ -- we should import the boot version of interface file. Only used+ -- in one-shot mode to populate eps_is_boot. + imp_sig_mods :: [ModuleName],+ -- ^ Signature modules below this one+ imp_orphs :: [Module], -- ^ Orphan modules below us in the import tree (and maybe including -- us for imported modules)@@ -1395,6 +1390,20 @@ where add env elt = addToUFM env (gwib_mod elt) elt +plusModDeps :: ModuleNameEnv ModuleNameWithIsBoot+ -> ModuleNameEnv ModuleNameWithIsBoot+ -> ModuleNameEnv ModuleNameWithIsBoot+plusModDeps = plusUFM_C plus_mod_dep+ where+ plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })+ r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})+ | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))+ boot1 == IsBoot = r2+ | otherwise = r1+ -- If either side can "see" a non-hi-boot interface, use that+ -- Reusing existing tuples saves 10% of allocations on test+ -- perf/compiler/MultiLayerModules+ modDepsElts :: ModuleNameEnv ModuleNameWithIsBoot -> [ModuleNameWithIsBoot]@@ -1404,10 +1413,12 @@ emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,- imp_dep_mods = emptyUFM,- imp_dep_pkgs = S.empty,+ imp_direct_dep_mods = emptyUFM,+ imp_dep_direct_pkgs = S.empty,+ imp_sig_mods = [], imp_trust_pkgs = S.empty, imp_trust_own_pkg = False,+ imp_boot_mods = emptyUFM, imp_orphs = [], imp_finsts = [] } @@ -1419,29 +1430,28 @@ plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_mods = mods1,- imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,+ imp_direct_dep_mods = ddmods1,+ imp_dep_direct_pkgs = ddpkgs1,+ imp_boot_mods = srs1,+ imp_sig_mods = sig_mods1, imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, imp_orphs = orphs1, imp_finsts = finsts1 }) (ImportAvails { imp_mods = mods2,- imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,+ imp_direct_dep_mods = ddmods2,+ imp_dep_direct_pkgs = ddpkgs2,+ imp_boot_mods = srcs2,+ imp_sig_mods = sig_mods2, imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,- imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,- imp_dep_pkgs = dpkgs1 `S.union` dpkgs2,+ imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2,+ imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, imp_trust_own_pkg = tself1 || tself2,+ imp_boot_mods = srs1 `plusModDeps` srcs2,+ imp_sig_mods = sig_mods1 `unionLists` sig_mods2, imp_orphs = orphs1 `unionLists` orphs2, imp_finsts = finsts1 `unionLists` finsts2 }- where- plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })- r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})- | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot)))- boot1 == IsBoot = r2- | otherwise = r1- -- If either side can "see" a non-hi-boot interface, use that- -- Reusing existing tuples saves 10% of allocations on test- -- perf/compiler/MultiLayerModules {- ************************************************************************
compiler/GHC/Tc/Types/Constraint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -70,8 +70,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Types ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel@@ -144,7 +142,7 @@ The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq and forms condition T3 in Note [Extending the inert equalities]-in GHC.Tc.Solver.Monad.+in GHC.Tc.Solver.InertSet. -} @@ -194,7 +192,7 @@ | CEqCan { -- CanEqLHS ~ rhs -- Invariants:- -- * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad+ -- * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet -- * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify -- * (TyEq:OC) lhs does not occur in rhs (occurs check) -- Note [CEqCan occurs check]@@ -1192,7 +1190,7 @@ data HasGivenEqs -- See Note [HasGivenEqs] = NoGivenEqs -- Definitely no given equalities,- -- except by Note [Let-bound skolems] in GHC.Tc.Solver.Monad+ -- except by Note [Let-bound skolems] in GHC.Tc.Solver.InertSet | LocalGivenEqs -- Might have Given equalities, but only ones that affect only -- local skolems e.g. forall a b. (a ~ F b) => ... | MaybeGivenEqs -- Might have any kind of Given equalities; no floating out@@ -1204,7 +1202,7 @@ The GivenEqs data type describes the Given constraints of an implication constraint: * NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems- which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.Monad+ which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet Examples: forall a. Eq a => ... forall a. (Show a, Num a) => ... forall a. a ~ Either Int Bool => ... -- Let-bound skolem@@ -1650,7 +1648,7 @@ -- | Whether or not one 'Ct' can rewrite another is determined by its -- flavour and its equality relation. See also--- Note [Flavours with roles] in "GHC.Tc.Solver.Monad"+-- Note [Flavours with roles] in GHC.Tc.Solver.InertSet type CtFlavourRole = (CtFlavour, EqRel) -- | Extract the flavour, role, and boxity from a 'CtEvidence'@@ -1758,7 +1756,7 @@ into [D] F alpha ~NO T alpha, [D] F alpha ~R T alpha. Then, we use the R half of the split to rewrite the second D, and off we go. This splitting would allow the split-off R equality to be rewritten by other equalities,-thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.Monad.+thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet. This infelicity is #19665 and tested in typecheck/should_compile/T19665 (marked as expect_broken).
compiler/GHC/Tc/Types/Evidence.hs view
@@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} module GHC.Tc.Types.Evidence (@@ -60,7 +60,6 @@ -- * QuoteWrapper QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy ) where-#include "GhclibHsVersions.h" import GHC.Prelude @@ -341,13 +340,13 @@ mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co | isTcReflCo co = WpHole- | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co)+ | otherwise = assertPpr (tcCoercionRole co == Representational) (ppr co) $ WpCast co mkWpCastN :: TcCoercionN -> HsWrapper mkWpCastN co | isTcReflCo co = WpHole- | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co)+ | otherwise = assertPpr (tcCoercionRole co == Nominal) (ppr co) $ WpCast (mkTcSubCo co) -- The mkTcSubCo converts Nominal to Representational @@ -866,8 +865,8 @@ mkEvCast :: EvExpr -> TcCoercion -> EvTerm mkEvCast ev lco- | ASSERT2( tcCoercionRole lco == Representational- , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))+ | assertPpr (tcCoercionRole lco == Representational)+ (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $ isTcReflCo lco = EvExpr ev | otherwise = evCast ev lco
compiler/GHC/Tc/Types/Origin.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -22,8 +22,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Tc.Utils.TcType@@ -287,7 +285,7 @@ -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen-pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol"+pprSkolInfo UnkSkol = warnPprTrace True (text "pprSkolInfo: UnkSkol") $ text "UnkSkol" pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc -- The type is already tidied@@ -497,10 +495,9 @@ exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name-exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ hflLabel f)+exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ dfoLabel f) exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable"-exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut"-exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)+exprCtOrigin (HsRecSel _ f) = OccurrenceOfRecSel (unLoc $ foLabel f) exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip@@ -512,7 +509,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e-exprCtOrigin (HsPar _ e) = lexprCtOrigin e+exprCtOrigin (HsPar _ _ e _) = lexprCtOrigin e exprCtOrigin (HsProjection _ _) = SectionOrigin exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin
compiler/GHC/Tc/Utils/TcType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -193,8 +193,6 @@ ) where -#include "GhclibHsVersions.h"- -- friends: import GHC.Prelude @@ -229,6 +227,7 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Utils.Error( Validity(..), isValid ) import qualified GHC.LanguageExtensions as LangExt@@ -698,7 +697,7 @@ promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar promoteSkolem tclvl skol | tclvl < tcTyVarLevel skol- = ASSERT( isTcTyVar skol && isSkolemTyVar skol )+ = assert (isTcTyVar skol && isSkolemTyVar skol ) setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol)) | otherwise@@ -707,7 +706,7 @@ -- | Change the TcLevel in a skolem, extending a substitution promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar) promoteSkolemX tclvl subst skol- = ASSERT( isTcTyVar skol && isSkolemTyVar skol )+ = assert (isTcTyVar skol && isSkolemTyVar skol ) (new_subst, new_skol) where new_skol@@ -841,7 +840,7 @@ -- role-agnostic, and this one must be role-aware. We could make -- foldTyCon role-aware, but that may slow down more common usages. ----- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. {-# INLINE any_rewritable #-} -- this allows specialization of predicates any_rewritable ignore_cos role tv_pred tc_pred should_expand = go role emptyVarSet@@ -890,7 +889,7 @@ -> EqRel -- Ambient role -> (EqRel -> TcTyVar -> Bool) -- check tyvar -> TcType -> Bool--- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. anyRewritableTyVar ignore_cos role pred = any_rewritable ignore_cos role pred (\ _ _ _ -> False) -- no special check for tyconapps@@ -907,14 +906,14 @@ -- should return True only for type family applications -> TcType -> Bool -- always ignores casts & coercions--- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. anyRewritableTyFamApp role check_tyconapp = any_rewritable True role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon) -- This version is used by shouldSplitWD. It *does* look in casts -- and coercions, and it always expands type synonyms whose RHSs mention -- type families.--- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. anyRewritableCanEqLHS :: EqRel -- Ambient role -> (EqRel -> TcTyVar -> Bool) -- check tyvar -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family@@ -1005,8 +1004,8 @@ | isTyVar tv -- See Note [Coercion variables in free variable lists] , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv , isTouchableInfo info- = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,- ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )+ = assertPpr (checkTcLevelInvariant ctxt_tclvl tv_tclvl)+ (ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl) $ tv_tclvl `sameDepthAs` ctxt_tclvl | otherwise = False@@ -1028,7 +1027,7 @@ | otherwise = True isSkolemTyVar tv- = ASSERT2( tcIsTcTyVar tv, ppr tv )+ = assertPpr (tcIsTcTyVar tv) (ppr tv) $ case tcTyVarDetails tv of MetaTv {} -> False _other -> True@@ -1220,13 +1219,13 @@ -- Always succeeds, even if it returns an empty list. tcSplitPiTys :: Type -> ([TyBinder], Type) tcSplitPiTys ty- = ASSERT( all isTyBinder (fst sty) ) sty+ = assert (all isTyBinder (fst sty) ) sty where sty = splitPiTys ty -- | Splits a type into a TyBinder and a body, if possible. Panics otherwise tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) tcSplitPiTy_maybe ty- = ASSERT( isMaybeTyBinder sty ) sty+ = assert (isMaybeTyBinder sty ) sty where sty = splitPiTy_maybe ty isMaybeTyBinder (Just (t,_)) = isTyBinder t@@ -1234,14 +1233,14 @@ tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) tcSplitForAllTyVarBinder_maybe ty | Just ty' <- tcView ty = tcSplitForAllTyVarBinder_maybe ty'-tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)+tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = assert (isTyVarBinder tv ) Just (tv, ty) tcSplitForAllTyVarBinder_maybe _ = Nothing -- | Like 'tcSplitPiTys', but splits off only named binders, -- returning just the tyvars. tcSplitForAllTyVars :: Type -> ([TyVar], Type) tcSplitForAllTyVars ty- = ASSERT( all isTyVar (fst sty) ) sty+ = assert (all isTyVar (fst sty) ) sty where sty = splitForAllTyCoVars ty -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible'@@ -1265,18 +1264,18 @@ -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)-tcSplitForAllReqTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty+tcSplitForAllReqTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty where sty = splitForAllReqTVBinders ty -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. All split tyvars are annotated with their 'Specificity'. tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)-tcSplitForAllInvisTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty+tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty where sty = splitForAllInvisTVBinders ty -- | Like 'tcSplitForAllTyVars', but splits off only named binders. tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)-tcSplitForAllTyVarBinders ty = ASSERT( all isTyVarBinder (fst sty)) sty+tcSplitForAllTyVarBinders ty = assert (all isTyVarBinder (fst sty)) sty where sty = splitForAllTyCoVarBinders ty -- | Is this a ForAllTy with a named binder?
compiler/GHC/Types/Avail.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveDataTypeable #-} -- -- (c) The University of Glasgow -- -#include "GhclibHsVersions.h"- module GHC.Types.Avail ( Avails, AvailInfo(..),@@ -51,6 +49,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn) import Data.Data ( Data ) import Data.Either ( partitionEithers )
compiler/GHC/Types/Cpr.hs view
@@ -124,9 +124,9 @@ | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) | otherwise = topCprType -applyCprTy :: CprType -> CprType-applyCprTy (CprType n res)- | n > 0 = CprType (n-1) res+applyCprTy :: CprType -> Arity -> CprType+applyCprTy (CprType n res) k+ | n >= k = CprType (n-k) res | res == botCpr = botCprType | otherwise = topCprType
compiler/GHC/Types/Demand.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -76,8 +76,6 @@ -- * Zapping usage information zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Types/Error.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}@@ -24,12 +25,16 @@ , Diagnostic (..) , DiagnosticMessage (..) , DiagnosticReason (..)- , mkDiagnosticMessage+ , DiagnosticHint (..) , mkPlainDiagnostic , mkPlainError , mkDecoratedDiagnostic , mkDecoratedError + -- * Hints and refactoring actions+ , GhcHint (..)+ , noHints+ -- * Rendering Messages , SDoc@@ -67,6 +72,7 @@ import Data.Bifunctor import Data.Foldable ( fold )+import GHC.Types.Hint {- Note [Messages]@@ -202,7 +208,14 @@ class Diagnostic a where diagnosticMessage :: a -> DecoratedSDoc diagnosticReason :: a -> DiagnosticReason+ diagnosticHints :: a -> [GhcHint] +-- | A generic 'Hint' message, to be used with 'DiagnosticMessage'.+data DiagnosticHint = DiagnosticHint !SDoc++instance Outputable DiagnosticHint where+ ppr (DiagnosticHint msg) = msg+ -- | A generic 'Diagnostic' message, without any further classification or -- provenance: By looking at a 'DiagnosticMessage' we don't know neither -- /where/ it was generated nor how to intepret its payload (as it's just a@@ -211,30 +224,36 @@ data DiagnosticMessage = DiagnosticMessage { diagMessage :: !DecoratedSDoc , diagReason :: !DiagnosticReason+ , diagHints :: [GhcHint] } instance Diagnostic DiagnosticMessage where diagnosticMessage = diagMessage diagnosticReason = diagReason+ diagnosticHints = diagHints --- | Create a 'DiagnosticMessage' with a 'DiagnosticReason'-mkDiagnosticMessage :: DecoratedSDoc -> DiagnosticReason -> DiagnosticMessage-mkDiagnosticMessage = DiagnosticMessage+-- | Helper function to use when no hints can be provided. Currently this function+-- can be used to construct plain 'DiagnosticMessage' and add hints to them, but+-- once #18516 will be fully executed, the main usage of this function would be in+-- the implementation of the 'diagnosticHints' typeclass method, to report the fact+-- that a particular 'Diagnostic' has no hints.+noHints :: [GhcHint]+noHints = mempty -mkPlainDiagnostic :: DiagnosticReason -> SDoc -> DiagnosticMessage-mkPlainDiagnostic rea doc = DiagnosticMessage (mkSimpleDecorated doc) rea+mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage+mkPlainDiagnostic rea hints doc = DiagnosticMessage (mkSimpleDecorated doc) rea hints -- | Create an error 'DiagnosticMessage' holding just a single 'SDoc'-mkPlainError :: SDoc -> DiagnosticMessage-mkPlainError doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag+mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage+mkPlainError hints doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag hints -- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason'-mkDecoratedDiagnostic :: DiagnosticReason -> [SDoc] -> DiagnosticMessage-mkDecoratedDiagnostic rea docs = DiagnosticMessage (mkDecorated docs) rea+mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage+mkDecoratedDiagnostic rea hints docs = DiagnosticMessage (mkDecorated docs) rea hints -- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs-mkDecoratedError :: [SDoc] -> DiagnosticMessage-mkDecoratedError docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag+mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage+mkDecoratedError hints docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag hints -- | The reason /why/ a 'Diagnostic' was emitted in the first place. -- Diagnostic messages are born within GHC with a very precise reason, which
+ compiler/GHC/Types/Hint.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+module GHC.Types.Hint where++import GHC.Prelude++import GHC.Utils.Outputable+import GHC.LanguageExtensions+import Data.Typeable+import GHC.Unit.Module (ModuleName, Module)++-- | A type for hints emitted by GHC.+-- A /hint/ suggests a possible way to deal with a particular warning or error.+data GhcHint+ =+ {-| An \"unknown\" hint. This type constructor allows arbitrary+ -- hints to be embedded. The typical use case would be GHC plugins+ -- willing to emit hints alongside their custom diagnostics.+ -}+ forall a. (Outputable a, Typeable a) => UnknownHint a+ {-| Suggests adding a particular language extension. GHC will do its best trying+ to guess when the user is using the syntax of a particular language extension+ without having the relevant extension enabled.++ Example: If the user uses the keyword \"mdo\" (and we are in a monadic block), but+ the relevant extension is not enabled, GHC will emit a 'SuggestExtension RecursiveDo'.++ Test case(s): parser/should_fail/T12429, parser/should_fail/T8501c,+ parser/should_fail/T18251e, ... (and many more)++ -}+ | SuggestExtension !Extension+ {-| Suggests that a monadic code block is probably missing a \"do\" keyword.++ Example:+ main =+ putStrLn "hello"+ putStrLn "world"++ Test case(s): parser/should_fail/T8501a, parser/should_fail/readFail007,+ parser/should_fail/InfixAppPatErr, parser/should_fail/T984+ -}+ | SuggestMissingDo+ {-| Suggests that a \"let\" expression is needed in a \"do\" block.++ Test cases: None (that explicitly test this particular hint is emitted).+ -}+ | SuggestLetInDo+ {-| Suggests to add an \".hsig\" signature file to the Cabal manifest.++ Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal+ is being used.++ Example: See comment of 'DriverUnexpectedSignature'.++ Test case(s): driver/T12955++ -}+ | SuggestAddSignatureCabalFile !ModuleName+ {-| Suggests to explicitly list the instantiations for the signatures in+ the GHC invocation command.++ Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal+ is /not/ being used.++ Example: See comment of 'DriverUnexpectedSignature'.++ Test case(s): driver/T12955+ -}+ | SuggestSignatureInstantiations !ModuleName [InstantiationSuggestion]+ {-| Suggests to use spaces instead of tabs.++ Triggered by: 'GHC.Parser.Errors.Types.PsWarnTab'.++ Examples: None+ Test Case(s): None+ -}+ | SuggestUseSpaces+ {-| Suggests wrapping an expression in parentheses++ Examples: None+ Test Case(s): None+ -}+ | SuggestParentheses+++instance Outputable GhcHint where+ ppr = \case+ UnknownHint m+ -> ppr m+ SuggestExtension ext+ -> text "Perhaps you intended to use" <+> ppr ext+ SuggestMissingDo+ -> text "Possibly caused by a missing 'do'?"+ SuggestLetInDo+ -> text "Perhaps you need a 'let' in a 'do' block?"+ $$ text "e.g. 'let x = 5' instead of 'x = 5'"+ SuggestAddSignatureCabalFile pi_mod_name+ -> text "Try adding" <+> quotes (ppr pi_mod_name)+ <+> text "to the"+ <+> quotes (text "signatures")+ <+> text "field in your Cabal file."+ SuggestSignatureInstantiations pi_mod_name suggestions+ -> let suggested_instantiated_with =+ hcat (punctuate comma $+ [ ppr k <> text "=" <> ppr v+ | InstantiationSuggestion k v <- suggestions+ ])+ in text "Try passing -instantiated-with=\"" <>+ suggested_instantiated_with <> text "\"" $$+ text "replacing <" <> ppr pi_mod_name <> text "> as necessary."+ SuggestUseSpaces+ -> text "Please use spaces instead."+ SuggestParentheses+ -> text "Use parentheses."++-- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated+-- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way+-- to instantiate a particular signature, where the first argument is+-- the signature name and the second is the module where the signature+-- was defined.+-- Example:+--+-- src/MyStr.hsig:2:11: error:+-- Unexpected signature: ‘MyStr’+-- (Try passing -instantiated-with="MyStr=<MyStr>"+-- replacing <MyStr> as necessary.)+data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module
compiler/GHC/Types/Id.hs view
@@ -5,8 +5,8 @@ \section[Id]{@Ids@: Value and constructor identifiers} -} -{-# LANGUAGE CPP #-} + -- | -- #name_types# -- GHC uses several kinds of name internally:@@ -66,6 +66,7 @@ isRecordSelector, isNaughtyRecordSelector, isPatSynRecordSelector, isDataConRecordSelector,+ isClassOpId, isClassOpId_maybe, isDFunId, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe,@@ -120,8 +121,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,@@ -161,6 +160,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.GlobalVars import GHC.Driver.Ppr@@ -238,7 +238,7 @@ -- Make an Id with the same unique and type as the -- incoming Id, but with an *Internal* Name and *LocalId* flavour localiseId id- | ASSERT( isId id ) isLocalId id && isInternalName name+ | assert (isId id) $ isLocalId id && isInternalName name = id | otherwise = Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id)@@ -297,19 +297,19 @@ -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id-mkLocalId name w ty = ASSERT( not (isCoVarType ty) )+mkLocalId name w ty = assert (not (isCoVarType ty)) $ mkLocalIdWithInfo name w ty vanillaIdInfo -- | Make a local CoVar mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar name ty- = ASSERT( isCoVarType ty )+ = assert (isCoVarType ty) $ Var.mkLocalVar CoVarId name Many ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty- -- We should ASSERT(eqType w Many) in the isCoVarType case.+ -- We should assert (eqType w Many) in the isCoVarType case. -- However, currently this assertion does not hold. -- In tests with -fdefer-type-errors, such as T14584a, -- we create a linear 'case' where the scrutinee is a coercion@@ -319,7 +319,7 @@ -- proper ids only; no covars! mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id-mkLocalIdWithInfo name w ty info = ASSERT( not (isCoVarType ty) )+mkLocalIdWithInfo name w ty info = assert (not (isCoVarType ty)) $ Var.mkLocalVar VanillaId name w ty info -- Note [Free type variables] @@ -338,7 +338,7 @@ -- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") -- that are created by the compiler out of thin air mkSysLocal :: FastString -> Unique -> Mult -> Type -> Id-mkSysLocal fs uniq w ty = ASSERT( not (isCoVarType ty) )+mkSysLocal fs uniq w ty = assert (not (isCoVarType ty)) $ mkLocalId (mkSystemVarName uniq fs) w ty -- | Like 'mkSysLocal', but checks to see if we have a covar type@@ -355,7 +355,7 @@ -- | Create a user local 'Id'. These are local 'Id's (see "GHC.Types.Var#globalvslocal") with a name and location that the user might recognize mkUserLocal :: OccName -> Unique -> Mult -> Type -> SrcSpan -> Id-mkUserLocal occ uniq w ty loc = ASSERT( not (isCoVarType ty) )+mkUserLocal occ uniq w ty loc = assert (not (isCoVarType ty)) $ mkLocalId (mkInternalName uniq occ loc) w ty -- | Like 'mkUserLocal', but checks if we have a coercion type@@ -458,6 +458,7 @@ isDataConWorkId :: Id -> Bool isDataConWrapId :: Id -> Bool isDFunId :: Id -> Bool+isClassOpId :: Id -> Bool isClassOpId_maybe :: Id -> Maybe Class isPrimOpId_maybe :: Id -> Maybe PrimOp@@ -481,6 +482,10 @@ RecSelId { sel_naughty = n } -> n _ -> False +isClassOpId id = case Var.idDetails id of+ ClassOpId _ -> True+ _other -> False+ isClassOpId_maybe id = case Var.idDetails id of ClassOpId cls -> Just cls _other -> Nothing@@ -539,7 +544,7 @@ isJoinId_maybe :: Var -> Maybe JoinArity isJoinId_maybe id- | isId id = ASSERT2( isId id, ppr id )+ | isId id = assertPpr (isId id) (ppr id) $ case Var.idDetails id of JoinId arity -> Just arity _ -> Nothing@@ -622,10 +627,10 @@ idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) asJoinId :: Id -> JoinArity -> JoinId-asJoinId id arity = WARN(not (isLocalId id),- text "global id being marked as join var:" <+> ppr id)- WARN(not (is_vanilla_or_join id),- ppr id <+> pprIdDetails (idDetails id))+asJoinId id arity = warnPprTrace (not (isLocalId id))+ (text "global id being marked as join var:" <+> ppr id) $+ warnPprTrace (not (is_vanilla_or_join id))+ (ppr id <+> pprIdDetails (idDetails id)) $ id `setIdDetails` JoinId arity where is_vanilla_or_join id = case Var.idDetails id of@@ -700,7 +705,7 @@ -- type, we still want @isStrictId id@ to be @True@. isStrictId :: Id -> Bool isStrictId id- | ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )+ | assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $ isJoinId id = False | otherwise = isStrictType (idType id) || isStrUsedDmd (idDemandInfo id)
compiler/GHC/Types/Id/Info.hs view
@@ -8,7 +8,7 @@ Haskell. [WDP 94/11]) -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BinaryLiterals #-} @@ -87,8 +87,6 @@ isNeverLevPolyIdInfo ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Core hiding( hasCoreUnfolding )@@ -111,6 +109,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.Word @@ -334,13 +333,13 @@ bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField bitfieldSetCallArityInfo info bf@(BitField bits) =- ASSERT(info < 2^(30 :: Int) - 1)+ assert (info < 2^(30 :: Int) - 1) $ bitfieldSetArityInfo (bitfieldGetArityInfo bf) $ BitField ((fromIntegral info `shiftL` 3) .|. (bits .&. 0b111)) bitfieldSetArityInfo :: ArityInfo -> BitField -> BitField bitfieldSetArityInfo info (BitField bits) =- ASSERT(info < 2^(30 :: Int) - 1)+ assert (info < 2^(30 :: Int) - 1) $ BitField ((fromIntegral info `shiftL` 33) .|. (bits .&. ((1 `shiftL` 33) - 1))) -- Getters@@ -741,7 +740,7 @@ -- polymorphic setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo setNeverLevPoly info ty- = ASSERT2( not (resultIsLevPoly ty), ppr ty )+ = assertPpr (not (resultIsLevPoly ty)) (ppr ty) $ info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } setLevityInfoWithType :: IdInfo -> Type -> IdInfo
compiler/GHC/Types/Id/Make.hs view
@@ -12,8 +12,8 @@ - primitive operations -} -{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Types.Id.Make (@@ -38,8 +38,6 @@ module GHC.Core.Opt.ConstantFold ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Builtin.Types.Prim@@ -81,6 +79,7 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.List.SetOps import GHC.Types.Var (VarBndr(Bndr))@@ -601,9 +600,8 @@ `setLevityInfoWithType` wkr_ty id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) res_ty_args = mkTyCoVarTys univ_tvs- newtype_unf = ASSERT2( isVanillaDataCon data_con &&- isSingleton arg_tys- , ppr data_con )+ newtype_unf = assertPpr (isVanillaDataCon data_con && isSingleton arg_tys)+ (ppr data_con) $ -- Note [Newtype datacons] mkCompulsoryUnfolding defaultSimpleOpts $ mkLams univ_tvs $ Lam id_arg1 $@@ -821,7 +819,7 @@ ; (rep_ids, binds) <- go subst2 boxers term_vars ; return (ex_vars ++ rep_ids, binds) } ) - go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])+ go _ [] src_vars = assertPpr (null src_vars) (ppr data_con) $ return ([], []) go subst (UnitBox : boxers) (src_var : src_vars) = do { (rep_ids2, binds) <- go subst boxers src_vars ; return (src_var : rep_ids2, binds) }@@ -847,8 +845,8 @@ {- Note [Activation for data constructor wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Activation on a data constructor wrapper allows it to inline only in Phase-0. This way rules have a chance to fire if they mention a data constructor on+The Activation on a data constructor wrapper allows it to inline only in FinalPhase.+This way rules have a chance to fire if they mention a data constructor on the left RULE "foo" f (K a b) = ... Since the LHS of rules are simplified with InitialPhase, we won't@@ -1110,7 +1108,7 @@ -- A recursive newtype might mean that -- 'arg_ty' is a newtype , let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args- = ASSERT( null (dataConExTyCoVars con) )+ = assert (null (dataConExTyCoVars con)) -- Note [Unpacking GADTs and existentials] ( rep_tys `zip` dataConRepStrictness con ,( \ arg_id ->@@ -1273,7 +1271,7 @@ -- it, otherwise the wrap/unwrap are both no-ops wrapNewTypeBody tycon args result_expr- = ASSERT( isNewTyCon tycon )+ = assert (isNewTyCon tycon) $ mkCast result_expr (mkSymCo co) where co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []@@ -1285,7 +1283,7 @@ unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr- = ASSERT( isNewTyCon tycon )+ = assert (isNewTyCon tycon) $ mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) -- If the type constructor is a representation type of a data instance, wrap@@ -1347,7 +1345,7 @@ mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id mkFCallId dflags uniq fcall ty- = ASSERT( noFreeVarsOfType ty )+ = assert (noFreeVarsOfType ty) $ -- A CCallOpId should have no free type variables; -- when doing substitutions won't substitute over it mkGlobalId (FCallId fcall) name ty info
compiler/GHC/Types/Literal.hs view
@@ -4,7 +4,7 @@ -} -{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE AllowAmbiguousTypes #-}@@ -63,8 +63,6 @@ , nullAddrLit, floatToDoubleLit, doubleToFloatLit ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Builtin.Types.Prim@@ -77,7 +75,6 @@ import GHC.Utils.Binary import GHC.Settings.Constants import GHC.Platform-import GHC.Utils.Misc import GHC.Utils.Panic import Data.ByteString (ByteString)@@ -375,12 +372,12 @@ -- | Create a numeric 'Literal' of the given type mkLitNumber :: Platform -> LitNumType -> Integer -> Literal mkLitNumber platform nt i =- ASSERT2(litNumCheckRange platform nt i, integer i)+ assertPpr (litNumCheckRange platform nt i) (integer i) (LitNumber nt i) -- | Creates a 'Literal' of type @Int#@ mkLitInt :: Platform -> Integer -> Literal-mkLitInt platform x = ASSERT2( platformInIntRange platform x, integer x )+mkLitInt platform x = assertPpr (platformInIntRange platform x) (integer x) (mkLitIntUnchecked x) -- | Creates a 'Literal' of type @Int#@.@@ -404,7 +401,7 @@ -- | Creates a 'Literal' of type @Word#@ mkLitWord :: Platform -> Integer -> Literal-mkLitWord platform x = ASSERT2( platformInWordRange platform x, integer x )+mkLitWord platform x = assertPpr (platformInWordRange platform x) (integer x) (mkLitWordUnchecked x) -- | Creates a 'Literal' of type @Word#@.@@ -428,7 +425,7 @@ -- | Creates a 'Literal' of type @Int8#@ mkLitInt8 :: Integer -> Literal-mkLitInt8 x = ASSERT2( inBoundedRange @Int8 x, integer x ) (mkLitInt8Unchecked x)+mkLitInt8 x = assertPpr (inBoundedRange @Int8 x) (integer x) (mkLitInt8Unchecked x) -- | Creates a 'Literal' of type @Int8#@. -- If the argument is out of the range, it is wrapped.@@ -441,7 +438,7 @@ -- | Creates a 'Literal' of type @Word8#@ mkLitWord8 :: Integer -> Literal-mkLitWord8 x = ASSERT2( inBoundedRange @Word8 x, integer x ) (mkLitWord8Unchecked x)+mkLitWord8 x = assertPpr (inBoundedRange @Word8 x) (integer x) (mkLitWord8Unchecked x) -- | Creates a 'Literal' of type @Word8#@. -- If the argument is out of the range, it is wrapped.@@ -454,7 +451,7 @@ -- | Creates a 'Literal' of type @Int16#@ mkLitInt16 :: Integer -> Literal-mkLitInt16 x = ASSERT2( inBoundedRange @Int16 x, integer x ) (mkLitInt16Unchecked x)+mkLitInt16 x = assertPpr (inBoundedRange @Int16 x) (integer x) (mkLitInt16Unchecked x) -- | Creates a 'Literal' of type @Int16#@. -- If the argument is out of the range, it is wrapped.@@ -467,7 +464,7 @@ -- | Creates a 'Literal' of type @Word16#@ mkLitWord16 :: Integer -> Literal-mkLitWord16 x = ASSERT2( inBoundedRange @Word16 x, integer x ) (mkLitWord16Unchecked x)+mkLitWord16 x = assertPpr (inBoundedRange @Word16 x) (integer x) (mkLitWord16Unchecked x) -- | Creates a 'Literal' of type @Word16#@. -- If the argument is out of the range, it is wrapped.@@ -480,7 +477,7 @@ -- | Creates a 'Literal' of type @Int32#@ mkLitInt32 :: Integer -> Literal-mkLitInt32 x = ASSERT2( inBoundedRange @Int32 x, integer x ) (mkLitInt32Unchecked x)+mkLitInt32 x = assertPpr (inBoundedRange @Int32 x) (integer x) (mkLitInt32Unchecked x) -- | Creates a 'Literal' of type @Int32#@. -- If the argument is out of the range, it is wrapped.@@ -493,7 +490,7 @@ -- | Creates a 'Literal' of type @Word32#@ mkLitWord32 :: Integer -> Literal-mkLitWord32 x = ASSERT2( inBoundedRange @Word32 x, integer x ) (mkLitWord32Unchecked x)+mkLitWord32 x = assertPpr (inBoundedRange @Word32 x) (integer x) (mkLitWord32Unchecked x) -- | Creates a 'Literal' of type @Word32#@. -- If the argument is out of the range, it is wrapped.@@ -506,7 +503,7 @@ -- | Creates a 'Literal' of type @Int64#@ mkLitInt64 :: Integer -> Literal-mkLitInt64 x = ASSERT2( inBoundedRange @Int64 x, integer x ) (mkLitInt64Unchecked x)+mkLitInt64 x = assertPpr (inBoundedRange @Int64 x) (integer x) (mkLitInt64Unchecked x) -- | Creates a 'Literal' of type @Int64#@. -- If the argument is out of the range, it is wrapped.@@ -519,7 +516,7 @@ -- | Creates a 'Literal' of type @Word64#@ mkLitWord64 :: Integer -> Literal-mkLitWord64 x = ASSERT2( inBoundedRange @Word64 x, integer x ) (mkLitWord64Unchecked x)+mkLitWord64 x = assertPpr (inBoundedRange @Word64 x) (integer x) (mkLitWord64Unchecked x) -- | Creates a 'Literal' of type @Word64#@. -- If the argument is out of the range, it is wrapped.@@ -552,7 +549,7 @@ mkLitInteger x = LitNumber LitNumInteger x mkLitNatural :: Integer -> Literal-mkLitNatural x = ASSERT2( inNaturalRange x, integer x )+mkLitNatural x = assertPpr (inNaturalRange x) (integer x) (LitNumber LitNumNatural x) -- | Create a rubbish literal of the given representation.
compiler/GHC/Types/Name/Cache.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE RankNTypes #-} -- | The Name Cache@@ -25,15 +25,12 @@ import GHC.Builtin.Types import GHC.Builtin.Names -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import Control.Concurrent.MVar import Control.Monad -#include "GhclibHsVersions.h"- {- Note [The Name Cache]@@ -119,7 +116,7 @@ extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache' nc name- = ASSERT2( isExternalName name, ppr name )+ = assertPpr (isExternalName name) (ppr name) $ extendOrigNameCache nc (nameModule name) (nameOccName name) name extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
compiler/GHC/Types/Name/Env.hs view
@@ -5,7 +5,7 @@ \section[NameEnv]{@NameEnv@: name environments} -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,8 +34,6 @@ -- ** Dependency analysis depAnal ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Types/Name/Occurrence.hs view
@@ -28,8 +28,6 @@ -- * The 'NameSpace' type NameSpace, -- Abstract - nameSpacesRelated,- -- ** Construction -- $real_vs_source_data_constructors tcName, clsName, tcClsName, dataName, varName,@@ -357,19 +355,6 @@ promoteOccName (OccName space name) = do space' <- promoteNameSpace space return $ OccName space' name---- Name spaces are related if there is a chance to mean the one when one writes--- the other, i.e. variables <-> data constructors and type variables <-> type constructors-nameSpacesRelated :: NameSpace -> NameSpace -> Bool-nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2--otherNameSpace :: NameSpace -> NameSpace-otherNameSpace VarName = DataName-otherNameSpace DataName = VarName-otherNameSpace TvName = TcClsName-otherNameSpace TcClsName = TvName-- {- | Other names in the compiler add additional information to an OccName. This class provides a consistent way to access the underlying OccName. -}
compiler/GHC/Types/Name/Ppr.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} + module GHC.Types.Name.Ppr ( mkPrintUnqualified , mkQualModule@@ -8,8 +8,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Unit@@ -112,7 +110,7 @@ -- Eg f = True; g = 0; f = False where is_name :: Name -> Bool- is_name name = ASSERT2( isExternalName name, ppr name )+ is_name name = assertPpr (isExternalName name) (ppr name) $ nameModule name == mod && nameOccName name == occ forceUnqualNames :: [Name]
compiler/GHC/Types/Name/Reader.hs view
@@ -3,7 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} -- | -- #name_types#@@ -77,8 +78,6 @@ opIsAt, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Unit.Module@@ -1368,7 +1367,7 @@ 2 (pprLoc loc) where loc = nameSrcSpan name- defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+ defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name same_module = importSpecModule imp_spec == moduleName defining_mod pp_mod | same_module = empty | otherwise = text "in" <+> quotes (ppr defining_mod)
compiler/GHC/Types/Name/Set.hs view
@@ -3,7 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1998 -} -{-# LANGUAGE CPP #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Types.Name.Set ( -- * Names set type@@ -34,8 +34,6 @@ -- * Non-CAFfy names NonCaffySet(..) ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Types/RepType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleContexts #-} module GHC.Types.RepType@@ -21,8 +21,6 @@ slotPrimRep, primRepSlot ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Types.Basic (Arity, RepArity)@@ -39,6 +37,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.List (sort) import qualified Data.IntSet as IS@@ -532,7 +531,7 @@ | Just ki' <- coreView ki = kindPrimRep doc ki' kindPrimRep doc (TyConApp typ [runtime_rep])- = ASSERT( typ `hasKey` tYPETyConKey )+ = assert (typ `hasKey` tYPETyConKey) $ runtimeRepPrimRep doc runtime_rep kindPrimRep doc ki = pprPanic "kindPrimRep" (ppr ki $$ doc)@@ -543,7 +542,7 @@ runtimeRepMonoPrimRep_maybe :: HasDebugCallStack => Type -> Maybe [PrimRep] runtimeRepMonoPrimRep_maybe rr_ty | Just (rr_dc, args) <- splitTyConApp_maybe rr_ty- , ASSERT2( runtimeRepTy `eqType` typeKind rr_ty, ppr rr_ty ) True+ , assertPpr (runtimeRepTy `eqType` typeKind rr_ty) (ppr rr_ty) True , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc = Just (fun args) | otherwise
compiler/GHC/Types/SrcLoc.hs view
@@ -120,6 +120,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString+import qualified GHC.Data.Strict as Strict import Control.DeepSeq import Control.Applicative (liftA2)@@ -225,8 +226,8 @@ -- | Source Location data SrcLoc- = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos]- | UnhelpfulLoc FastString -- Just a general indication+ = RealSrcLoc !RealSrcLoc !(Strict.Maybe BufPos) -- See Note [Why Maybe BufPos]+ | UnhelpfulLoc !FastString -- Just a general indication deriving (Eq, Show) {-@@ -238,14 +239,14 @@ -} mkSrcLoc :: FastString -> Int -> Int -> SrcLoc-mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Strict.Nothing mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col -getBufPos :: SrcLoc -> Maybe BufPos+getBufPos :: SrcLoc -> Strict.Maybe BufPos getBufPos (RealSrcLoc _ mbpos) = mbpos-getBufPos (UnhelpfulLoc _) = Nothing+getBufPos (UnhelpfulLoc _) = Strict.Nothing -- | Built-in "bad" 'SrcLoc' values for particular locations noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc@@ -381,7 +382,7 @@ -- A 'SrcSpan' identifies either a specific portion of a text file -- or a human-readable description of a location. data SrcSpan =- RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos]+ RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] | UnhelpfulSpan !UnhelpfulSpanReason deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we@@ -430,9 +431,9 @@ instance NFData SrcSpan where rnf x = x `seq` () -getBufSpan :: SrcSpan -> Maybe BufSpan+getBufSpan :: SrcSpan -> Strict.Maybe BufSpan getBufSpan (RealSrcSpan _ mbspan) = mbspan-getBufSpan (UnhelpfulSpan _) = Nothing+getBufSpan (UnhelpfulSpan _) = Strict.Nothing -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan@@ -773,8 +774,8 @@ -- Precondition: both operands have an associated 'BufSpan'. cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering cmpBufSpan (L l1 _) (L l2 _)- | Just a <- getBufSpan l1- , Just b <- getBufSpan l2+ | Strict.Just a <- getBufSpan l1+ , Strict.Just b <- getBufSpan l2 = compare a b | otherwise = panic "cmpBufSpan: no BufSpan"@@ -787,7 +788,7 @@ instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where ppr (L l e) = -- GenLocated: -- Print spans without the file name etc- whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Nothing)))+ whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Strict.Nothing))) $$ ppr e @@ -882,7 +883,7 @@ psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) mkSrcSpanPs :: PsSpan -> SrcSpan-mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b)+mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b) -- | Layout information for declarations. data LayoutInfo =
compiler/GHC/Types/TyThing.hs view
@@ -229,6 +229,8 @@ tyThingParent_maybe (AnId id) = case idDetails id of RecSelId { sel_tycon = RecSelData tc } -> Just (ATyCon tc)+ RecSelId { sel_tycon = RecSelPatSyn ps } ->+ Just (AConLike (PatSynCon ps)) ClassOpId cls -> Just (ATyCon (classTyCon cls)) _other -> Nothing@@ -311,5 +313,3 @@ -- Instance used in GHC.HsToCore.Quote instance MonadThings m => MonadThings (ReaderT s m) where lookupThing = lift . lookupThing--
compiler/GHC/Types/Unique.hs view
@@ -17,7 +17,8 @@ Haskell). -} -{-# LANGUAGE CPP, BangPatterns, MagicHash #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, MagicHash #-} module GHC.Types.Unique ( -- * Main data types@@ -45,15 +46,13 @@ mkLocalUnique, minLocalUnique, maxLocalUnique, ) where -#include "GhclibHsVersions.h" #include "Unique.h" import GHC.Prelude import GHC.Data.FastString import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic+import GHC.Utils.Panic.Plain -- just for implementing a fast [0,61) -> Char function import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))@@ -311,7 +310,7 @@ iToBase62 :: Int -> String iToBase62 n_- = ASSERT(n_ >= 0) go n_ ""+ = assert (n_ >= 0) $ go n_ "" where go n cs | n < 62 = let !c = chooseChar62 n in c : cs
compiler/GHC/Types/Unique/FM.hs view
@@ -23,7 +23,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wall #-} module GHC.Types.Unique.FM (@@ -54,6 +54,7 @@ plusUFM_C, plusUFM_CD, plusUFM_CD2,+ mergeUFM, plusMaybeUFM_C, plusUFMList, minusUFM,@@ -77,20 +78,18 @@ pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable-import GHC.Utils.Panic (assertPanic)-import GHC.Utils.Misc (debugIsOn)+import GHC.Utils.Panic.Plain import qualified Data.IntMap as M import qualified Data.IntMap.Strict as MS import qualified Data.IntSet as S import Data.Data import qualified Data.Semigroup as Semi import Data.Functor.Classes (Eq1 (..))+import Data.Coerce -- | A finite map from @uniques@ of one type to -- elements in another type.@@ -127,7 +126,7 @@ -- Note that listToUFM (zip ks vs) performs similarly, but -- the explicit recursion avoids relying too much on fusion. zipToUFM :: Uniquable key => [key] -> [elt] -> UniqFM key elt-zipToUFM ks vs = ASSERT( length ks == length vs ) innerZip emptyUFM ks vs+zipToUFM ks vs = assert (length ks == length vs ) innerZip emptyUFM ks vs where innerZip ufm (k:kList) (v:vList) = innerZip (addToUFM ufm k v) kList vList innerZip ufm _ _ = ufm@@ -274,6 +273,20 @@ (\_ x y -> Just (Just x `f` Just y)) (MS.map (\x -> Just x `f` Nothing)) (MS.map (\y -> Nothing `f` Just y))+ xm ym++mergeUFM+ :: (elta -> eltb -> Maybe eltc)+ -> (UniqFM key elta -> UniqFM key eltc) -- map X+ -> (UniqFM key eltb -> UniqFM key eltc) -- map Y+ -> UniqFM key elta+ -> UniqFM key eltb+ -> UniqFM key eltc+mergeUFM f g h (UFM xm) (UFM ym)+ = UFM $ MS.mergeWithKey+ (\_ x y -> (x `f` y))+ (coerce g)+ (coerce h) xm ym plusMaybeUFM_C :: (elt -> elt -> Maybe elt)
compiler/GHC/Types/Unique/Supply.hs view
@@ -43,14 +43,10 @@ import GHC.Exts( Ptr(..), noDuplicate#, oneShot ) #if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )-#if defined(DEBUG)-import GHC.Utils.Misc #endif-#endif import Foreign.Storable #include "Unique.h"-#include "GhclibHsVersions.h" {- ************************************************************************@@ -241,7 +237,7 @@ #if defined(DEBUG) -- Uh oh! We will overflow next time a unique is requested. -- (Note that if the increment isn't 1 we may miss this check)- MASSERT(u /= mask)+ massert (u /= mask) #endif return u #endif
compiler/GHC/Types/Var.hs view
@@ -5,7 +5,7 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable,+{-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms, BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -95,8 +95,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult )@@ -112,6 +110,7 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import Data.Data @@ -409,13 +408,10 @@ -- abuse, ASSERTs that there is no multiplicity to update. updateVarType :: (Type -> Type) -> Var -> Var updateVarType upd var- | debugIsOn = case var of- Id { id_details = details } -> ASSERT( isCoVarDetails details )+ Id { id_details = details } -> assert (isCoVarDetails details) $ result _ -> result- | otherwise- = result where result = var { varType = upd (varType var) } @@ -424,13 +420,10 @@ -- abuse, ASSERTs that there is no multiplicity to update. updateVarTypeM :: Monad m => (Type -> m Type) -> Var -> m Var updateVarTypeM upd var- | debugIsOn = case var of- Id { id_details = details } -> ASSERT( isCoVarDetails details )+ Id { id_details = details } -> assert (isCoVarDetails details) $ result _ -> result- | otherwise- = result where result = do { ty' <- upd (varType var) ; return (var { varType = ty' }) }@@ -683,7 +676,7 @@ -- 'var' should be a type variable mkTyVarBinder :: vis -> TyVar -> VarBndr TyVar vis mkTyVarBinder vis var- = ASSERT( isTyVar var )+ = assert (isTyVar var) $ Bndr var vis -- | Make many named binders@@ -848,7 +841,7 @@ setIdNotExported :: Id -> Id -- ^ We can only do this to LocalIds-setIdNotExported id = ASSERT( isLocalId id )+setIdNotExported id = assert (isLocalId id) $ id { idScope = LocalId NotExported } -----------------------
compiler/GHC/Types/Var/Set.hs view
@@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP #-} + module GHC.Types.Var.Set ( -- * Var, Id and TyVar set types VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet,@@ -45,8 +45,6 @@ partitionDVarSet, dVarSetToVarSet, ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Unit/Info.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} -- | Info about installed units (compiled libraries) module GHC.Unit.Info@@ -28,8 +28,6 @@ , unitHsLibs ) where--#include "GhclibHsVersions.h" import GHC.Prelude import GHC.Platform.Ways
compiler/GHC/Unit/Module/Deps.hs view
@@ -17,25 +17,41 @@ import GHC.Utils.Binary -- | Dependency information about ALL modules and packages below this one--- in the import hierarchy.+-- in the import hierarchy. This is the serialisable version of `ImportAvails`. -- -- Invariant: the dependencies of a module @M@ never includes @M@. -- -- Invariant: none of the lists contain duplicates.+--+-- See Note [Transitive Information in Dependencies] data Dependencies = Deps- { dep_mods :: [ModuleNameWithIsBoot]- -- ^ All home-package modules transitively below this one- -- I.e. modules that this one imports, or that are in the- -- dep_mods of those directly-imported modules+ { dep_direct_mods :: [ModuleNameWithIsBoot]+ -- ^ All home-package modules which are directly imported by this one. - , dep_pkgs :: [(UnitId, Bool)]- -- ^ All packages transitively below this module- -- I.e. packages to which this module's direct imports belong,- -- or that are in the dep_pkgs of those modules- -- The bool indicates if the package is required to be- -- trusted when the module is imported as a safe import+ , dep_direct_pkgs :: [UnitId]+ -- ^ All packages directly imported by this module+ -- I.e. packages to which this module's direct imports belong.+ --+ , dep_plgins :: [ModuleName]+ -- ^ All the plugins used while compiling this module.+++ -- Transitive information below here+ , dep_sig_mods :: ![ModuleName]+ -- ^ Transitive closure of hsig files in the home package+++ , dep_trusted_pkgs :: [UnitId]+ -- Packages which we are required to trust+ -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names + , dep_boot_mods :: [ModuleNameWithIsBoot]+ -- ^ All modules which have boot files below this one, and whether we+ -- should use the boot file or not.+ -- This information is only used to populate the eps_is_boot field.+ -- See Note [Structure of dep_boot_mods]+ , dep_orphs :: [Module] -- ^ Transitive closure of orphan modules (whether -- home or external pkg).@@ -53,30 +69,39 @@ -- does NOT include us, unlike 'imp_finsts'. See Note -- [The type family instance consistency story]. - , dep_plgins :: [ModuleName]- -- ^ All the plugins used while compiling this module. } deriving( Eq ) -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies. instance Binary Dependencies where- put_ bh deps = do put_ bh (dep_mods deps)- put_ bh (dep_pkgs deps)+ put_ bh deps = do put_ bh (dep_direct_mods deps)+ put_ bh (dep_direct_pkgs deps)+ put_ bh (dep_trusted_pkgs deps)+ put_ bh (dep_sig_mods deps)+ put_ bh (dep_boot_mods deps) put_ bh (dep_orphs deps) put_ bh (dep_finsts deps) put_ bh (dep_plgins deps) - get bh = do ms <- get bh- ps <- get bh+ get bh = do dms <- get bh+ dps <- get bh+ tps <- get bh+ hsigms <- get bh+ sms <- get bh os <- get bh fis <- get bh pl <- get bh- return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,+ return (Deps { dep_direct_mods = dms+ , dep_direct_pkgs = dps+ , dep_sig_mods = hsigms+ , dep_boot_mods = sms+ , dep_trusted_pkgs = tps+ , dep_orphs = os, dep_finsts = fis, dep_plgins = pl }) noDependencies :: Dependencies-noDependencies = Deps [] [] [] [] []+noDependencies = Deps [] [] [] [] [] [] [] [] -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance@@ -193,3 +218,75 @@ hash <- get bh return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } i -> error ("Binary.get(Usage): " ++ show i)+++{-+Note [Transitive Information in Dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is important to be careful what information we put in 'Dependencies' because+ultimately it ends up serialised in an interface file. Interface files must always+be kept up-to-date with the state of the world, so if `Dependencies` needs to be updated+then the module had to be recompiled just to update `Dependencies`.++Before #16885, the dependencies used to contain the transitive closure of all+home modules. Therefore, if you added an import somewhere low down in the home package+it would recompile nearly every module in your project, just to update this information.++Now, we are a bit more careful about what we store and+explicitly store transitive information only if it is really needed.++# Direct Information++* dep_direct_mods - Directly imported home package modules+* dep_direct_pkgs - Directly imported packages+* dep_plgins - Directly used plugins++# Transitive Information++Some features of the compiler require transitive information about what is currently+being compiled, so that is explicitly stored separately in the form they need.++* dep_trusted_pkgs - Only used for the -fpackage-trust feature+* dep_boot_mods - Only used to populate eps_is_boot in -c mode+* dep_orphs - Modules with orphan instances+* dep_finsts - Modules with type family instances++Important note: If you add some transitive information to the interface file then+you need to make sure recompilation is triggered when it could be out of date.+The correct way to do this is to include the transitive information in the export+hash of the module. The export hash is computed in `GHC.Iface.Recomp.addFingerprints`.+-}++{-+Note [Structure of mod_boot_deps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In `-c` mode we always need to know whether to load the normal or boot version of+an interface file, and this can't be determined from just looking at the direct imports.++Consider modules with dependencies:++```+A -(S)-> B+A -> C -> B -(S)-> B+```++Say when compiling module `A` that we need to load the interface for `B`, do we load+`B.hi` or `B.hi-boot`? Well, `A` does directly {-# SOURCE #-} import B, so you might think+that we would load the `B.hi-boot` file, however this is wrong because `C` imports+`B` normally. Therefore in the interface file for `C` we still need to record that+there is a hs-boot file for `B` below it but that we now want `B.hi` rather than+`B.hi-boot`. When `C` is imported, the fact that it needs `B.hi` clobbers the `{- SOURCE -}`+import for `B`.++Therefore in mod_boot_deps we store the names of any modules which have hs-boot files,+and whether we want to import the .hi or .hi-boot version of the interface file.++If you get this wrong, then GHC fails to compile, so there is a test but you might+not make it that far if you get this wrong!++Question: does this happen even across packages?+No: if I need to load the interface for module X from package P I always look for p:X.hi.++-}
compiler/GHC/Unit/Module/ModIface.hs view
@@ -282,7 +282,7 @@ -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef)) _ -> emptyUniqDSet where- cands = map gwib_mod $ dep_mods $ mi_deps iface+ cands = dep_sig_mods $ mi_deps iface -- | Given a set of free holes, and a unit identifier, rename -- the free holes according to the instantiation of the unit
compiler/GHC/Unit/Module/Status.hs view
@@ -1,5 +1,5 @@ module GHC.Unit.Module.Status- ( HscStatus (..)+ ( HscBackendAction(..), HscRecompStatus (..) ) where @@ -8,20 +8,22 @@ import GHC.Unit import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModDetails import GHC.Utils.Fingerprint --- | Status of a module compilation to machine code-data HscStatus- -- | Nothing to do.- = HscNotGeneratingCode ModIface ModDetails+-- | Status of a module in incremental compilation+data HscRecompStatus -- | Nothing to do because code already exists.- | HscUpToDate ModIface ModDetails- -- | Update boot file result.- | HscUpdateBoot ModIface ModDetails- -- | Generate signature file (backpack)- | HscUpdateSig ModIface ModDetails+ = HscUpToDate ModIface+ -- | Recompilation of module, or update of interface is required. Optionally+ -- pass the old interface hash to avoid updating the existing interface when+ -- it has not changed.+ | HscRecompNeeded (Maybe Fingerprint)++-- | Action to perform in backend compilation+data HscBackendAction+ -- | Update the boot and signature file results.+ = HscUpdate ModIface -- | Recompile this module. | HscRecomp { hscs_guts :: CgGuts
compiler/GHC/Unit/State.hs view
@@ -1,6 +1,6 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -- | Unit manipulation@@ -68,8 +68,6 @@ unwireUnit ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Unit/Types.hs view
@@ -290,7 +290,7 @@ u1 == u2 = instUnitKey u1 == instUnitKey u2 instance Ord (GenInstantiatedUnit unit) where- u1 `compare` u2 = instUnitFS u1 `uniqCompareFS` instUnitFS u2+ u1 `compare` u2 = instUnitFS u1 `lexicalCompareFS` instUnitFS u2 instance Binary InstantiatedUnit where put_ bh indef = do
compiler/GHC/Utils/Binary.hs view
@@ -1,3 +1,4 @@+ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-}@@ -72,8 +73,6 @@ putDictionary, getDictionary, putFS, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} GHC.Types.Name (Name)@@ -83,6 +82,7 @@ import GHC.Data.FastMutInt import GHC.Utils.Fingerprint import GHC.Types.SrcLoc+import qualified GHC.Data.Strict as Strict import Control.DeepSeq import Foreign hiding (shiftL, shiftR)@@ -704,6 +704,15 @@ case h of 0 -> return Nothing _ -> do x <- get bh; return (Just x)++instance Binary a => Binary (Strict.Maybe a) where+ put_ bh Strict.Nothing = putByte bh 0+ put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a+ get bh =+ do h <- getWord8 bh+ case h of+ 0 -> return Strict.Nothing+ _ -> do x <- get bh; return (Strict.Just x) instance (Binary a, Binary b) => Binary (Either a b) where put_ bh (Left a) = do putByte bh 0; put_ bh a
compiler/GHC/Utils/Binary/Typeable.hs view
@@ -15,8 +15,6 @@ ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Utils.Binary
+ compiler/GHC/Utils/Constants.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}++module GHC.Utils.Constants+ ( debugIsOn+ , ghciSupported+ , isWindowsHost+ , isDarwinHost+ )+where++import GHC.Prelude++{-++These booleans are global constants, set by CPP flags. They allow us to+recompile a single module (this one) to change whether or not debug output+appears. They sometimes let us avoid even running CPP elsewhere.++It's important that the flags are literal constants (True/False). Then,+with -0, tests of the flags in other modules will simplify to the correct+branch of the conditional, thereby dropping debug code altogether when+the flags are off.+-}++ghciSupported :: Bool+#if defined(HAVE_INTERNAL_INTERPRETER)+ghciSupported = True+#else+ghciSupported = False+#endif++debugIsOn :: Bool+#if defined(DEBUG)+debugIsOn = True+#else+debugIsOn = False+#endif++isWindowsHost :: Bool+#if defined(mingw32_HOST_OS)+isWindowsHost = True+#else+isWindowsHost = False+#endif++isDarwinHost :: Bool+#if defined(darwin_HOST_OS)+isDarwinHost = True+#else+isDarwinHost = False+#endif
compiler/GHC/Utils/Error.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -40,6 +39,7 @@ mkPlainDiagnostic, mkDecoratedError, mkDecoratedDiagnostic,+ noHints, -- * Utilities doIfSet, doIfSet_dyn,@@ -61,8 +61,6 @@ sortMsgBag ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Driver.Session@@ -72,6 +70,7 @@ import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic+import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc@@ -151,7 +150,7 @@ -> e -> MsgEnvelope e mkErrorMsgEnvelope locn unqual msg =- mk_msg_envelope SevError locn unqual msg+ assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg -- | Variant that doesn't care about qualified/unqualified names. mkPlainMsgEnvelope :: Diagnostic e
compiler/GHC/Utils/Exception.hs view
@@ -11,7 +11,7 @@ import GHC.Prelude import GHC.IO (catchException)-import Control.Exception as CE+import Control.Exception as CE hiding (assert) import Control.Monad.IO.Class import Control.Monad.Catch
compiler/GHC/Utils/Fingerprint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- ----------------------------------------------------------------------------@@ -21,8 +21,6 @@ fingerprintString, getFileHash ) where--#include "GhclibHsVersions.h" import GHC.Prelude
compiler/GHC/Utils/GlobalVars.hs view
@@ -3,6 +3,9 @@ {-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly +-- | Do not use global variables!+--+-- Global variables are a hack. Do not use them if you can help it. module GHC.Utils.GlobalVars ( v_unsafeHasPprDebug , v_unsafeHasNoDebugOutput@@ -19,7 +22,8 @@ ) where -#include "GhclibHsVersions.h"+-- For GHC_STAGE+#include "ghcplatform.h" import GHC.Prelude @@ -29,11 +33,32 @@ import Data.IORef import Foreign (Ptr) +#define GLOBAL_VAR(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = global (value); ------------------------------------------------------------------------------ Do not use global variables!------ Global variables are a hack. Do not use them if you can help it.+#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = globalM (value);+++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = sharedGlobal (value) (accessor); \+foreign import ccall unsafe saccessor \+ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = sharedGlobalM (value) (accessor); \+foreign import ccall unsafe saccessor \+ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++ #if GHC_STAGE < 2
compiler/GHC/Utils/IO/Unsafe.hs view
@@ -2,14 +2,12 @@ (c) The University of Glasgow, 2000-2006 -} -{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-} module GHC.Utils.IO.Unsafe ( inlinePerformIO, ) where--#include "GhclibHsVersions.h" import GHC.Prelude ()
compiler/GHC/Utils/Logger.hs view
@@ -44,6 +44,7 @@ import GHC.Prelude import GHC.Driver.Session+import GHC.Driver.Flags import GHC.Driver.Ppr import GHC.Types.Error import GHC.Types.SrcLoc@@ -59,6 +60,7 @@ import qualified Data.Set as Set import Data.Set (Set) import Data.List (intercalate, stripPrefix)+import qualified Data.List.NonEmpty as NE import Data.Time import System.IO import Control.Monad@@ -247,21 +249,21 @@ flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore" flagMsg SevError WarningWithoutFlag = Just "-Werror" flagMsg SevError (WarningWithFlag wflag) = do- spec <- flagSpecOf wflag+ let name = NE.head (warnFlagNames wflag) return $- "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++- ", -Werror=" ++ flagSpecName spec+ "-W" ++ name ++ warnFlagGrp wflag +++ ", -Werror=" ++ name flagMsg SevError ErrorWithoutFlag = Nothing flagMsg SevWarning WarningWithoutFlag = Nothing flagMsg SevWarning (WarningWithFlag wflag) = do- spec <- flagSpecOf wflag- return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)+ let name = NE.head (warnFlagNames wflag)+ return ("-W" ++ name ++ warnFlagGrp wflag) flagMsg SevWarning ErrorWithoutFlag = panic "SevWarning with ErrorWithoutFlag" warnFlagGrp flag | gopt Opt_ShowWarnGroups dflags =- case smallestGroups flag of+ case smallestWarningGroups flag of [] -> "" groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" | otherwise = ""
compiler/GHC/Utils/Misc.hs view
@@ -13,10 +13,6 @@ -- | Highly random utility functions -- module GHC.Utils.Misc (- -- * Flags dependent on the compiler build- ghciSupported, debugIsOn,- isWindowsHost, isDarwinHost,- -- * Miscellaneous higher-order functions applyWhen, nTimes, @@ -131,12 +127,11 @@ overrideWith, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import GHC.Utils.Exception import GHC.Utils.Panic.Plain+import GHC.Utils.Constants import Data.Data import qualified Data.List as List@@ -170,51 +165,7 @@ infixr 9 `thenCmp` -{--************************************************************************-* *-\subsection{Is DEBUG on, are we on Windows, etc?}-* *-************************************************************************ -These booleans are global constants, set by CPP flags. They allow us to-recompile a single module (this one) to change whether or not debug output-appears. They sometimes let us avoid even running CPP elsewhere.--It's important that the flags are literal constants (True/False). Then,-with -0, tests of the flags in other modules will simplify to the correct-branch of the conditional, thereby dropping debug code altogether when-the flags are off.--}--ghciSupported :: Bool-#if defined(HAVE_INTERNAL_INTERPRETER)-ghciSupported = True-#else-ghciSupported = False-#endif--debugIsOn :: Bool-#if defined(DEBUG)-debugIsOn = True-#else-debugIsOn = False-#endif--isWindowsHost :: Bool-#if defined(mingw32_HOST_OS)-isWindowsHost = True-#else-isWindowsHost = False-#endif--isDarwinHost :: Bool-#if defined(darwin_HOST_OS)-isDarwinHost = True-#else-isDarwinHost = False-#endif- {- ************************************************************************ * *@@ -586,7 +537,7 @@ elem100 :: Eq a => Int -> a -> [a] -> Bool elem100 _ _ [] = False elem100 i x (y:ys)- | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))+ | i > 100 = warnPprTrace True (text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) | otherwise = x == y || elem100 (i + 1) x ys isn'tIn msg x ys@@ -595,7 +546,7 @@ notElem100 :: Eq a => Int -> a -> [a] -> Bool notElem100 _ _ [] = True notElem100 i x (y:ys)- | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))+ | i > 100 = warnPprTrace True (text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) | otherwise = x /= y && notElem100 (i + 1) x ys # endif /* DEBUG */ @@ -679,7 +630,7 @@ -} minWith :: Ord b => (a -> b) -> [a] -> a-minWith get_key xs = ASSERT( not (null xs) )+minWith get_key xs = assert (not (null xs) ) head (sortWith get_key xs) nubSort :: Ord a => [a] -> [a]
compiler/GHC/Utils/Panic.hs view
@@ -4,7 +4,8 @@ -} -{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables, LambdaCase #-} -- | Defines basic functions for printing error messages. --@@ -24,6 +25,9 @@ , pprPanic , assertPanic , assertPprPanic+ , assertPpr+ , assertPprM+ , massertPpr , sorry , trace , panicDoc@@ -48,6 +52,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic.Plain+import GHC.Utils.Constants import GHC.Utils.Exception as Exception @@ -295,6 +300,21 @@ -- | Panic with an assertion failure, recording the given file and -- line number. Should typically be accessed with the ASSERT family of macros-assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a-assertPprPanic _file _line msg- = pprPanic "ASSERT failed!" msg+assertPprPanic :: HasCallStack => SDoc -> a+assertPprPanic msg = withFrozenCallStack (pprPanic "ASSERT failed!" msg)+++assertPpr :: HasCallStack => Bool -> SDoc -> a -> a+{-# INLINE assertPpr #-}+assertPpr cond msg a =+ if debugIsOn && not cond+ then withFrozenCallStack (assertPprPanic msg)+ else a++massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m ()+{-# INLINE massertPpr #-}+massertPpr cond msg = withFrozenCallStack (assertPpr cond msg (pure ()))++assertPprM :: (HasCallStack, Monad m) => m Bool -> SDoc -> m ()+{-# INLINE assertPprM #-}+assertPprM mcond msg = withFrozenCallStack (mcond >>= \cond -> massertPpr cond msg)
compiler/GHC/Utils/Panic/Plain.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, LambdaCase #-} -- | Defines a simple exception type and utilities to throw it. The -- 'PlainGhcException' type is a subset of the 'GHC.Utils.Panic.GhcException'@@ -21,13 +21,13 @@ , panic, sorry, pgmError , cmdLineError, cmdLineErrorIO , assertPanic+ , assert, assertM, massert , progName ) where -#include "GhclibHsVersions.h"- import GHC.Settings.Config+import GHC.Utils.Constants import GHC.Utils.Exception as Exception import GHC.Stack import GHC.Prelude@@ -97,13 +97,13 @@ sorryMsg :: ShowS -> ShowS sorryMsg s = showString "sorry! (unimplemented feature or known bug)\n"- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")+ . showString (" GHC version " ++ cProjectVersion ++ ":\n\t") . s . showString "\n" panicMsg :: ShowS -> ShowS panicMsg s = showString "panic! (the 'impossible' happened)\n"- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")+ . showString (" GHC version " ++ cProjectVersion ++ ":\n\t") . s . showString "\n\n" . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" @@ -136,3 +136,27 @@ assertPanic file line = Exception.throw (Exception.AssertionFailed ("ASSERT failed! file " ++ file ++ ", line " ++ show line))+++assertPanic' :: HasCallStack => a+assertPanic' =+ let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack)+ in+ Exception.throw (Exception.AssertionFailed+ ("ASSERT failed!\n"+ ++ withFrozenCallStack doc))++assert :: HasCallStack => Bool -> a -> a+{-# INLINE assert #-}+assert cond a =+ if debugIsOn && not cond+ then withFrozenCallStack assertPanic'+ else a++massert :: (HasCallStack, Applicative m) => Bool -> m ()+{-# INLINE massert #-}+massert cond = withFrozenCallStack (assert cond (pure ()))++assertM :: (HasCallStack, Monad m) => m Bool -> m ()+{-# INLINE assertM #-}+assertM mcond = withFrozenCallStack (mcond >>= massert)
− compiler/GhclibHsVersions.h
@@ -1,56 +0,0 @@-#pragma once---- For GHC_STAGE-#include "ghcplatform.h"--#if 0--IMPORTANT! If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--#define GLOBAL_VAR(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = GHC.Utils.GlobalVars.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = GHC.Utils.GlobalVars.globalM (value);---#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = GHC.Utils.GlobalVars.sharedGlobal (value) (accessor);\-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = GHC.Utils.GlobalVars.sharedGlobalM (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples: Assuming flagSet :: String -> m Bool------ do { c <- getChar; MASSERT( isUpper c ); ... }--- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }--- do { str <- getStr; ASSERTM( flagSet str ); .. }--- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. }--- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e) ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e) do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () }
compiler/Language/Haskell/Syntax/Binds.hs view
@@ -33,6 +33,7 @@ import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type+import GHC.Types.Name.Reader(RdrName) import GHC.Tc.Types.Evidence import GHC.Core.Type import GHC.Types.Basic@@ -931,7 +932,7 @@ making the distinction between the two names clear. -}-instance Outputable (RecordPatSynField a) where+instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
compiler/Language/Haskell/Syntax/Decls.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}
compiler/Language/Haskell/Syntax/Expr.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -23,9 +23,6 @@ -- | Abstract Haskell syntax for expressions. module Language.Haskell.Syntax.Expr where -#include "GhclibHsVersions.h"---- friends: import GHC.Prelude import Language.Haskell.Syntax.Decls@@ -44,7 +41,6 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Tickish-import GHC.Core.ConLike import GHC.Unit.Module (ModuleName) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -101,19 +97,20 @@ The results of these new rules cannot be represented by @LHsRecField GhcPs (LHsExpr GhcPs)@ values as the type is defined today. We minimize modifying existing code by having these new rules calculate-@LHsRecProj GhcPs (Located b)@ ("record projection") values instead:+@LHsRecProj GhcPs (LHsExpr GhcPs)@ ("record projection") values+instead: @-newtype FieldLabelStrings = FieldLabelStrings [Located FieldLabelString]-type RecProj arg = HsRecField' FieldLabelStrings arg-type LHsRecProj p arg = Located (RecProj arg)+newtype FieldLabelStrings = FieldLabelStrings [XRec p (DotFieldOcc p)]+type RecProj arg = HsFieldBind FieldLabelStrings arg+type LHsRecProj p arg = XRec p (RecProj arg) @ The @fbind@ rule is then given the type @fbind :: { forall b. DisambECP b => PV (Fbind b) }@ accomodating both alternatives: @ type Fbind b = Either- (LHsRecField GhcPs (Located b))- ( LHsRecProj GhcPs (Located b))+ (LHsRecField GhcPs (LocatedA b))+ ( LHsRecProj GhcPs (LocatedA b)) @ In @data HsExpr p@, the @RecordUpd@ constuctor indicates regular@@ -128,8 +125,8 @@ @ Here, @-type RecUpdProj p = RecProj (LHsExpr p)-type LHsRecUpdProj p = Located (RecUpdProj p)+type RecUpdProj p = RecProj p (LHsExpr p)+type LHsRecUpdProj p = XRec p (RecUpdProj p) @ and @Left@ values indicating regular record update, @Right@ values updates desugared to @setField@s.@@ -141,28 +138,34 @@ -- | RecordDotSyntax field updates +type LFieldLabelStrings p = XRec p (FieldLabelStrings p)+ newtype FieldLabelStrings p =- FieldLabelStrings [Located (HsFieldLabel p)]+ FieldLabelStrings [XRec p (DotFieldOcc p)] -instance Outputable (FieldLabelStrings p) where+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where ppr (FieldLabelStrings flds) =- hcat (punctuate dot (map (ppr . unLoc) flds))+ hcat (punctuate dot (map (ppr . unXRec @p) flds)) -instance OutputableBndr (FieldLabelStrings p) where+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where pprInfixOcc = pprFieldLabelStrings pprPrefixOcc = pprFieldLabelStrings -pprFieldLabelStrings :: FieldLabelStrings p -> SDoc+instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where+ pprInfixOcc = pprInfixOcc . unLoc+ pprPrefixOcc = pprInfixOcc . unLoc++pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc pprFieldLabelStrings (FieldLabelStrings flds) =- hcat (punctuate dot (map (ppr . unLoc) flds))+ hcat (punctuate dot (map (ppr . unXRec @p) flds)) -instance Outputable (HsFieldLabel p) where- ppr (HsFieldLabel _ s) = ppr s- ppr XHsFieldLabel{} = text "XHsFieldLabel"+instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where+ ppr (DotFieldOcc _ s) = ppr s+ ppr XDotFieldOcc{} = text "XDotFieldOcc" -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates].-type RecProj p arg = HsRecField' (FieldLabelStrings p) arg+type RecProj p arg = HsFieldBind (LFieldLabelStrings p) arg -- The phantom type parameter @p@ is for symmetry with @LHsRecField p -- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process).@@ -265,6 +268,55 @@ typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) -} +{-+Note [Record selectors in the AST]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is how record selectors are expressed in GHC's AST:++Example data type+ data T = MkT { size :: Int }++Record selectors:+ | GhcPs | GhcRn | GhcTc |+----------------------------------------------------------------------------------|+size (assuming one | HsVar | HsRecSel | HsRecSel |+ 'size' in scope) | | | |+----------------------|--------------|----------------------|---------------------|+.size (assuming | HsProjection | getField @"size" | getField @"size" |+ OverloadedRecordDot) | | | |+----------------------|--------------|----------------------|---------------------|+e.size (assuming | HsGetField | getField @"size" e | getField @"size" e |+ OverloadedRecordDot) | | | |++NB 1: DuplicateRecordFields makes no difference to the first row of+this table, except that if 'size' is a field of more than one data+type, then a naked use of the record selector 'size' may well be+ambiguous. You have to use a qualified name. And there is no way to do+this if both data types are declared in the same module.++NB 2: The notation getField @"size" e is short for+HsApp (HsAppType (HsVar "getField") (HsWC (HsTyLit (HsStrTy "size")) [])) e.+We track the original parsed syntax via HsExpanded.++-}++{-+Note [Non-overloaded record field selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ data T = MkT { x,y :: Int }+ f r x = x + y r++This parses with HsVar for x, y, r on the RHS of f. Later, the renamer+recognises that y in the RHS of f is really a record selector, and+changes it to a HsRecSel. In contrast x is locally bound, shadowing+the record selector, and stays as an HsVar.++The renamer adds the Name of the record selector into the XCFieldOcc+extension field, The typechecker keeps HsRecSel as HsRecSel, and+transforms the record-selector Name to an Id.+-}+ -- | A Haskell expression. data HsExpr p = HsVar (XVar p)@@ -282,15 +334,11 @@ -- erroring expression will be written after -- solving. See Note [Holes] in GHC.Tc.Types.Constraint. - | HsConLikeOut (XConLikeOut p)- ConLike -- ^ After typechecker only; must be different- -- HsVar for pretty printing - | HsRecFld (XRecFld p)- (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector- -- The parser produces HsVars- -- The renamer renames record-field selectors to HsRecFld- -- The typechecker preserves HsRecFld+ | HsRecSel (XRecSel p)+ (FieldOcc p) -- ^ Variable pointing to record selector+ -- See Note [Non-overloaded record field selectors] and+ -- Note [Record selectors in the AST] | HsOverLabel (XOverLabel p) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)@@ -335,7 +383,7 @@ -- NB Bracketed ops such as (+) come out as Vars. -- NB Sadly, we need an expr for the operator in an OpApp/Section since- -- the renamer may turn a HsVar into HsRecFld or HsUnboundVar+ -- the renamer may turn a HsVar into HsRecSel or HsUnboundVar | OpApp (XOpApp p) (LHsExpr p) -- left operand@@ -357,7 +405,9 @@ -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | HsPar (XPar p)+ !(LHsToken "(" p) (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn]+ !(LHsToken ")" p) | SectionL (XSectionL p) (LHsExpr p) -- operand; see Note [Sections in HsSyn]@@ -485,27 +535,29 @@ -- | Record field selection e.g @z.x@. -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot'- --- -- This case only arises when the OverloadedRecordDot langauge- -- extension is enabled. + -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++ -- This case only arises when the OverloadedRecordDot langauge+ -- extension is enabled. See Note [Record Selectors in the AST]. | HsGetField { gf_ext :: XGetField p , gf_expr :: LHsExpr p- , gf_field :: Located (HsFieldLabel p)+ , gf_field :: XRec p (DotFieldOcc p) } -- | Record field selector. e.g. @(.x)@ or @(.x.y)@ --+ -- This case only arises when the OverloadedRecordDot langauge+ -- extensions is enabled. See Note [Record Selectors in the AST].+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP' -- 'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'- --- -- This case only arises when the OverloadedRecordDot langauge- -- extensions is enabled. + -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | HsProjection { proj_ext :: XProjection p- , proj_flds :: [Located (HsFieldLabel p)]+ , proj_flds :: [XRec p (DotFieldOcc p)] } -- | Expression with an explicit type signature. @e :: type@@@ -620,12 +672,12 @@ -- --------------------------------------------------------------------- -data HsFieldLabel p- = HsFieldLabel- { hflExt :: XCHsFieldLabel p- , hflLabel :: Located FieldLabelString+data DotFieldOcc p+ = DotFieldOcc+ { dfoExt :: XCDotFieldOcc p+ , dfoLabel :: XRec p FieldLabelString }- | XHsFieldLabel !(XXHsFieldLabel p)+ | XDotFieldOcc !(XXDotFieldOcc p) -- --------------------------------------------------------------------- @@ -881,7 +933,9 @@ -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | HsCmdPar (XCmdPar id)+ !(LHsToken "(" id) (LHsCmd id) -- parenthesised command+ !(LHsToken ")" id) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, -- 'GHC.Parser.Annotation.AnnClose' @')'@
compiler/Language/Haskell/Syntax/Extension.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -22,6 +23,7 @@ import GHC.Prelude +import GHC.TypeLits (Symbol, KnownSymbol) import Data.Data hiding ( Fixity ) import Data.Kind (Type) import GHC.Utils.Outputable@@ -385,8 +387,7 @@ type family XVar x type family XUnboundVar x-type family XConLikeOut x-type family XRecFld x+type family XRecSel x type family XOverLabel x type family XIPVar x type family XOverLitE x@@ -426,9 +427,9 @@ type family XXExpr x -- ---------------------------------------- FieldLabel type families-type family XCHsFieldLabel x-type family XXHsFieldLabel x+-- DotFieldOcc type families+type family XCDotFieldOcc x+type family XXDotFieldOcc x -- ------------------------------------- -- HsPragE type families@@ -563,25 +564,25 @@ -- ===================================================================== -- Type families for the HsPat extension points -type family XWildPat x-type family XVarPat x-type family XLazyPat x-type family XAsPat x-type family XParPat x-type family XBangPat x-type family XListPat x-type family XTuplePat x-type family XSumPat x-type family XConPat x-type family XViewPat x-type family XSplicePat x-type family XLitPat x-type family XNPat x-type family XNPlusKPat x-type family XSigPat x-type family XCoPat x-type family XXPat x-type family XHsRecField x+type family XWildPat x+type family XVarPat x+type family XLazyPat x+type family XAsPat x+type family XParPat x+type family XBangPat x+type family XListPat x+type family XTuplePat x+type family XSumPat x+type family XConPat x+type family XViewPat x+type family XSplicePat x+type family XLitPat x+type family XNPat x+type family XNPlusKPat x+type family XSigPat x+type family XCoPat x+type family XXPat x+type family XHsFieldBind x -- ===================================================================== -- Type families for the HsTypes type families@@ -694,3 +695,14 @@ -- ===================================================================== -- End of Type family definitions -- =====================================================================++++-- =====================================================================+-- Token information++type LHsToken tok p = XRec p (HsToken tok)++data HsToken (tok :: Symbol) = HsTok++deriving instance KnownSymbol tok => Data (HsToken tok)
compiler/Language/Haskell/Syntax/Lit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -18,8 +18,6 @@ -- | Source-language literals module Language.Haskell.Syntax.Lit where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr )@@ -164,7 +162,7 @@ compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 compare (HsFractional _) (HsIntegral _) = GT compare (HsFractional _) (HsIsString _ _) = LT- compare (HsIsString _ s1) (HsIsString _ s2) = s1 `uniqCompareFS` s2+ compare (HsIsString _ s1) (HsIsString _ s2) = s1 `lexicalCompareFS` s2 compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT
compiler/Language/Haskell/Syntax/Pat.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,6 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -22,7 +23,7 @@ ConLikeP, HsConPatDetails, hsConPatArgs,- HsRecFields(..), HsRecField'(..), LHsRecField',+ HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, hsRecFields, hsRecFieldSel, hsRecFieldsArgs,@@ -74,7 +75,9 @@ -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | ParPat (XParPat p)+ !(LHsToken "(" p) (LPat p) -- ^ Parenthesised pattern+ !(LHsToken ")" p) -- See Note [Parens in HsSyn] in GHC.Hs.Expr -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, -- 'GHC.Parser.Annotation.AnnClose' @')'@@@ -225,7 +228,7 @@ hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps-hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unXRec @p) (rec_flds fs)+hsConPatArgs (RecCon fs) = map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- | Haskell Record Fields@@ -256,7 +259,7 @@ -- and the remainder being 'filled in' implicitly -- | Located Haskell Record Field-type LHsRecField' p id arg = XRec p (HsRecField' id arg)+type LHsFieldBind p id arg = XRec p (HsFieldBind id arg) -- | Located Haskell Record Field type LHsRecField p arg = XRec p (HsRecField p arg)@@ -265,21 +268,21 @@ type LHsRecUpdField p = XRec p (HsRecUpdField p) -- | Haskell Record Field-type HsRecField p arg = HsRecField' (FieldOcc p) arg+type HsRecField p arg = HsFieldBind (LFieldOcc p) arg -- | Haskell Record Update Field-type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p)+type HsRecUpdField p = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr p) --- | Haskell Record Field+-- | Haskell Field Binding -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual', -- -- For details on above see note [exact print annotations] in GHC.Parser.Annotation-data HsRecField' id arg = HsRecField {- hsRecFieldAnn :: XHsRecField id,- hsRecFieldLbl :: Located id,- hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning- hsRecPun :: Bool -- ^ Note [Punning]+data HsFieldBind lhs rhs = HsFieldBind {+ hfbAnn :: XHsFieldBind lhs,+ hfbLHS :: lhs,+ hfbRHS :: rhs, -- ^ Filled in by renamer when punning+ hfbPun :: Bool -- ^ Note [Punning] } deriving (Functor, Foldable, Traversable) @@ -324,28 +327,27 @@ -- -- The parsed HsRecUpdField corresponding to the record update will have: ----- hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName+-- hfbLHS = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName -- -- After the renamer, this will become: ----- hsRecFieldLbl = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name+-- hfbLHS = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name -- -- (note that the Unambiguous constructor is not type-correct here). -- The typechecker will determine the particular selector: ----- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id+-- hfbLHS = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id -- -- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. -hsRecFields :: forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]-hsRecFields rbinds = map (unLoc . hsRecFieldSel . unXRec @p) (rec_flds rbinds)+hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p]+hsRecFields rbinds = map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) --- Probably won't typecheck at once, things have changed :/ hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]-hsRecFieldsArgs rbinds = map (hsRecFieldArg . unXRec @p) (rec_flds rbinds)+hsRecFieldsArgs rbinds = map (hfbRHS . unXRec @p) (rec_flds rbinds) -hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)-hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl+hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p+hsRecFieldSel = foExt . unXRec @p . hfbLHS {-@@ -366,7 +368,7 @@ dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) instance (Outputable p, OutputableBndr p, Outputable arg)- => Outputable (HsRecField' p arg) where- ppr (HsRecField { hsRecFieldLbl = L _ f, hsRecFieldArg = arg,- hsRecPun = pun })+ => Outputable (HsFieldBind p arg) where+ ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg,+ hfbPun = pun }) = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)
compiler/Language/Haskell/Syntax/Type.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-@@ -46,7 +47,7 @@ HsConDetails(..), noTypeArgs, FieldOcc(..), LFieldOcc,- AmbiguousFieldOcc(..),+ AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mapHsOuterImplicit, hsQTvExplicit,@@ -54,8 +55,6 @@ hsPatSigType, ) where -#include "GhclibHsVersions.h"- import GHC.Prelude import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsSplice )@@ -735,7 +734,7 @@ | HsQualTy -- See Note [HsType binders] { hst_xqual :: XQualTy pass- , hst_ctxt :: Maybe (LHsContext pass) -- Context C => blah+ , hst_ctxt :: LHsContext pass -- Context C => blah , hst_body :: LHsType pass } | HsTyVar (XTyVar pass)@@ -1295,34 +1294,40 @@ -- | Field Occurrence ----- Represents an *occurrence* of an unambiguous field. This may or may not be a+-- Represents an *occurrence* of a field. This may or may not be a -- binding occurrence (e.g. this type is used in 'ConDeclField' and--- 'RecordPatSynField' which bind their fields, but also in 'HsRecField' for--- record construction and patterns, which do not).+-- 'RecordPatSynField' which bind their fields, but also in+-- 'HsRecField' for record construction and patterns, which do not). ----- We store both the 'RdrName' the user originally wrote, and after the renamer,--- the selector function.-data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass- , rdrNameFieldOcc :: LocatedN RdrName- -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr"- }-- | XFieldOcc- !(XXFieldOcc pass)--deriving instance (Eq (XCFieldOcc pass), Eq (XXFieldOcc pass)) => Eq (FieldOcc pass)+-- We store both the 'RdrName' the user originally wrote, and after+-- the renamer we use the extension field to store the selector+-- function.+data FieldOcc pass+ = FieldOcc {+ foExt :: XCFieldOcc pass+ , foLabel :: XRec pass RdrName -- See Note [Located RdrNames] in Language.Haskell.Syntax.Expr+ }+ | XFieldOcc !(XXFieldOcc pass)+deriving instance (+ Eq (XRec pass RdrName)+ , Eq (XCFieldOcc pass)+ , Eq (XXFieldOcc pass)+ ) => Eq (FieldOcc pass) -instance Outputable (FieldOcc pass) where- ppr = ppr . rdrNameFieldOcc+instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where+ ppr = ppr . foLabel -instance OutputableBndr (FieldOcc pass) where- pprInfixOcc = pprInfixOcc . unLoc . rdrNameFieldOcc- pprPrefixOcc = pprPrefixOcc . unLoc . rdrNameFieldOcc+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where+ pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel+ pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel -instance OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where+instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where pprInfixOcc = pprInfixOcc . unLoc pprPrefixOcc = pprPrefixOcc . unLoc +-- | Located Ambiguous Field Occurence+type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass)+ -- | Ambiguous Field Occurrence -- -- Represents an *occurrence* of a field that is potentially@@ -1332,9 +1337,8 @@ -- (for unambiguous occurrences) or the typechecker (for ambiguous -- occurrences). ----- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat" and--- Note [Disambiguating record fields] in "GHC.Tc.Gen.Head".--- See Note [Located RdrNames] in "GHC.Hs.Expr"+-- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat".+-- See Note [Located RdrNames] in "GHC.Hs.Expr". data AmbiguousFieldOcc pass = Unambiguous (XUnambiguous pass) (LocatedN RdrName) | Ambiguous (XAmbiguous pass) (LocatedN RdrName)
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 0.20210501+version: 0.20210601 license: BSD3 license-file: LICENSE category: Development@@ -45,7 +45,6 @@ includes/MachDeps.h includes/stg/MachRegs.h includes/CodeGen.Platform.hs- compiler/GhclibHsVersions.h compiler/Unique.h source-repository head type: git@@ -219,6 +218,7 @@ GHC.Data.ShortText GHC.Data.SizedSeq GHC.Data.Stream+ GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap GHC.Driver.Backend@@ -281,7 +281,6 @@ GHC.Parser GHC.Parser.Annotation GHC.Parser.CharClass- GHC.Parser.Errors GHC.Parser.Errors.Ppr GHC.Parser.Errors.Types GHC.Parser.Header@@ -342,6 +341,7 @@ GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs+ GHC.Types.Hint GHC.Types.HpcInfo GHC.Types.IPE GHC.Types.Id@@ -406,6 +406,7 @@ GHC.Utils.Binary.Typeable GHC.Utils.BufHandle GHC.Utils.CliOption+ GHC.Utils.Constants GHC.Utils.Encoding GHC.Utils.Error GHC.Utils.Exception
ghc-lib/stage0/compiler/build/GHC/Parser.hs view
@@ -56,14 +56,17 @@ import GHC.Data.Maybe ( orElse ) import GHC.Utils.Outputable+import GHC.Utils.Error import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) import GHC.Utils.Panic import GHC.Prelude+import qualified GHC.Data.Strict as Strict import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString) import GHC.Types.SrcLoc import GHC.Types.Basic+import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.SourceFile@@ -77,7 +80,8 @@ import GHC.Parser.PostProcess.Haddock import GHC.Parser.Lexer import GHC.Parser.Annotation-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr () import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon,@@ -1486,8 +1490,8 @@ happyOut209 :: (HappyAbsSyn ) -> HappyWrap209 happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut209 #-}-newtype HappyWrap210 = HappyWrap210 (([Located Token],Bool))-happyIn210 :: (([Located Token],Bool)) -> (HappyAbsSyn )+newtype HappyWrap210 = HappyWrap210 ((Maybe EpaLocation,Bool))+happyIn210 :: ((Maybe EpaLocation,Bool)) -> (HappyAbsSyn ) happyIn210 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap210 x) {-# INLINE happyIn210 #-} happyOut210 :: (HappyAbsSyn ) -> HappyWrap210@@ -1528,8 +1532,8 @@ happyOut215 :: (HappyAbsSyn ) -> HappyWrap215 happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut215 #-}-newtype HappyWrap216 = HappyWrap216 (Located [Located (HsFieldLabel GhcPs)])-happyIn216 :: (Located [Located (HsFieldLabel GhcPs)]) -> (HappyAbsSyn )+newtype HappyWrap216 = HappyWrap216 (Located [Located (DotFieldOcc GhcPs)])+happyIn216 :: (Located [Located (DotFieldOcc GhcPs)]) -> (HappyAbsSyn ) happyIn216 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap216 x) {-# INLINE happyIn216 #-} happyOut216 :: (HappyAbsSyn ) -> HappyWrap216@@ -1766,8 +1770,8 @@ happyOut249 :: (HappyAbsSyn ) -> HappyWrap249 happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut249 #-}-newtype HappyWrap250 = HappyWrap250 (forall b. DisambECP b => PV (Located ([TrailingAnn],[LStmt GhcPs (LocatedA b)])))-happyIn250 :: (forall b. DisambECP b => PV (Located ([TrailingAnn],[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn )+newtype HappyWrap250 = HappyWrap250 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LStmt GhcPs (LocatedA b)])))+happyIn250 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) happyIn250 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap250 x) {-# INLINE happyIn250 #-} happyOut250 :: (HappyAbsSyn ) -> HappyWrap250@@ -1822,8 +1826,8 @@ happyOut257 :: (HappyAbsSyn ) -> HappyWrap257 happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut257 #-}-newtype HappyWrap258 = HappyWrap258 (Located [Located (HsFieldLabel GhcPs)])-happyIn258 :: (Located [Located (HsFieldLabel GhcPs)]) -> (HappyAbsSyn )+newtype HappyWrap258 = HappyWrap258 (Located [Located (DotFieldOcc GhcPs)])+happyIn258 :: (Located [Located (DotFieldOcc GhcPs)]) -> (HappyAbsSyn ) happyIn258 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap258 x) {-# INLINE happyIn258 #-} happyOut258 :: (HappyAbsSyn ) -> HappyWrap258@@ -3407,7 +3411,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( if (getVARSYM happy_var_1 == fsLit "-") then return [mj AnnMinus happy_var_1]- else do { addError $ PsError PsErrExpectedHyphen [] (getLoc happy_var_1)+ else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ PsErrExpectedHyphen ; return [] })}) ) (\r -> happyReturn (happyIn26 r)) @@ -4309,7 +4313,8 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( do { let { pkgFS = getSTRING happy_var_1 } ; unless (looksLikePackageName (unpackFS pkgFS)) $- addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc happy_var_1)+ addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $+ (PsErrInvalidPackageName pkgFS) ; return (Just (glAA happy_var_1), Just (StringLiteral (getSTRINGs happy_var_1) pkgFS Nothing)) })}) ) (\r -> happyReturn (happyIn65 r)) @@ -4703,7 +4708,7 @@ case happyOut102 happy_x_4 of { (HappyWrap102 happy_var_4) -> case happyOut88 happy_x_5 of { (HappyWrap88 happy_var_5) -> case happyOut91 happy_x_6 of { (HappyWrap91 happy_var_6) -> - ( mkFamDecl (comb4 happy_var_1 (reLoc happy_var_3) happy_var_4 happy_var_5) (snd $ unLoc happy_var_6) TopLevel happy_var_3+ ( mkFamDecl (comb5 happy_var_1 (reLoc happy_var_3) happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_6) TopLevel happy_var_3 (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4) ++ (fst $ unLoc happy_var_5) ++ (fst $ unLoc happy_var_6)))}}}}}})@@ -6169,9 +6174,7 @@ = happyThen ((case happyOut128 happy_x_1 of { (HappyWrap128 happy_var_1) -> ( do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc happy_var_1) ; cs <- getCommentsFor (gl happy_var_1)- ; if (isNilOL (unLoc $ snd $ unLoc happy_var_1))- then return (sL1 happy_var_1 $ HsValBinds (EpAnn (glR happy_var_1) (AnnList (Just $ glR happy_var_1) Nothing Nothing [] []) cs) val_binds)- else return (sL1 happy_var_1 $ HsValBinds (EpAnn (glR happy_var_1) (fst $ unLoc happy_var_1) cs) val_binds) })})+ ; return (sL1 happy_var_1 $ HsValBinds (EpAnn (glR happy_var_1) (fst $ unLoc happy_var_1) cs) val_binds)})}) ) (\r -> happyReturn (happyIn129 r)) happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -6313,7 +6316,8 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( if (getVARSYM happy_var_1 == fsLit "~") then return [mj AnnTilde happy_var_1]- else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc happy_var_1)+ else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $+ PsErrInvalidRuleActivationMarker ; return [] })}) ) (\r -> happyReturn (happyIn134 r)) @@ -7000,7 +7004,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> ( acsA (\cs -> (sLL (reLoc happy_var_1) (reLoc happy_var_3) $- HsQualTy { hst_ctxt = Just (addTrailingDarrowC happy_var_1 happy_var_2 cs)+ HsQualTy { hst_ctxt = addTrailingDarrowC happy_var_1 happy_var_2 cs , hst_xqual = NoExtField , hst_body = happy_var_3 })))}}}) ) (\r -> happyReturn (happyIn159 r))@@ -7082,7 +7086,7 @@ case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> ( hintLinear (getLoc happy_var_2) >> acsA (\cs -> sLL (reLoc happy_var_1) (reLoc happy_var_3)- $ HsFunTy (EpAnn (glAR happy_var_1) (mau happy_var_2) cs) (HsLinearArrow UnicodeSyntax Nothing) happy_var_1 happy_var_3))}}})+ $ HsFunTy (EpAnn (glAR happy_var_1) (mlu happy_var_2) cs) (HsLinearArrow UnicodeSyntax Nothing) happy_var_1 happy_var_3))}}}) ) (\r -> happyReturn (happyIn161 r)) happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -7622,7 +7626,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut296 happy_x_2 of { (HappyWrap296 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 (UserTyVar (EpAnn (glR happy_var_1) [mop happy_var_1, mcp happy_var_3] cs) InferredSpec happy_var_2)))}}})+ ( acsA (\cs -> sLL happy_var_1 happy_var_3 (UserTyVar (EpAnn (glR happy_var_1) [moc happy_var_1, mcc happy_var_3] cs) InferredSpec happy_var_2)))}}}) ) (\r -> happyReturn (happyIn175 r)) happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -7638,7 +7642,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut181 happy_x_4 of { (HappyWrap181 happy_var_4) -> case happyOutTok happy_x_5 of { happy_var_5 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_5 (KindedTyVar (EpAnn (glR happy_var_1) [mop happy_var_1,mu AnnDcolon happy_var_3 ,mcp happy_var_5] cs) InferredSpec happy_var_2 happy_var_4)))}}}}})+ ( acsA (\cs -> sLL happy_var_1 happy_var_5 (KindedTyVar (EpAnn (glR happy_var_1) [moc happy_var_1,mu AnnDcolon happy_var_3 ,mcc happy_var_5] cs) InferredSpec happy_var_2 happy_var_4)))}}}}}) ) (\r -> happyReturn (happyIn175 r)) happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -8598,13 +8602,13 @@ happyReduction_503 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn210- (([happy_var_1],True)+ ((msemim happy_var_1,True) )} happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_504 = happySpecReduce_0 194# happyReduction_504 happyReduction_504 = happyIn210- (([],False)+ ((Nothing,False) ) happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -8816,10 +8820,12 @@ unECP happy_var_5 >>= \ happy_var_5 -> unECP happy_var_8 >>= \ happy_var_8 -> mkHsIfPV (comb2A happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8- (mj AnnIf happy_var_1:mj AnnThen happy_var_4- :mj AnnElse happy_var_7- :(concatMap (\l -> mz AnnSemi l) (fst happy_var_3))- ++(concatMap (\l -> mz AnnSemi l) (fst happy_var_6))))}}}}}}}})+ (AnnsIf+ { aiIf = glAA happy_var_1+ , aiThen = glAA happy_var_4+ , aiElse = glAA happy_var_7+ , aiThenSemi = fst happy_var_3+ , aiElseSemi = fst happy_var_6}))}}}}}}}}) ) (\r -> happyReturn (happyIn213 r)) happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -8942,7 +8948,7 @@ case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> fmap ecpFromExp $ acsa (\cs ->- let fl = sLL happy_var_2 happy_var_3 (HsFieldLabel ((EpAnn (glR happy_var_2) (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments)) happy_var_3) in+ let fl = sLL happy_var_2 happy_var_3 (DotFieldOcc ((EpAnn (glR happy_var_2) (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments)) happy_var_3) in mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc happy_var_1) happy_var_3) happy_var_1 fl (EpAnn (glAR happy_var_1) NoEpAnns cs)))}}}) ) (\r -> happyReturn (happyIn214 r)) @@ -9021,7 +9027,7 @@ happyIn215 (ECP $ unECP happy_var_2 >>= \ happy_var_2 ->- mkHsParPV (comb2 happy_var_1 happy_var_3) happy_var_2 (AnnParen AnnParens (glAA happy_var_1) (glAA happy_var_3))+ mkHsParPV (comb2 happy_var_1 happy_var_3) (hsTok happy_var_1) happy_var_2 (hsTok happy_var_3) )}}} happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -9270,7 +9276,7 @@ = happyThen ((case happyOut216 happy_x_1 of { (HappyWrap216 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> - ( acs (\cs -> sLL happy_var_1 happy_var_3 ((sLL happy_var_2 happy_var_3 $ HsFieldLabel (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_2)) cs) happy_var_3) : unLoc happy_var_1)))}}})+ ( acs (\cs -> sLL happy_var_1 happy_var_3 ((sLL happy_var_2 happy_var_3 $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_2)) cs) happy_var_3) : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn216 r)) happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -9280,7 +9286,7 @@ happyRest) tk = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> - ( acs (\cs -> sLL happy_var_1 happy_var_2 [sLL happy_var_1 happy_var_2 $ HsFieldLabel (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_1)) cs) happy_var_2]))}})+ ( acs (\cs -> sLL happy_var_1 happy_var_2 [sLL happy_var_1 happy_var_2 $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_1)) cs) happy_var_2]))}}) ) (\r -> happyReturn (happyIn216 r)) happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10074,8 +10080,8 @@ happyReduction_623 (happy_x_1 `HappyStk` happyRest) tk = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - ( -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess- checkPattern_hints [SuggestMissingDo]+ ( -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess+ checkPattern_details incompleteDoBlock (unECP happy_var_1))}) ) (\r -> happyReturn (happyIn246 r)) @@ -10113,7 +10119,7 @@ case happyOutTok happy_x_3 of { happy_var_3 -> happyIn249 (happy_var_2 >>= \ happy_var_2 -> amsrl- (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] (fst $ unLoc happy_var_2))+ (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fst $ unLoc happy_var_2) []) )}}} happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10124,7 +10130,7 @@ = case happyOut250 happy_x_2 of { (HappyWrap250 happy_var_2) -> happyIn249 (happy_var_2 >>= \ happy_var_2 -> amsrl- (L (gl happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) Nothing Nothing [] (fst $ unLoc happy_var_2))+ (L (gl happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) Nothing Nothing (fst $ unLoc happy_var_2) []) )} happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10139,7 +10145,7 @@ (happy_var_1 >>= \ happy_var_1 -> happy_var_3 >>= \ (happy_var_3 :: LStmt GhcPs (LocatedA b)) -> case (snd $ unLoc happy_var_1) of- [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((msemi happy_var_2) ++ (fst $ unLoc happy_var_1)+ [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((mj AnnSemi happy_var_2) : (fst $ unLoc happy_var_1) ,happy_var_3 : (snd $ unLoc happy_var_1))) (h:t) -> do { h' <- addTrailingSemiA h (gl happy_var_2)@@ -10155,7 +10161,7 @@ happyIn250 (happy_var_1 >>= \ happy_var_1 -> case (snd $ unLoc happy_var_1) of- [] -> return (sLL happy_var_1 happy_var_2 ((msemi happy_var_2) ++ (fst $ unLoc happy_var_1),snd $ unLoc happy_var_1))+ [] -> return (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_2) : (fst $ unLoc happy_var_1),snd $ unLoc happy_var_1)) (h:t) -> do { h' <- addTrailingSemiA h (gl happy_var_2) ; return $ sL1 happy_var_1 (fst $ unLoc happy_var_1,h':t) }@@ -10309,7 +10315,7 @@ case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> happyIn257 (unECP happy_var_3 >>= \ happy_var_3 ->- fmap Left $ acsA (\cs -> sLL (reLocN happy_var_1) (reLoc happy_var_3) $ HsRecField (EpAnn (glNR happy_var_1) [mj AnnEqual happy_var_2] cs) (sL1N happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False)+ fmap Left $ acsA (\cs -> sLL (reLocN happy_var_1) (reLoc happy_var_3) $ HsFieldBind (EpAnn (glNR happy_var_1) [mj AnnEqual happy_var_2] cs) (sL1N happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False) )}}} happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10318,7 +10324,7 @@ = case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> happyIn257 (placeHolderPunRhs >>= \rhs ->- fmap Left $ acsa (\cs -> sL1a (reLocN happy_var_1) $ HsRecField (EpAnn (glNR happy_var_1) [] cs) (sL1N happy_var_1 $ mkFieldOcc happy_var_1) rhs True)+ fmap Left $ acsa (\cs -> sL1a (reLocN happy_var_1) $ HsFieldBind (EpAnn (glNR happy_var_1) [] cs) (sL1N happy_var_1 $ mkFieldOcc happy_var_1) rhs True) )} happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10336,10 +10342,10 @@ case happyOut224 happy_x_5 of { (HappyWrap224 happy_var_5) -> happyIn257 (do- let top = sL1 happy_var_1 $ HsFieldLabel noAnn happy_var_1- ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc happy_var_3)+ let top = sL1 happy_var_1 $ DotFieldOcc noAnn happy_var_1+ ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) lf' = comb2 happy_var_2 (L lf ())- fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t+ fields = top : L lf' (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t final = last fields l = comb2 happy_var_1 happy_var_3 isPun = False@@ -10358,14 +10364,14 @@ case happyOut258 happy_x_3 of { (HappyWrap258 happy_var_3) -> happyIn257 (do- let top = sL1 happy_var_1 $ HsFieldLabel noAnn happy_var_1- ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc happy_var_3)+ let top = sL1 happy_var_1 $ DotFieldOcc noAnn happy_var_1+ ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) lf' = comb2 happy_var_2 (L lf ())- fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t+ fields = top : L lf' (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t final = last fields l = comb2 happy_var_1 happy_var_3 isPun = True- var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . hflLabel . unLoc $ final))+ var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final)) fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun [] )}}} @@ -10379,7 +10385,7 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> ( getCommentsFor (getLoc happy_var_3) >>= \cs ->- return (sLL happy_var_1 happy_var_3 ((sLL happy_var_2 happy_var_3 (HsFieldLabel (EpAnn (glR happy_var_2) (AnnFieldLabel $ Just $ glAA happy_var_2) cs) happy_var_3)) : unLoc happy_var_1)))}}})+ return (sLL happy_var_1 happy_var_3 ((sLL happy_var_2 happy_var_3 (DotFieldOcc (EpAnn (glR happy_var_2) (AnnFieldLabel $ Just $ glAA happy_var_2) cs) happy_var_3)) : unLoc happy_var_1)))}}}) ) (\r -> happyReturn (happyIn258 r)) happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -10388,7 +10394,7 @@ happyRest) tk = happyThen ((case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> ( getCommentsFor (getLoc happy_var_1) >>= \cs ->- return (sL1 happy_var_1 [sL1 happy_var_1 (HsFieldLabel (EpAnn (glR happy_var_1) (AnnFieldLabel Nothing) cs) happy_var_1)]))})+ return (sL1 happy_var_1 [sL1 happy_var_1 (DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel Nothing) cs) happy_var_1)]))}) ) (\r -> happyReturn (happyIn258 r)) happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -12204,7 +12210,7 @@ getSCC lt = do let s = getSTRING lt -- We probably actually want to be more restrictive than this if ' ' `elem` unpackFS s- then addFatalError $ PsError PsErrSpaceInSCC [] (getLoc lt)+ then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC else return s -- Utilities for combining source spans@@ -12345,16 +12351,16 @@ hintLinear :: MonadP m => SrcSpan -> m () hintLinear span = do linearEnabled <- getBit LinearTypesBit- unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span+ unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction -- Does this look like (a %m)? looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool looksLikeMult ty1 l_op ty2 | Unqual op_name <- unLoc l_op , occNameFS op_name == fsLit "%"- , Just ty1_pos <- getBufSpan (getLocA ty1)- , Just pct_pos <- getBufSpan (getLocA l_op)- , Just ty2_pos <- getBufSpan (getLocA ty2)+ , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)+ , Strict.Just pct_pos <- getBufSpan (getLocA l_op)+ , Strict.Just ty2_pos <- getBufSpan (getLocA ty2) , bufSpanEnd ty1_pos /= bufSpanStart pct_pos , bufSpanEnd pct_pos == bufSpanStart ty2_pos = True@@ -12364,14 +12370,15 @@ hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do mwiEnabled <- getBit MultiWayIfBit- unless mwiEnabled $ addError $ PsError PsErrMultiWayIf [] span+ unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf -- Hint about explicit-forall hintExplicitForall :: Located Token -> P () hintExplicitForall tok = do forall <- getBit ExplicitForallBit rulePrag <- getBit InRulePragBit- unless (forall || rulePrag) $ addError $ PsError (PsErrExplicitForall (isUnicode tok)) [] (getLoc tok)+ unless (forall || rulePrag) $ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+ (PsErrExplicitForall (isUnicode tok)) -- Hint about qualified-do hintQualifiedDo :: Located Token -> P ()@@ -12379,7 +12386,8 @@ qualifiedDo <- getBit QualifiedDoBit case maybeQDoDoc of Just qdoDoc | not qualifiedDo ->- addError $ PsError (PsErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)+ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+ (PsErrIllegalQualifiedDo qdoDoc) _ -> return () where maybeQDoDoc = case unLoc tok of@@ -12393,7 +12401,7 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do thQuotes <- getBit ThQuotesBit- addFatalError $ PsError (PsErrEmptyDoubleQuotes thQuotes) [] span+ addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes {- %************************************************************************@@ -12423,6 +12431,9 @@ msemi :: Located e -> [TrailingAnn] msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)] +msemim :: Located e -> Maybe EpaLocation+msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l)+ -- |Construct an AddEpAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation.@@ -12433,6 +12444,9 @@ mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (EpaSpan $ rs l) else AddRarrowAnn (EpaSpan $ rs l) +mlu :: Located Token -> TrailingAnn+mlu lt@(L l t) = AddLollyAnnU (EpaSpan $ rs l)+ -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId@@ -12485,8 +12499,9 @@ csf <- getFinalCommentsFor l meof <- getEofPos let ce = case meof of- Nothing -> EpaComments []- Just (pos, gap) -> EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]+ Strict.Nothing -> EpaComments []+ Strict.Just (pos `Strict.And` gap) ->+ EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)] return (a (cs Semi.<> csf Semi.<> ce)) acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)@@ -12595,6 +12610,9 @@ listAsAnchor :: [LocatedAn t a] -> Anchor listAsAnchor [] = spanAsAnchor noSrcSpan listAsAnchor (L l _:_) = spanAsAnchor (locA l)++hsTok :: Located Token -> LHsToken tok GhcPs+hsTok (L l _) = L (EpAnn (Anchor (realSrcSpan l) UnchangedAnchor) NoEpAnns emptyComments) HsTok -- -------------------------------------
ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs view
@@ -36,12 +36,15 @@ commentToAnnotation, HdkComment(..), warnopt,+ addPsMessage ) where import GHC.Prelude+import qualified GHC.Data.Strict as Strict -- base import Control.Monad+import Control.Applicative import Data.Char import Data.List (stripPrefix, isInfixOf, partition) import Data.Maybe@@ -60,11 +63,12 @@ import qualified Data.Map as Map -- compiler-import GHC.Data.Bag+import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.StringBuffer import GHC.Data.FastString+import GHC.Types.Error hiding ( getErrorMessages, getMessages ) import GHC.Types.Unique.FM import GHC.Data.Maybe import GHC.Data.OrdList@@ -79,7 +83,8 @@ import GHC.Parser.Annotation import GHC.Driver.Flags-import GHC.Parser.Errors+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr () #if __GLASGOW_HASKELL__ >= 603 #include "ghcconfig.h"@@ -597,7 +602,7 @@ , (0,alex_action_116) ] -{-# LINE 690 "compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 695 "compiler/GHC/Parser/Lexer.x" #-} -- -----------------------------------------------------------------------------@@ -1051,7 +1056,8 @@ Layout prev_off _ : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len- else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span)+ else addFatalError $+ mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState@@ -1436,7 +1442,10 @@ commentEnd lexToken input commentAcc finalizeComment buf span errBrace :: AlexInput -> RealSrcSpan -> P a-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) [])+errBrace (AI end _) span =+ failLocMsgP (realSrcSpanStart span)+ (psRealLoc end)+ (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF)) open_brace, close_brace :: Action open_brace span _str _len = do@@ -1491,11 +1500,11 @@ Just (ITcase, _) -> do lastTk <- getLastTk keyword <- case lastTk of- Just (L _ ITlam) -> do+ Strict.Just (L _ ITlam) -> do lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState- addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState))+ addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase return ITlcase _ -> return ITcase maybe_layout keyword@@ -1527,8 +1536,7 @@ varsym_prefix :: Action varsym_prefix = sym $ \span exts s -> let warnExtConflict errtok =- do { addWarning Opt_WarnOperatorWhitespaceExtConflict $- PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok+ do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok) ; return (ITvarsym s) } in if | s == fsLit "@" ->@@ -1554,19 +1562,19 @@ | s == fsLit "!" -> return ITbang | s == fsLit "~" -> return ITtilde | otherwise ->- do { addWarning Opt_WarnOperatorWhitespace $- PsWarnOperatorWhitespace (mkSrcSpanPs span) s- OperatorWhitespaceOccurrence_Prefix+ do { addPsMessage+ (mkSrcSpanPs span)+ (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action varsym_suffix = sym $ \span _ s ->- if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT [])+ if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT) | otherwise ->- do { addWarning Opt_WarnOperatorWhitespace $- PsWarnOperatorWhitespace (mkSrcSpanPs span) s- OperatorWhitespaceOccurrence_Suffix+ do { addPsMessage+ (mkSrcSpanPs span)+ (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing]@@ -1576,9 +1584,9 @@ | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) | s == fsLit "." -> return ITdot | otherwise ->- do { addWarning Opt_WarnOperatorWhitespace $- PsWarnOperatorWhitespace (mkSrcSpanPs span) s- OperatorWhitespaceOccurrence_TightInfix+ do { addPsMessage+ (mkSrcSpanPs span)+ (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix)) ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing]@@ -1634,7 +1642,8 @@ let src = lexemeToString buf len when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState- addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))+ let msg = PsErrNumUnderscores NumUnderscore_Integral+ addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg return $ L span $ itint (SourceText src) $! transint $ parseUnsignedInteger (offsetBytes transbuf buf) (subtract translen len) radix char_to_int@@ -1675,7 +1684,8 @@ let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState- addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))+ let msg = PsErrNumUnderscores NumUnderscore_Float+ addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg return (L span $! (f $! src)) tok_float, tok_primfloat, tok_primdouble :: String -> Token@@ -1854,7 +1864,9 @@ = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False- err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) [])+ err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span))+ (psRealLoc end)+ (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF) -- ----------------------------------------------------------------------------- -- Strings & Chars@@ -1891,7 +1903,8 @@ setInput i when (any (> '\xFF') s') $ do pState <- getPState- let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))+ let msg = PsErrPrimStringInvalidChar+ let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg addError err return (ITprimstring (SourceText s') (unsafeMkByteString s')) _other ->@@ -2154,7 +2167,7 @@ quasiquote_error start = do (AI end buf) <- getInput reportLexError start (psRealLoc end) buf- (\k -> PsError (PsErrLexer LexUnterminatedQQ k) [])+ (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k)) -- ----------------------------------------------------------------------------- -- Warnings@@ -2164,9 +2177,9 @@ addTabWarning (psRealSpan srcspan) lexToken -warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action-warnThen flag warning action srcspan buf len = do- addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing))+warnThen :: PsMessage -> Action -> Action+warnThen warning action srcspan buf len = do+ addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning action srcspan buf len -- -----------------------------------------------------------------------------@@ -2218,6 +2231,10 @@ data ParserOpts = ParserOpts { pWarningFlags :: EnumSet WarningFlag -- ^ enabled warning flags , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions+ , pMakePsMessage :: SrcSpan -> PsMessage -> MsgEnvelope PsMessage+ -- ^ The function to be used to construct diagnostic messages.+ -- The idea is to partially-apply 'mkParserMessage' upstream, to+ -- avoid the dependency on the 'DynFlags' in the Lexer. } -- | Haddock comment as produced by the lexer. These are accumulated in@@ -2232,11 +2249,11 @@ data PState = PState { buffer :: StringBuffer, options :: ParserOpts,- warnings :: Bag PsWarning,- errors :: Bag PsError,- tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file+ warnings :: Messages PsMessage,+ errors :: Messages PsMessage,+ tab_first :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file tab_count :: !Word, -- number of tab warnings in the file- last_tk :: Maybe (PsLocated Token), -- last non-comment token+ last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token prev_loc :: PsSpan, -- pos of previous token, including comments, prev_loc2 :: PsSpan, -- pos of two back token, including comments, -- see Note [PsSpan in Comments]@@ -2269,8 +2286,8 @@ -- locations of 'noise' tokens in the source, so that users of -- the GHC API can do source to source conversions. -- See note [exact print annotations] in GHC.Parser.Annotation- eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token- header_comments :: Maybe [LEpaComment],+ eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token+ header_comments :: Strict.Maybe [LEpaComment], comment_q :: [LEpaComment], -- Haddock comments accumulated in ascending order of their location@@ -2321,14 +2338,14 @@ POk s1 a -> (unP (k a)) s1 PFailed s1 -> PFailed s1 -failMsgP :: (SrcSpan -> PsError) -> P a+failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a failMsgP f = do pState <- getPState addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a failLocMsgP loc1 loc2 f =- addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing))+ addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing)) getPState :: P PState getPState = P $ \s -> POk s s@@ -2358,7 +2375,7 @@ addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()-setEofPos span gap = P $ \s -> POk s{ eof_pos = Just (span, gap) } ()+setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } () setLastToken :: PsSpan -> Int -> P () setLastToken loc len = P $ \s -> POk s {@@ -2367,7 +2384,7 @@ } () setLastTk :: PsLocated Token -> P ()-setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Just tk+setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Strict.Just tk , prev_loc = l , prev_loc2 = prev_loc s} () @@ -2375,7 +2392,7 @@ setLastComment (L l _) = P $ \s -> POk s { prev_loc = l , prev_loc2 = prev_loc s} () -getLastTk :: P (Maybe (PsLocated Token))+getLastTk :: P (Strict.Maybe (PsLocated Token)) getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk -- see Note [PsSpan in Comments]@@ -2664,6 +2681,7 @@ mkParserOpts :: EnumSet WarningFlag -- ^ warnings flags enabled -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled+ -> (SrcSpan -> PsMessage -> MsgEnvelope PsMessage) -- ^ How to construct diagnostics -> Bool -- ^ are safe imports on? -> Bool -- ^ keeping Haddock comment tokens -> Bool -- ^ keep regular comment tokens@@ -2675,11 +2693,12 @@ -> ParserOpts -- ^ Given exactly the information needed, set up the 'ParserOpts'-mkParserOpts warningFlags extensionFlags+mkParserOpts warningFlags extensionFlags mkMessage safeImports isHaddock rawTokStream usePosPrags = ParserOpts {- pWarningFlags = warningFlags- , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits+ pWarningFlags = warningFlags+ , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits+ , pMakePsMessage = mkMessage } where safeHaskellBit = SafeHaskellBit `setBitIf` safeImports@@ -2752,11 +2771,11 @@ PState { buffer = buf, options = options,- errors = emptyBag,- warnings = emptyBag,- tab_first = Nothing,+ errors = emptyMessages,+ warnings = emptyMessages,+ tab_first = Strict.Nothing, tab_count = 0,- last_tk = Nothing,+ last_tk = Strict.Nothing, prev_loc = mkPsSpan init_loc init_loc, prev_loc2 = mkPsSpan init_loc init_loc, last_loc = mkPsSpan init_loc init_loc,@@ -2771,8 +2790,8 @@ alr_context = [], alr_expecting_ocurly = Nothing, alr_justClosedExplicitLetBlock = False,- eof_pos = Nothing,- header_comments = Nothing,+ eof_pos = Strict.Nothing,+ header_comments = Strict.Nothing, comment_q = [], hdk_comments = nilOL }@@ -2800,15 +2819,15 @@ -- to the accumulator and parsing continues. This allows GHC to report -- more than one parse error per file. --- addError :: PsError -> m ()+ addError :: MsgEnvelope PsMessage -> m () -- | Add a warning to the accumulator. -- Use 'getMessages' to get the accumulated warnings.- addWarning :: WarningFlag -> PsWarning -> m ()+ addWarning :: MsgEnvelope PsMessage -> m () -- | Add a fatal error. This will be the last error reported by the parser, and -- the parser will not produce any result, ending in a 'PFailed' state.- addFatalError :: PsError -> m a+ addFatalError :: MsgEnvelope PsMessage -> m a -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool@@ -2824,12 +2843,13 @@ instance MonadP P where addError err- = P $ \s -> POk s { errors = err `consBag` errors s} ()+ = P $ \s -> POk s { errors = err `addMessage` errors s} () - addWarning option w- = P $ \s -> if warnopt option (options s)- then POk (s { warnings = w `consBag` warnings s }) ()- else POk s ()+ -- If the warning is meant to be suppressed, GHC will assign+ -- a `SevIgnore` severity and the message will be discarded,+ -- so we can simply add it no matter what.+ addWarning w+ = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) () addFatalError err = addError err >> P PFailed@@ -2854,7 +2874,7 @@ POk s { header_comments = header_comments', comment_q = comment_q'- } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))+ } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns)) getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments getCommentsFor (RealSrcSpan l _) = allocateCommentsP l@@ -2868,13 +2888,18 @@ getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l getFinalCommentsFor _ = return emptyComments -getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan))+getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan)) getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos +addPsMessage :: SrcSpan -> PsMessage -> P ()+addPsMessage srcspan msg = do+ opts <- options <$> getPState+ addWarning ((pMakePsMessage opts) srcspan msg)+ addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->- let tf' = if isJust tf then tf else Just srcspan+ let tf' = tf <|> Strict.Just srcspan tc' = tc + 1 s' = if warnopt Opt_WarnTabs o then s{tab_first = tf', tab_count = tc'}@@ -2883,21 +2908,25 @@ -- | Get a bag of the errors that have been accumulated so far. -- Does not take -Werror into account.-getErrorMessages :: PState -> Bag PsError+getErrorMessages :: PState -> Messages PsMessage getErrorMessages p = errors p -- | Get the warnings and errors accumulated so far. -- Does not take -Werror into account.-getMessages :: PState -> (Bag PsWarning, Bag PsError)+getMessages :: PState -> (Messages PsMessage, Messages PsMessage) getMessages p = let ws = warnings p -- we add the tabulation warning on the fly because -- we count the number of occurrences of tab characters ws' = case tab_first p of- Nothing -> ws- Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p)- `consBag` ws+ Strict.Nothing -> ws+ Strict.Just tf ->+ let msg = mkMsg (RealSrcSpan tf Strict.Nothing) $+ (PsWarnTab (tab_count p))+ in msg `addMessage` ws in (ws', errors p)+ where+ mkMsg = pMakePsMessage . options $ p getContext :: P [LayoutContext] getContext = P $ \s@PState{context=ctx} -> POk s ctx@@ -2943,8 +2972,8 @@ -> StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token -> SrcSpan- -> PsError-srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc+ -> MsgEnvelope PsMessage+srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details) where token = lexemeToString (offsetBytes (-len) buf) len pattern_ = decodePrevNChars 8 buf@@ -2953,16 +2982,13 @@ mdoInLast100 = "mdo" `isInfixOf` last100 th_enabled = ThQuotesBit `xtest` pExtsBitmap options ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options-- sug c s = if c then Just s else Nothing- sug_th = sug (not th_enabled && token == "$") SuggestTH -- #7396- sug_rdo = sug (token == "<-" && mdoInLast100) SuggestRecursiveDo- sug_do = sug (token == "<-" && not mdoInLast100) SuggestDo- sug_let = sug (token == "=" && doInLast100) SuggestLetInDo -- #15849- sug_pat = sug (not ps_enabled && pattern_ == "pattern ") SuggestPatternSynonyms -- #12429- suggests- | null token = []- | otherwise = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]+ details = PsErrParseDetails {+ ped_th_enabled = th_enabled+ , ped_do_in_last_100 = doInLast100+ , ped_mdo_in_last_100 = mdoInLast100+ , ped_pat_syn_enabled = ps_enabled+ , ped_pattern_parsed = pattern_ == "pattern "+ } -- Report a parse failure, giving the span of the previous token as -- the location of the error. This is the entry point for errors@@ -2979,7 +3005,7 @@ loc <- getRealSrcLoc (AI end buf) <- getInput reportLexError loc (psRealLoc end) buf- (\k -> PsError (PsErrLexer e k) [])+ (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k) -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a@@ -3094,8 +3120,9 @@ -- This next case is to handle a transitional issue: (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional ->- do addWarning Opt_WarnAlternativeLayoutRuleTransitional- $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where+ do addPsMessage+ (mkSrcSpanPs thisLoc)+ (PsWarnTransitionalLayout TransLayout_Where) setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close@@ -3104,8 +3131,9 @@ -- This next case is to handle a transitional issue: (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional ->- do addWarning Opt_WarnAlternativeLayoutRuleTransitional- $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe+ do addPsMessage+ (mkSrcSpanPs thisLoc)+ (PsWarnTransitionalLayout TransLayout_Pipe) setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close@@ -3228,7 +3256,7 @@ return (L span ITeof) AlexError (AI loc2 buf) -> reportLexError (psRealLoc loc1) (psRealLoc loc2) buf- (\k -> PsError (PsErrLexer LexError k) [])+ (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k) AlexSkip inp2 _ -> do setInput inp2 lexToken@@ -3242,7 +3270,11 @@ if (isComment lt') then setLastComment lt else setLastTk lt return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a+reportLexError :: RealSrcLoc+ -> RealSrcLoc+ -> StringBuffer+ -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage)+ -> P a reportLexError loc1 loc2 buf f | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF) | otherwise =@@ -3392,8 +3424,8 @@ allocatePriorComments :: RealSrcSpan -> [LEpaComment]- -> Maybe [LEpaComment]- -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])+ -> Strict.Maybe [LEpaComment]+ -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) allocatePriorComments ss comment_q mheader_comments = let cmp (L l _) = anchor l <= ss@@ -3402,14 +3434,14 @@ comment_q'= after in case mheader_comments of- Nothing -> (Just newAnns, comment_q', [])- Just _ -> (mheader_comments, comment_q', newAnns)+ Strict.Nothing -> (Strict.Just newAnns, comment_q', [])+ Strict.Just _ -> (mheader_comments, comment_q', newAnns) allocateFinalComments :: RealSrcSpan -> [LEpaComment]- -> Maybe [LEpaComment]- -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])+ -> Strict.Maybe [LEpaComment]+ -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) allocateFinalComments ss comment_q mheader_comments = let cmp (L l _) = anchor l <= ss@@ -3418,8 +3450,8 @@ comment_q'= before in case mheader_comments of- Nothing -> (Just newAnns, [], comment_q')- Just _ -> (mheader_comments, [], comment_q' ++ newAnns)+ Strict.Nothing -> (Strict.Just newAnns, [], comment_q')+ Strict.Just _ -> (mheader_comments, [], comment_q' ++ newAnns) commentToAnnotation :: RealLocated Token -> LEpaComment commentToAnnotation (L l (ITdocCommentNext s ll)) = mkLEpaComment l ll (EpaDocCommentNext s)@@ -3492,7 +3524,7 @@ alex_action_34 = endPrag alex_action_35 = dispatch_pragmas fileHeaderPrags alex_action_36 = nested_comment lexToken -alex_action_37 = warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma+alex_action_37 = warnThen PsWarnUnrecognisedPragma (nested_comment lexToken) alex_action_38 = multiline_doc_comment alex_action_39 = nested_doc_comment
ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -140,7 +140,8 @@ s <- readFile fp let def = "#define HS_CONSTANTS \"" find [] xs = xs- find _ [] = error $ "Couldn't find " ++ def ++ " in " ++ fp+ find _ [] = error $ "GHC couldn't find the RTS constants ("++def++") in " ++ fp ++ ": the RTS package you are trying to use is perhaps for another GHC version" +++ "(e.g. you are using the wrong package database) or the package database is broken.\n" find (d:ds) (x:xs) | d == x = find ds xs | otherwise = find def xs
ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module GHC.Settings.Config ( module GHC.Version , cBuildPlatformString
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -289,7 +289,7 @@ , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n in the CNF. ") , ("reallyUnsafePtrEquality#"," Returns @1\\#@ if the given pointers are equal and @0\\#@ otherwise. ") , ("numSparks#"," Returns the number of sparks in the local spark pool. ")- , ("keepAlive#"," TODO. ")+ , ("keepAlive#"," \\tt{keepAlive# x s k} keeps the value \\tt{x} alive during the execution\n of the computation \\tt{k}. ") , ("BCO"," Primitive bytecode type. ") , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ") , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n essentially an @unsafeCoerce\\#@, but if implemented as such\n the core lint pass complains and fails to compile.\n As a primop, it is opaque to core/stg, and only appears\n in cmm (where the copy propagation pass will get rid of it).\n Note that \"a\" must be a value, not a thunk! It's too late\n for strictness analysis to enforce this, so you're on your\n own to guarantee this. Also note that @Addr\\#@ is not a GC\n pointer - up to you to guarantee that it does not become\n a dangling pointer immediately after you get it.")
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -233,6 +233,9 @@ /* Define to 1 if you have the Darwin version of pthread_setname_np */ #define HAVE_PTHREAD_SETNAME_NP_DARWIN 1 +/* Define to 1 if you have the NetBSD version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP_NETBSD */+ /* Define to 1 if you have pthread_set_name_np */ /* #undef HAVE_PTHREAD_SET_NAME_NP */
ghc-lib/stage0/lib/llvm-targets view
@@ -52,5 +52,6 @@ ,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))+,("aarch64-unknown-netbsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ]
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "e61d2d47c4942c829ec98016be5aa5ae36982524"+cProjectGitCommitId = "6db8a0f76ec45d47060e28bb303e9eef60bdb16b" cProjectVersion :: String-cProjectVersion = "9.3.20210501"+cProjectVersion = "9.3.20210529" cProjectVersionInt :: String cProjectVersionInt = "903" cProjectPatchLevel :: String-cProjectPatchLevel = "20210501"+cProjectPatchLevel = "20210529" cProjectPatchLevel1 :: String-cProjectPatchLevel1 = "20210501"+cProjectPatchLevel1 = "20210529" cProjectPatchLevel2 :: String cProjectPatchLevel2 = ""
libraries/ghci/GHCi/Message.hs view
@@ -462,7 +462,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 3 || \- (major1) == 9 && (major2) == 3 && (minor) <= 20210501)+ (major1) == 9 && (major2) == 3 && (minor) <= 20210529) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo
libraries/template-haskell/Language/Haskell/TH.hs view
@@ -22,6 +22,7 @@ -- *** Reify reify, -- :: Name -> Q Info reifyModule,+ newDeclarationGroup, Info(..), ModuleInfo(..), InstanceDec, ParentName,
libraries/template-haskell/Language/Haskell/TH/Syntax.hs view
@@ -532,7 +532,10 @@ -} -{- | 'reify' looks up information about the 'Name'.+{- | 'reify' looks up information about the 'Name'. It will fail with+a compile error if the 'Name' is not visible. A 'Name' is visible if it is+imported or defined in a prior top-level declaration group. See the+documentation for 'newDeclarationGroup' for more details. It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName' to ensure that we are reifying from the right namespace. For instance, in this context:@@ -568,6 +571,60 @@ reifyType :: Name -> Q Type reifyType nm = Q (qReifyType nm) +{- | Template Haskell is capable of reifying information about types and+terms defined in previous declaration groups. Top-level declaration splices break up+declaration groups.++For an example, consider this code block. We define a datatype @X@ and+then try to call 'reify' on the datatype.++@+module Check where++data X = X+ deriving Eq++$(do+ info <- reify ''X+ runIO $ print info+ )+@++This code fails to compile, noting that @X@ is not available for reification at the site of 'reify'. We can fix this by creating a new declaration group using an empty top-level splice:++@+data X = X+ deriving Eq++$(pure [])++$(do+ info <- reify ''X+ runIO $ print info+ )+@++We provide 'newDeclarationGroup' as a means of documenting this behavior+and providing a name for the pattern.++Since top level splices infer the presence of the @$( ... )@ brackets, we can also write:++@+data X = X+ deriving Eq++newDeclarationGroup++$(do+ info <- reify ''X+ runIO $ print info+ )+@++-}+newDeclarationGroup :: Q [Dec]+newDeclarationGroup = pure []+ {- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is, if @nm@ is the name of a type class, then all instances of this class at the types @tys@ are returned. Alternatively, if @nm@ is the name of a data family or type family,@@ -585,6 +642,10 @@ There is one edge case: @reifyInstances ''Typeable tys@ currently always produces an empty list (no matter what @tys@ are given).++An instance is visible if it is imported or defined in a prior top-level+declaration group. See the documentation for 'newDeclarationGroup' for more details.+ -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] reifyInstances cls tys = Q (qReifyInstances cls tys)@@ -625,6 +686,10 @@ reifyConStrictness n = Q (qReifyConStrictness n) -- | Is the list of instances returned by 'reifyInstances' nonempty?+--+-- If you're confused by an instance not being visible despite being+-- defined in the same module and above the splice in question, see the+-- docs for 'newDeclarationGroup' for a possible explanation. isInstance :: Name -> [Type] -> Q Bool isInstance nm tys = do { decs <- reifyInstances nm tys ; return (not (null decs)) }