[Git][ghc/ghc][wip/structured-ghci-errors] 6 commits: Generalise GHC diagnostic code infrastructure
Jade (@Jade)
gitlab at gitlab.haskell.org
Wed Jul 31 21:37:14 UTC 2024
Jade pushed to branch wip/structured-ghci-errors at Glasgow Haskell Compiler / GHC
Commits:
8da8ca0d by sheaf at 2024-07-31T10:42:33+02:00
Generalise GHC diagnostic code infrastructure
This commit generalises the infrastructure used for diagnostic codes,
allowing it to be used for other namespaces than the GHC namespace.
In particular, this enables GHCi to re-use the same infrastructure to
emit error messages.
- - - - -
aaea28bf by Jade at 2024-07-31T12:21:56+02:00
WIP
- - - - -
81dd90c0 by Jade at 2024-07-31T12:21:56+02:00
WIP (using own type family)
- - - - -
acdc8566 by Jade at 2024-07-31T12:21:56+02:00
WIP
- - - - -
5607151d by Jade at 2024-07-31T22:06:17+02:00
WIP
- - - - -
8c1acd06 by Jade at 2024-07-31T23:36:36+02:00
WIP
- - - - -
20 changed files:
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Ppr.hs
- compiler/GHC/HsToCore/Errors/Ppr.hs
- compiler/GHC/Iface/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Error/Codes.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- + ghc/GHCi/UI/Print.hs
- ghc/ghc-bin.cabal.in
- linters/lint-codes/LintCodes/Static.hs
- linters/lint-codes/Main.hs
- testsuite/tests/ghci/scripts/T10508.stderr
Changes:
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -13,7 +13,7 @@ import GHC.Utils.Error
import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext )
import GHC.Utils.Logger
-printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
+printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages logger msg_opts opts msgs
= sequence_ [ let style = mkErrStyle name_ppr_ctx
ctx = (diag_ppr_ctx opts) { sdocStyle = style }
@@ -28,7 +28,7 @@ printMessages logger msg_opts opts msgs
errMsgContext = name_ppr_ctx }
<- sortMsgBag (Just opts) (getMessages msgs) ]
where
- messageWithHints :: Diagnostic a => a -> SDoc
+ messageWithHints :: a -> SDoc
messageWithHints e =
let main_msg = formatBulleted $ diagnosticMessage msg_opts e
in case diagnosticHints e of
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -89,7 +89,7 @@ instance Diagnostic GhcMessage where
GhcUnknownMessage m
-> diagnosticHints m
- diagnosticCode = constructorCode
+ diagnosticCode = constructorCode @GHC
instance HasDefaultDiagnosticOpts DriverMessageOpts where
defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)
@@ -409,4 +409,4 @@ instance Diagnostic DriverMessage where
DriverInstantiationNodeInDependencyGeneration {}
-> noHints
- diagnosticCode = constructorCode
+ diagnosticCode = constructorCode @GHC
=====================================
compiler/GHC/Driver/Errors/Types.hs
=====================================
@@ -111,7 +111,7 @@ data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage
-- conversion can happen gradually. This function should not be needed within
-- GHC, as it would typically be used by plugin or library authors (see
-- comment for the 'GhcUnknownMessage' type constructor)
-ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage
+ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ GhcHint, Diagnostic a, Typeable a) => a -> GhcMessage
ghcUnknownMessage = GhcUnknownMessage . mkSimpleUnknownDiagnostic
-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on
=====================================
compiler/GHC/Driver/Ppr.hs
=====================================
@@ -6,6 +6,7 @@ module GHC.Driver.Ppr
, showPpr
, showPprUnsafe
, printForUser
+ , printForUserColoured
)
where
@@ -34,6 +35,13 @@ showSDocForUser dflags unit_state name_ppr_ctx doc = renderWithContext (initSDoc
doc' = pprWithUnitState unit_state doc
printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()
-printForUser dflags handle name_ppr_ctx depth doc
+printForUser = printForUser' False
+
+printForUserColoured :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()
+printForUserColoured = printForUser' True
+
+printForUser' :: Bool -> DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()
+printForUser' colour dflags handle name_ppr_ctx depth doc
= printSDocLn ctx (PageMode False) handle doc
- where ctx = initSDocContext dflags (mkUserStyle name_ppr_ctx depth)
+ where ctx = initSDocContext dflags (setStyleColoured colour $ mkUserStyle name_ppr_ctx depth)
+
=====================================
compiler/GHC/HsToCore/Errors/Ppr.hs
=====================================
@@ -280,7 +280,7 @@ instance Diagnostic DsMessage where
DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule]
DsIncompleteRecordSelector{} -> noHints
- diagnosticCode = constructorCode
+ diagnosticCode = constructorCode @GHC
{-
Note [Suggest NegativeLiterals]
=====================================
compiler/GHC/Iface/Errors/Ppr.hs
=====================================
@@ -59,7 +59,7 @@ instance Diagnostic IfaceMessage where
diagnosticHints = interfaceErrorHints
- diagnosticCode = constructorCode
+ diagnosticCode = constructorCode @GHC
interfaceErrorHints :: IfaceMessage -> [GhcHint]
interfaceErrorHints = \ case
=====================================
compiler/GHC/Parser/Errors/Ppr.hs
=====================================
@@ -826,7 +826,7 @@ instance Diagnostic PsMessage where
PsErrInvalidPun {} -> [suggestExtension LangExt.ListTuplePuns]
PsErrIllegalOrPat{} -> [suggestExtension LangExt.OrPatterns]
- diagnosticCode = constructorCode
+ diagnosticCode = constructorCode @GHC
psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc
psHeaderMessageDiagnostic = \case
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -3272,7 +3272,7 @@ instance Diagnostic TcRnMessage where
TcRnMisplacedInvisPat{}
-> noHints
- diagnosticCode = constructorCode
+ diagnosticCode = constructorCode @GHC
note :: SDoc -> SDoc
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -285,7 +285,7 @@ data TcRnMessageDetailed
!TcRnMessage
deriving Generic
-mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts)
+mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ GhcHint)
=> a -> TcRnMessage
mkTcRnUnknownMessage diag = TcRnUnknownMessage (mkSimpleUnknownDiagnostic diag)
-- Please don't use this function inside the GHC codebase;
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -9,6 +9,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-}
module GHC.Types.Error
( -- * Messages
@@ -36,7 +37,6 @@ module GHC.Types.Error
, DiagnosticMessage (..)
, DiagnosticReason (WarningWithFlag, ..)
, ResolvedDiagnosticReason(..)
- , DiagnosticHint (..)
, mkPlainDiagnostic
, mkPlainError
, mkDecoratedDiagnostic
@@ -167,7 +167,7 @@ instance Diagnostic e => Outputable (Messages e) where
pprDiagnostic (errMsgDiagnostic envelope)
]
-instance Diagnostic e => ToJson (Messages e) where
+instance (Diagnostic e) => ToJson (Messages e) where
json msgs = JSArray . toList $ json <$> getMessages msgs
{- Note [Discarding Messages]
@@ -247,11 +247,16 @@ defaultDiagnosticOpts = defaultOpts @(DiagnosticOpts opts)
-- A 'Diagnostic' carries the /actual/ description of the message (which, in
-- GHC's case, it can be an error or a warning) and the /reason/ why such
-- message was generated in the first place.
-class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
+class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
-- | Type of configuration options for the diagnostic.
type DiagnosticOpts a
+ -- | Type of hint this diagnostic can provide.
+ -- by default this is 'GhcHint'
+ type DiagnosticHint a
+ type DiagnosticHint a = GhcHint
+
-- | Extract the error message text from a 'Diagnostic'.
diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc
@@ -261,7 +266,7 @@ class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
-- | Extract any hints a user might use to repair their
-- code to avoid this diagnostic.
- diagnosticHints :: a -> [GhcHint]
+ diagnosticHints :: a -> [DiagnosticHint a]
-- | Get the 'DiagnosticCode' associated with this 'Diagnostic'.
-- This can return 'Nothing' for at least two reasons:
@@ -279,13 +284,13 @@ class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where
-- | An existential wrapper around an unknown diagnostic.
data UnknownDiagnostic opts where
- UnknownDiagnostic :: (Diagnostic a, Typeable a)
+ UnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticHint a ~ GhcHint)
=> (opts -> DiagnosticOpts a) -- Inject the options of the outer context
-- into the options for the wrapped diagnostic.
-> a
-> UnknownDiagnostic opts
-instance HasDefaultDiagnosticOpts opts => Diagnostic (UnknownDiagnostic opts) where
+instance (HasDefaultDiagnosticOpts opts) => Diagnostic (UnknownDiagnostic opts) where
type DiagnosticOpts (UnknownDiagnostic opts) = opts
diagnosticMessage opts (UnknownDiagnostic f diag) = diagnosticMessage (f opts) diag
diagnosticReason (UnknownDiagnostic _ diag) = diagnosticReason diag
@@ -299,15 +304,15 @@ instance HasDefaultDiagnosticOpts NoDiagnosticOpts where
defaultOpts = NoDiagnosticOpts
-- | Make a "simple" unknown diagnostic which doesn't have any configuration options.
-mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => a -> UnknownDiagnostic b
+mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ GhcHint) => a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts)
-- | Make an unknown diagnostic which uses the same options as the context it will be embedded into.
-mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => a -> UnknownDiagnostic (DiagnosticOpts a)
+mkUnknownDiagnostic :: (Typeable a, Diagnostic a, DiagnosticHint a ~ GhcHint) => a -> UnknownDiagnostic (DiagnosticOpts a)
mkUnknownDiagnostic = UnknownDiagnostic id
-- | Embed a more complicated diagnostic which requires a potentially different options type.
-embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
+embedUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticHint a ~ GhcHint) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts
embedUnknownDiagnostic = UnknownDiagnostic
--------------------------------------------------------------------------------
@@ -317,11 +322,6 @@ pprDiagnostic e = vcat [ ppr (diagnosticReason e)
, nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ]
where opts = defaultDiagnosticOpts @e
--- | 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
@@ -578,7 +578,7 @@ https://json-schema.org
schemaVersion :: String
schemaVersion = "1.0"
-- See Note [Diagnostic Message JSON Schema] before editing!
-instance Diagnostic e => ToJson (MsgEnvelope e) where
+instance (Diagnostic e) => ToJson (MsgEnvelope e) where
json m = JSObject [
("version", JSString schemaVersion),
("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -16,22 +16,30 @@
-- A diagnostic code is a numeric unique identifier for a diagnostic.
-- See Note [Diagnostic codes].
module GHC.Types.Error.Codes
- ( GhcDiagnosticCode, constructorCode, constructorCodes )
+ ( -- * General diagnostic code infrastructure
+ DiagnosticCodeNameSpace(NameSpaceTag, DiagnosticCodeFor, ConRecursIntoFor)
+ , Outdated
+ , constructorCode, constructorCodes
+ -- * GHC diagnostic codes
+ , GHC, GhcDiagnosticCode, ConRecursInto
+ )
where
import GHC.Prelude
-import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode, NoDiagnosticOpts )
-import GHC.Hs.Extension ( GhcRn )
+import GHC.Core.InstEnv ( LookupInstanceErrReason )
+import GHC.Hs.Extension ( GhcRn )
+import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..), NoDiagnosticOpts
+ , diagnosticCode )
+import GHC.Unit.Module.Warnings ( WarningTxt )
+import GHC.Utils.Panic.Plain
-import GHC.Core.InstEnv (LookupInstanceErrReason)
-import GHC.Iface.Errors.Types
+-- Import all the structured error data types
import GHC.Driver.Errors.Types ( DriverMessage, GhcMessageOpts, DriverMessageOpts )
-import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage )
import GHC.HsToCore.Errors.Types ( DsMessage )
+import GHC.Iface.Errors.Types
+import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage )
import GHC.Tc.Errors.Types
-import GHC.Unit.Module.Warnings ( WarningTxt )
-import GHC.Utils.Panic.Plain
import Data.Kind ( Type, Constraint )
import GHC.Exts ( proxy# )
@@ -57,7 +65,11 @@ To ensure uniqueness across GHC versions, we proceed as follows:
- a diagnostic code never gets deleted from the GhcDiagnosticCode type family
in GHC.Types.Error.Codes, even if it is no longer used.
Older versions of GHC might still display the code, and we don't want that
- old code to get confused with the error code of a different, new, error message.
+ old code to get confused with the error code of a different, new, error message.*
+
+Note that this module also provides a 'DiagnosticCodeNameSpace' typeclass which
+allows diagnostic codes to be emitted in different namespaces than the GHC
+namespace; see Note [Diagnostic code namespaces].
[Instructions for adding a new diagnostic code]
@@ -99,33 +111,94 @@ To ensure uniqueness across GHC versions, we proceed as follows:
Never remove a return value from the 'GhcDiagnosticCode' type family!
Outdated error messages must still be tracked to ensure uniqueness
- of diagnostic codes across GHC versions.
+ of diagnostic codes across GHC versions. Instead, you should wrap the
+ return value in the 'Outdated' type synonym. The presence of this type synonym
+ is used by the 'codes' test to determine which diagnostic codes to check
+ for testsuite coverage.
-}
{- *********************************************************************
* *
- The GhcDiagnosticCode type family
+ DiagnosticCode infrastructure
* *
********************************************************************* -}
--- | This function obtain a diagnostic code by looking up the constructor
--- name using generics, and using the 'GhcDiagnosticCode' type family.
-constructorCode :: (Generic diag, GDiagnosticCode (Rep diag))
+{- Note [Diagnostic code namespaces]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The machinery for GHC diagnostic codes described in Note [Diagnostic codes]
+works for other namespaces than the GHC namespaces; one example is GHCi-specific
+diagnostic codes.
+
+To achieve this, we parametrise all the machinery over a namespace type-level
+argument, using the 'DiagnosticCodeNameSpace' class.
+To provide diagnostic codes, one needs to supply an instance of this class,
+which means supplying the following pieces of information:
+
+ - a type that represents the namespace, e.g. `data GHC` can be used to
+ represent the GHC namespace,
+ - a type family equation for 'NameSpaceTag', e.g. 'NameSpaceTag GHC = "GHC"',
+ - a diagnostic code type family, e.g. 'DiagnosticCodeFor GHC con = GhcDiagnosticCode con',
+ - a type family that specifies how to recur into constructor arguments,
+ e.g. 'ConRecursIntoFor GHC con = ConRecursInto con'.
+
+This allows any tool that imports the GHC library to re-use the diagnostic
+code machinery that GHC uses.
+-}
+
+-- | A constraint for a namespace which has its own diagnostic codes.
+--
+-- See Note [Diagnostic code namespaces].
+type DiagnosticCodeNameSpace :: Type -> Constraint
+class DiagnosticCodeNameSpace namespace where
+ -- | The symbolic tag for a namespace.
+ type NameSpaceTag namespace = (r :: Symbol) | r -> namespace
+ -- NB: the injectivity annotation ensures uniqueness of namespaces,
+ -- e.g. it prevents two different namespaces from using the same symbolic tag.
+ -- | A diagnostic code in a given namespace.
+ type DiagnosticCodeFor namespace (c :: Symbol) :: Nat
+ -- | Specify that one should recur into an argument of a constructor
+ -- in order to obtain a diagnostic code. See Note [Diagnostic codes].
+ type ConRecursIntoFor namespace (c :: Symbol) :: Maybe Type
+
+-- | Use this type synonym to mark a diagnostic code as outdated.
+--
+-- The presence of this type synonym is used by the 'codes' test to determine
+-- which diagnostic codes to check for testsuite coverage.
+type Outdated a = a
+
+-- | This function obtains a diagnostic code by looking up the constructor
+-- name using generics, and using the 'DiagnosticCode' type family.
+constructorCode :: forall namespace diag
+ . (Generic diag, GDiagnosticCode namespace (Rep diag))
=> diag -> Maybe DiagnosticCode
-constructorCode diag = gdiagnosticCode (from diag)
+constructorCode diag = gdiagnosticCode @namespace (from diag)
-- | This function computes all diagnostic codes that occur inside a given
--- type using generics and the 'GhcDiagnosticCode' type family.
+-- type using generics and the 'DiagnosticCode' type family.
--
-- For example, if @T = MkT1 | MkT2@, @GhcDiagnosticCode \"MkT1\" = 123@ and
-- @GhcDiagnosticCode \"MkT2\" = 456@, then we will get
--- > constructorCodes @T = fromList [ (123, \"MkT1\"), (456, \"MkT2\") ]
-constructorCodes :: forall diag. (Generic diag, GDiagnosticCodes '[diag] (Rep diag))
+-- > constructorCodes @GHC @T = fromList [ (DiagnosticCode "GHC" 123, \"MkT1\"), (DiagnosticCode "GHC" 456, \"MkT2\") ]
+constructorCodes :: forall namespace diag
+ . (Generic diag, GDiagnosticCodes namespace '[diag] (Rep diag))
=> Map DiagnosticCode String
-constructorCodes = gdiagnosticCodes @'[diag] @(Rep diag)
+constructorCodes = gdiagnosticCodes @namespace @'[diag] @(Rep diag)
-- See Note [diagnosticCodes: don't recur into already-seen types]
-- for the @'[diag] type argument.
+{- *********************************************************************
+* *
+ The GhcDiagnosticCode type family
+* *
+********************************************************************* -}
+
+-- | The GHC namespace for diagnostic codes.
+data GHC
+instance DiagnosticCodeNameSpace GHC where
+ type instance NameSpaceTag GHC = "GHC"
+ type instance DiagnosticCodeFor GHC con = GhcDiagnosticCode con
+ type instance ConRecursIntoFor GHC con = ConRecursInto con
+
-- | Type family computing the numeric diagnostic code for a given error message constructor.
--
-- Its injectivity annotation ensures uniqueness of error codes.
@@ -894,7 +967,9 @@ type family GhcDiagnosticCode c = n | n -> c where
-- NB: never remove a return value from this type family!
-- We need to ensure uniquess of diagnostic codes across GHC versions,
-- and this includes outdated diagnostic codes for errors that GHC
- -- no longer reports. These are collected below.
+ -- no longer reports. These are mostly collected below, but for ease
+ -- of rebasing it is often better to simply declare a constructor outdated
+ -- without moving it down here.
GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = Outdated 12222
GhcDiagnosticCode "TcRnNoClassInstHead" = Outdated 56538
@@ -915,12 +990,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnInterfaceLookupError" = Outdated 52243
GhcDiagnosticCode "TcRnForallIdentifier" = Outdated 64088
--- | Use this type synonym to mark a diagnostic code as outdated.
---
--- The presence of this type synonym is used by the 'codes' test to determine
--- which diagnostic codes to check for testsuite coverage.
-type Outdated a = a
-
{- *********************************************************************
* *
Recurring into an argument
@@ -1088,7 +1157,7 @@ type family ConRecursInto con where
{- Note [Diagnostic codes using generics]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Diagnostic codes are specified at the type-level using the injective
+Diagnostic codes for GHC are specified at the type-level using the injective
type family 'GhcDiagnosticCode'. This ensures uniqueness of diagnostic
codes, giving quick feedback (in the form of a type error).
@@ -1125,7 +1194,12 @@ To achieve this, we use a variant of the 'typed' lens from 'generic-lens'
first, and decide whether to recur into it using the
HasTypeQ type family.
- The two different behaviours are controlled by two main instances (*) and (**).
- - (*) recurses into a subtype, when we have a type family equation such as:
+ - (*) directly uses the constructor name, by using the 'DiagnosticCodeFor'
+ type family. The 'KnownConstructor' context (ERR2) on the instance provides
+ a custom error message in case of a missing diagnostic code, which points
+ GHC contributors to the documentation explaining how to add diagnostic codes
+ for their diagnostics.
+ - (**) recurses into a subtype, when we have a type family equation such as:
ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason
@@ -1133,94 +1207,87 @@ To achieve this, we use a variant of the 'typed' lens from 'generic-lens'
type 'DeriveInstanceErrReason'.
The overlapping instance (ERR1) provides an error message in case a constructor
does not have the type specified by the 'ConRecursInto' type family.
- - (**) directly uses the constructor name, by using the 'GhcDiagnosticCode'
- type family. The 'KnownConstructor' context (ERR2) on the instance provides
- a custom error message in case of a missing diagnostic code, which points
- GHC contributors to the documentation explaining how to add diagnostic codes
- for their diagnostics.
-}
-- | Use the generic representation of a type to retrieve the
--- diagnostic code, using the 'GhcDiagnosticCode' type family.
+-- diagnostic code, using 'DiagnosticCodeFor namespace' type family.
--
-- See Note [Diagnostic codes using generics] in GHC.Types.Error.Codes.
-type GDiagnosticCode :: (Type -> Type) -> Constraint
-class GDiagnosticCode f where
+type GDiagnosticCode :: Type -> (Type -> Type) -> Constraint
+class GDiagnosticCode namespace f where
gdiagnosticCode :: f a -> Maybe DiagnosticCode
-- | Use the generic representation of a type to retrieve the collection
-- of all diagnostic codes it can give rise to.
-type GDiagnosticCodes :: [Type] -> (Type -> Type) -> Constraint
-class GDiagnosticCodes seen f where
+type GDiagnosticCodes :: Type -> [Type] -> (Type -> Type) -> Constraint
+class GDiagnosticCodes namespace seen f where
gdiagnosticCodes :: Map DiagnosticCode String
-type ConstructorCode :: Symbol -> (Type -> Type) -> Maybe Type -> Constraint
-class ConstructorCode con f recur where
+type ConstructorCode :: Type -> Symbol -> (Type -> Type) -> Maybe Type -> Constraint
+class ConstructorCode namespace con f recur where
gconstructorCode :: f a -> Maybe DiagnosticCode
-type ConstructorCodes :: Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint
-class ConstructorCodes con f seen recur where
+type ConstructorCodes :: Type -> Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint
+class ConstructorCodes namespace con f seen recur where
gconstructorCodes :: Map DiagnosticCode String
-instance (KnownConstructor con, KnownSymbol con) => ConstructorCode con f 'Nothing where
- gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#
-instance (KnownConstructor con, KnownSymbol con) => ConstructorCodes con f seen 'Nothing where
- gconstructorCodes =
- Map.singleton
- (DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#)
- (symbolVal' @con proxy#)
-
-- If we recur into the 'UnknownDiagnostic' existential datatype,
-- unwrap the existential and obtain the error code.
instance {-# OVERLAPPING #-}
- ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts)
- , HasType (UnknownDiagnostic opts) con f )
- => ConstructorCode con f ('Just (UnknownDiagnostic opts)) where
- gconstructorCode diag = case getType @(UnknownDiagnostic opts) @con @f diag of
+ ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts)
+ , HasType namespace (UnknownDiagnostic opts) con f )
+ => ConstructorCode namespace con f ('Just (UnknownDiagnostic opts)) where
+ gconstructorCode diag = case getType @namespace @(UnknownDiagnostic opts) @con @f diag of
UnknownDiagnostic _ diag -> diagnosticCode diag
instance {-# OVERLAPPING #-}
- ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts) )
- => ConstructorCodes con f seen ('Just (UnknownDiagnostic opts)) where
+ ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts) )
+ => ConstructorCodes namespace con f seen ('Just (UnknownDiagnostic opts)) where
gconstructorCodes = Map.empty
--- (*) Recursive instance: Recur into the given type.
-instance ( ConRecursInto con ~ 'Just ty, HasType ty con f
- , Generic ty, GDiagnosticCode (Rep ty) )
- => ConstructorCode con f ('Just ty) where
- gconstructorCode diag = gdiagnosticCode (from $ getType @ty @con @f diag)
-instance ( ConRecursInto con ~ 'Just ty, HasType ty con f
- , Generic ty, GDiagnosticCodes (Insert ty seen) (Rep ty)
+-- | (*) Base instance: use the diagnostic code for this constructor in this namespace.
+instance (KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con)
+ => ConstructorCode namespace con f 'Nothing where
+ gconstructorCode _ = Just $ DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy#
+instance ( KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con) => ConstructorCodes namespace con f seen 'Nothing where
+ gconstructorCodes =
+ Map.singleton
+ (DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy#)
+ (symbolVal' @con proxy#)
+
+-- | (**) Recursive instance: recur into the given type.
+instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f
+ , Generic ty, GDiagnosticCode namespace (Rep ty) )
+ => ConstructorCode namespace con f ('Just ty) where
+ gconstructorCode diag = gdiagnosticCode @namespace (from $ getType @namespace @ty @con @f diag)
+instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f
+ , Generic ty, GDiagnosticCodes namespace (Insert ty seen) (Rep ty)
, Seen seen ty )
- => ConstructorCodes con f seen ('Just ty) where
+ => ConstructorCodes namespace con f seen ('Just ty) where
gconstructorCodes =
-- See Note [diagnosticCodes: don't recur into already-seen types]
if wasSeen @seen @ty
then Map.empty
- else gdiagnosticCodes @(Insert ty seen) @(Rep ty)
+ else gdiagnosticCodes @namespace @(Insert ty seen) @(Rep ty)
--- (**) Constructor instance: handle constructors directly.
---
--- Obtain the code from the 'GhcDiagnosticCode'
--- type family, applied to the name of the constructor.
-instance (ConstructorCode con f recur, recur ~ ConRecursInto con, KnownSymbol con)
- => GDiagnosticCode (M1 i ('MetaCons con x y) f) where
- gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x
-instance (ConstructorCodes con f seen recur, recur ~ ConRecursInto con, KnownSymbol con)
- => GDiagnosticCodes seen (M1 i ('MetaCons con x y) f) where
- gdiagnosticCodes = gconstructorCodes @con @f @seen @recur
+instance (ConstructorCode namespace con f recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con)
+ => GDiagnosticCode namespace (M1 i ('MetaCons con x y) f) where
+ gdiagnosticCode (M1 x) = gconstructorCode @namespace @con @f @recur x
+instance (ConstructorCodes namespace con f seen recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con)
+ => GDiagnosticCodes namespace seen (M1 i ('MetaCons con x y) f) where
+ gdiagnosticCodes = gconstructorCodes @namespace @con @f @seen @recur
-- Handle sum types (the diagnostic types are sums of constructors).
-instance (GDiagnosticCode f, GDiagnosticCode g) => GDiagnosticCode (f :+: g) where
- gdiagnosticCode (L1 x) = gdiagnosticCode @f x
- gdiagnosticCode (R1 y) = gdiagnosticCode @g y
-instance (GDiagnosticCodes seen f, GDiagnosticCodes seen g) => GDiagnosticCodes seen (f :+: g) where
- gdiagnosticCodes = Map.union (gdiagnosticCodes @seen @f) (gdiagnosticCodes @seen @g)
+instance (GDiagnosticCode namespace f, GDiagnosticCode namespace g) => GDiagnosticCode namespace (f :+: g) where
+ gdiagnosticCode (L1 x) = gdiagnosticCode @namespace @f x
+ gdiagnosticCode (R1 y) = gdiagnosticCode @namespace @g y
+instance (GDiagnosticCodes namespace seen f, GDiagnosticCodes namespace seen g) => GDiagnosticCodes namespace seen (f :+: g) where
+ gdiagnosticCodes = Map.union (gdiagnosticCodes @namespace @seen @f) (gdiagnosticCodes @namespace @seen @g)
-- Discard metadata we don't need.
-instance GDiagnosticCode f
- => GDiagnosticCode (M1 i ('MetaData nm mod pkg nt) f) where
- gdiagnosticCode (M1 x) = gdiagnosticCode @f x
-instance GDiagnosticCodes seen f
- => GDiagnosticCodes seen (M1 i ('MetaData nm mod pkg nt) f) where
- gdiagnosticCodes = gdiagnosticCodes @seen @f
+instance GDiagnosticCode namespace f
+ => GDiagnosticCode namespace (M1 i ('MetaData nm mod pkg nt) f) where
+ gdiagnosticCode (M1 x) = gdiagnosticCode @namespace @f x
+instance GDiagnosticCodes namespace seen f
+ => GDiagnosticCodes namespace seen (M1 i ('MetaData nm mod pkg nt) f) where
+ gdiagnosticCodes = gdiagnosticCodes @namespace @seen @f
-- | Decide whether to pick the left or right branch
-- when deciding how to recurse into a product.
@@ -1247,30 +1314,30 @@ type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where
Alt ('Just a) _ = 'Just a
Alt _ b = b
-type HasType :: Type -> Symbol -> (Type -> Type) -> Constraint
-class HasType ty orig f where
+type HasType :: Type -> Type -> Symbol -> (Type -> Type) -> Constraint
+class HasType namespace ty orig f where
getType :: f a -> ty
-instance HasType ty orig (M1 i s (K1 x ty)) where
+instance HasType namespace ty orig (M1 i s (K1 x ty)) where
getType (M1 (K1 x)) = x
-instance HasTypeProd ty (HasTypeQ ty f) orig f g => HasType ty orig (f :*: g) where
- getType = getTypeProd @ty @(HasTypeQ ty f) @orig
+instance HasTypeProd namespace ty (HasTypeQ ty f) orig f g => HasType namespace ty orig (f :*: g) where
+ getType = getTypeProd @namespace @ty @(HasTypeQ ty f) @orig
-- The lr parameter tells us whether to pick the left or right
-- branch in a product, and is computed using 'HasTypeQ'.
--
-- If it's @Just l@, then we have found the type in the left branch,
-- so use that. Otherwise, look in the right branch.
-class HasTypeProd ty lr orig f g where
+class HasTypeProd namespace ty lr orig f g where
getTypeProd :: (f :*: g) a -> ty
-- Pick the left branch.
-instance HasType ty orig f => HasTypeProd ty ('Just l) orig f g where
- getTypeProd (x :*: _) = getType @ty @orig @f x
+instance HasType namespace ty orig f => HasTypeProd namespace ty ('Just l) orig f g where
+ getTypeProd (x :*: _) = getType @namespace @ty @orig @f x
-- Pick the right branch.
-instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where
- getTypeProd (_ :*: y) = getType @ty @orig @g y
+instance HasType namespace ty orig g => HasTypeProd namespace ty 'Nothing orig f g where
+ getTypeProd (_ :*: y) = getType @namespace @ty @orig @g y
{- Note [diagnosticCodes: don't recur into already-seen types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1294,7 +1361,7 @@ of the form
This would cause an infinite loop. We thus keep track of a list of types we
have already encountered, and when we recur into a type we have already
-encountered, we simply skip taking that union (see (*)).
+encountered, we simply skip taking that union (see (**)).
Note that 'constructorCodes' starts by marking the initial type itself as "seen",
which precisely avoids the loop above when calling 'constructorCodes @TcRnMessage'.
@@ -1329,28 +1396,43 @@ instance {-# OVERLAPPABLE #-}
':$$: 'Text "does not have any argument of type '" ':<>: 'ShowType ty ':<>: 'Text "'."
':$$: 'Text ""
':$$: 'Text "This is likely due to an incorrect type family equation:"
- ':$$: 'Text " ConRecursInto \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty )
- => HasType ty orig f where
+ ':$$: 'Text " ConRecursIntoFor " ':<>: 'ShowType namespace ':<>: Text " \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty )
+ => HasType namespace ty orig f where
getType = panic "getType: unreachable"
-- (ERR2) Improve error messages for missing 'GhcDiagnosticCode' equations.
-type KnownConstructor :: Symbol -> Constraint
-type family KnownConstructor con where
- KnownConstructor con =
+type KnownConstructor :: Type -> Symbol -> Constraint
+type family KnownConstructor namespace con where
+ KnownConstructor namespace con =
KnownNatOrErr
( TypeError
- ( 'Text "Missing diagnostic code for constructor "
+ ( 'Text "Missing " ':<>: 'ShowType namespace ':<>: Text " diagnostic code for constructor "
':<>: 'Text "'" ':<>: 'Text con ':<>: 'Text "'."
':$$: 'Text ""
':$$: 'Text "Note [Diagnostic codes] in GHC.Types.Error.Codes"
':$$: 'Text "contains instructions for adding a new diagnostic code."
)
)
- (GhcDiagnosticCode con)
+ (DiagnosticCodeFor namespace con)
type KnownNatOrErr :: Constraint -> Nat -> Constraint
type KnownNatOrErr err n = (Assert err n, KnownNat n)
+-- (ERR3) Improve error messages for invalid namespaces.
+type KnownNameSpace :: Type -> Constraint
+type family KnownNameSpace namespace where
+ KnownNameSpace namespace =
+ ValidNameSpaceOrErr
+ ( TypeError
+ ( 'Text "Please provide a 'DiagnosticCodeNameSpace' instance for " ':<>: 'ShowType namespace ':<>: Text ","
+ ':$$: 'Text "including an associated type family equation for 'NameSpaceTag'."
+ )
+ )
+ (NameSpaceTag namespace)
+
+type ValidNameSpaceOrErr :: Constraint -> Symbol -> Constraint
+type ValidNameSpaceOrErr err s = (Assert err s, KnownSymbol s)
+
-- Detecting a stuck type family using a data family.
-- See https://blog.csongor.co.uk/report-stuck-families/.
type Assert :: Constraint -> k -> Constraint
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -10,6 +10,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
{-# OPTIONS -fno-warn-name-shadowing #-}
-- This module does a lot of it
@@ -34,7 +35,10 @@ module GHCi.UI (
import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
import GHCi.UI.Monad hiding ( args, runStmt )
import GHCi.UI.Info
-import GHCi.UI.Exception
+import GHCi.UI.Exception hiding (GHCi)
+import GHCi.Leak
+import GHCi.UI.Print
+
import GHC.Runtime.Debugger
import GHC.Runtime.Eval (mkTopLevEnv)
@@ -170,14 +174,12 @@ import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
import GHC.TopHandler ( topHandler )
-import GHCi.Leak
import qualified GHC.Unit.Module.Graph as GHC
-----------------------------------------------------------------------------
data GhciSettings = GhciSettings {
availableCommands :: [Command],
- shortHelpText :: String,
fullHelpText :: String,
defPrompt :: PromptFunction,
defPromptCont :: PromptFunction
@@ -187,7 +189,6 @@ defaultGhciSettings :: GhciSettings
defaultGhciSettings =
GhciSettings {
availableCommands = ghciCommands,
- shortHelpText = defShortHelpText,
defPrompt = default_prompt,
defPromptCont = default_prompt_cont,
fullHelpText = defFullHelpText
@@ -321,10 +322,8 @@ keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome
keepGoing' a str = do
in_multi <- inMultiMode
if in_multi
- then
- liftIO $ hPutStrLn stderr "Command is not supported (yet) in multi-mode"
- else
- a str
+ then reportError GhciCommandNotSupportedInMultiMode
+ else a str
return CmdSuccess
-- For commands which are actually support in multi-mode, initially just :reload
@@ -337,12 +336,9 @@ inMultiMode = multiMode <$> getGHCiState
keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
keepGoingPaths a str
= do case toArgsNoLoc str of
- Left err -> liftIO $ hPutStrLn stderr err >> return CmdSuccess
+ Left err -> reportError (GhciInvalidArgumentString err) >> return CmdSuccess
Right args -> keepGoing' a args
-defShortHelpText :: String
-defShortHelpText = "use :? for help.\n"
-
defFullHelpText :: String
defFullHelpText =
" Commands available from the prompt:\n" ++
@@ -588,7 +584,6 @@ interactiveUI config srcs maybe_exprs = do
extra_imports = [],
prelude_imports = [prelude_import],
ghc_e = isJust maybe_exprs,
- short_help = shortHelpText config,
long_help = fullHelpText config,
lastErrorLocations = lastErrLocationsRef,
mod_infos = M.empty,
@@ -599,6 +594,11 @@ interactiveUI config srcs maybe_exprs = do
return ()
+reportError :: GhciMonad m => GhciCommandMessage -> m ()
+reportError err = do
+ printError err
+ failIfExprEvalMode
+
{-
Note [Changing language extensions for interactive evaluation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1015,15 +1015,14 @@ generatePromptFunctionFromString promptS modules_names line =
processString ('%':'c':'a':'l':'l':xs) = do
-- Input has just been validated by parseCallEscape
let (cmd NE.:| args, afterClosed) = fromJust $ parseCallEscape xs
- respond <- liftIO $ do
+ respond <- do
(code, out, err) <-
- readProcessWithExitCode
- cmd args ""
+ liftIO $ readProcessWithExitCode cmd args ""
`catchIO` \e -> return (ExitFailure 1, "", show e)
case code of
ExitSuccess -> return out
_ -> do
- hPutStrLn stderr err
+ reportError (GhciPromptCallError err)
return ""
liftM ((text respond) <>) (processString afterClosed)
processString ('%':'%':xs) =
@@ -1448,16 +1447,14 @@ specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
specialCommand str = do
let (cmd,rest) = break isSpace str
maybe_cmd <- lookupCommand cmd
- htxt <- short_help <$> getGHCiState
case maybe_cmd of
GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)
BadCommand ->
- do liftIO $ hPutStr stderr ("unknown command ':" ++ cmd ++ "'\n"
- ++ htxt)
+ -- JADE_TODO
+ do reportError (GhciUnknownCommand cmd)
return CmdFailure
NoLastCommand ->
- do liftIO $ hPutStr stderr ("there is no last command to perform\n"
- ++ htxt)
+ do reportError GhciNoLastCommandAvailable
return CmdFailure
shellEscape :: MonadIO m => String -> m CmdExecOutcome
@@ -1577,8 +1574,8 @@ help _ = do
-----------------------------------------------------------------------------
-- :info
-info :: GHC.GhcMonad m => Bool -> String -> m ()
-info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
+info :: GhciMonad m => Bool -> String -> m ()
+info _ "" = reportError (GhciCommandSyntaxError "info <thing-you-want-info-about>")
info allInfo s = handleSourceError printGhciException $ do
forM_ (words s) $ \thing -> do
sdoc <- infoThing allInfo thing
@@ -1617,9 +1614,7 @@ pprInfo (thing, fixity, cls_insts, fam_insts, docs)
-- :main
runMain :: GhciMonad m => String -> m ()
-runMain s = case toArgsNoLoc s of
- Left err -> liftIO (hPutStrLn stderr err)
- Right args -> doWithMain (doWithArgs args)
+runMain s = toArgsNoLocWithErrorHandler s (doWithMain . doWithArgs)
where
doWithMain fun = do
dflags <- getDynFlags
@@ -1676,6 +1671,11 @@ toArgsNoLoc str = map unLoc <$> toArgs fake_loc str
fake_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
-- this should never be seen, because it's discarded with the `map unLoc`
+toArgsNoLocWithErrorHandler :: GhciMonad m => String -> ([String] -> m ()) -> m ()
+toArgsNoLocWithErrorHandler str f = case toArgsNoLoc str of
+ Left err -> reportError $ GhciInvalidArgumentString err
+ Right ok -> f ok
+
-----------------------------------------------------------------------------
-- :cd
@@ -1776,59 +1776,54 @@ chooseEditFile =
-- :def
defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()
-defineMacro _ (':':_) = (liftIO $ hPutStrLn stderr
- "macro name cannot start with a colon")
- >> failIfExprEvalMode
-defineMacro _ ('!':_) = (liftIO $ hPutStrLn stderr
- "macro name cannot start with an exclamation mark")
- >> failIfExprEvalMode
- -- little code duplication allows to grep error msg
+defineMacro _ (':':_) = reportError (GhciMacroInvalidStart "a colon")
+defineMacro _ ('!':_) = reportError (GhciMacroInvalidStart "an exclamation mark")
defineMacro overwrite s = do
let (macro_name, definition) = break isSpace s
macros <- ghci_macros <$> getGHCiState
let defined = map cmdName macros
if null macro_name
then if null defined
+ -- JADE_TODO
then liftIO $ putStrLn "no macros defined"
else liftIO $ putStr ("the following macros are defined:\n" ++
unlines defined)
else do
isCommand <- isJust <$> lookupCommand' macro_name
+
let check_newname
- | macro_name `elem` defined = throwGhcException (CmdLineError
- ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))
- | isCommand = throwGhcException (CmdLineError
- ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))
- | otherwise = return ()
- hint = " Use ':def!' to overwrite."
-
- unless overwrite check_newname
- -- compile the expression
- handleSourceError printErrAndMaybeExit $ do
- step <- getGhciStepIO
- expr <- GHC.parseExpr definition
- -- > ghciStepIO . definition :: String -> IO String
- let stringTy :: LHsType GhcPs
- stringTy = nlHsTyVar NotPromoted stringTyCon_RDR
- ioM :: LHsType GhcPs -- AZ
- ioM = nlHsTyVar NotPromoted (getRdrName ioTyConName) `nlHsAppTy` stringTy
- body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
- `mkHsApp` (nlHsPar expr)
- tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $
- nlHsFunTy stringTy ioM
- new_expr = L (getLoc expr) $ ExprWithTySig noAnn body tySig
- hv <- GHC.compileParsedExprRemote new_expr
-
- let newCmd = Command { cmdName = macro_name
- , cmdAction = lift . runMacro hv
- , cmdHidden = False
- , cmdCompletionFunc = noCompletion
- }
-
- -- later defined macros have precedence
- modifyGHCiState $ \s ->
- let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
- in s { ghci_macros = newCmd : filtered }
+ | macro_name `elem` defined = Just (GhciMacroAlreadyDefined macro_name)
+ | isCommand = Just (GhciMacroOverwritesBuiltin macro_name)
+ | otherwise = Nothing
+
+ if | not overwrite, Just err <- check_newname -> reportError err
+ | otherwise -> do
+ -- compile the expression
+ handleSourceError printErrAndMaybeExit $ do
+ step <- getGhciStepIO
+ expr <- GHC.parseExpr definition
+ -- > ghciStepIO . definition :: String -> IO String
+ let stringTy :: LHsType GhcPs
+ stringTy = nlHsTyVar NotPromoted stringTyCon_RDR
+ ioM :: LHsType GhcPs -- AZ
+ ioM = nlHsTyVar NotPromoted (getRdrName ioTyConName) `nlHsAppTy` stringTy
+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
+ `mkHsApp` (nlHsPar expr)
+ tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $
+ nlHsFunTy stringTy ioM
+ new_expr = L (getLoc expr) $ ExprWithTySig noAnn body tySig
+ hv <- GHC.compileParsedExprRemote new_expr
+
+ let newCmd = Command { cmdName = macro_name
+ , cmdAction = lift . runMacro hv
+ , cmdHidden = False
+ , cmdCompletionFunc = noCompletion
+ }
+
+ -- later defined macros have precedence
+ modifyGHCiState $ \s ->
+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
+ in s { ghci_macros = newCmd : filtered }
runMacro
:: GhciMonad m
@@ -1850,8 +1845,7 @@ undefineMacro str = mapM_ undef (words str)
where undef macro_name = do
cmds <- ghci_macros <$> getGHCiState
if (macro_name `notElem` map cmdName cmds)
- then throwGhcException (CmdLineError
- ("macro '" ++ macro_name ++ "' is not defined"))
+ then reportError (GhciMacroNotDefined macro_name)
else do
-- This is a tad racy but really, it's a shell
modifyGHCiState $ \s ->
@@ -1890,9 +1884,8 @@ getGhciStepIO = do
-----------------------------------------------------------------------------
-- :doc
-docCmd :: GHC.GhcMonad m => String -> m ()
-docCmd "" =
- throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")
+docCmd :: GhciMonad m => String -> m ()
+docCmd "" = reportError (GhciCommandSyntaxError "doc <thing-you-want-docs-for>")
docCmd s = do
-- TODO: Maybe also get module headers for module names
names <- GHC.parseName s
@@ -1978,8 +1971,7 @@ handleGetDocsFailure no_docs = do
-- :instances
instancesCmd :: String -> InputT GHCi ()
-instancesCmd "" =
- throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")
+instancesCmd "" = reportError (GhciCommandSyntaxError "instances <type-you-want-instances-for>")
instancesCmd s = do
handleSourceError printGhciException $ do
ty <- GHC.parseInstanceHead s
@@ -2082,16 +2074,13 @@ addModule files = do
Finder.findImportedModule hsc_env m (ThisPkg (homeUnitId home_unit))
case result of
Found _ _ -> return True
- _ -> do liftIO $ hPutStrLn stderr ("Module " ++ moduleNameString m ++ " not found")
- failIfExprEvalMode
+ _ -> do reportError (GhciModuleNotFound (moduleNameString m))
return False
checkTargetFile :: GhciMonad m => String -> m Bool
checkTargetFile f = do
exists <- liftIO (doesFileExist f)
- unless exists $ do
- liftIO $ hPutStrLn stderr $ "File " ++ f ++ " not found"
- failIfExprEvalMode
+ unless exists $ reportError (GhciFileNotFound f)
return exists
-- | @:unadd@ command
@@ -2164,7 +2153,8 @@ doLoad load_type howmuch = do
hmis <- ifaceCache <$> getGHCiState
-- If GHCi message gets its own configuration at some stage then this will need to be
-- modified to 'embedUnknownDiagnostic'.
- ok <- trySuccess $ GHC.loadWithCache (Just hmis) (mkUnknownDiagnostic . GHCiMessage) howmuch
+ -- JADE_TODO
+ ok <- trySuccess $ GHC.loadWithCache (Just hmis) (embedUnknownDiagnostic id) howmuch
afterLoad ok load_type
pure ok
@@ -2335,15 +2325,10 @@ modulesLoadedMsg ok mods load_type = do
-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
-- and printing 'throwE' strings to 'stderr'. If in expression
-- evaluation mode - throw GhcException and exit.
-runExceptGhciMonad :: GhciMonad m => ExceptT SDoc m () -> m ()
+runExceptGhciMonad :: GhciMonad m => ExceptT GhciCommandMessage m () -> m ()
runExceptGhciMonad act = handleSourceError printGhciException $
- either handleErr pure =<<
+ either reportError pure =<<
runExceptT act
- where
- handleErr sdoc = do
- rendered <- showSDocForUserQualify sdoc
- liftIO $ hPutStrLn stderr rendered
- failIfExprEvalMode
-- | Inverse of 'runExceptT' for \"pure\" computations
-- (c.f. 'except' for 'Except')
@@ -2419,7 +2404,7 @@ allTypesCmd _ = runExceptGhciMonad $ do
-- Helpers for locAtCmd/typeAtCmd/usesCmd
-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
-parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
+parseSpanArg :: String -> Either GhciCommandMessage (RealSrcSpan,String)
parseSpanArg s = do
(fp,s0) <- readAsString (skipWs s)
s0' <- skipWs1 s0
@@ -2443,13 +2428,13 @@ parseSpanArg s = do
return (span',trailer)
where
- readAsInt :: String -> Either SDoc (Int,String)
- readAsInt "" = Left "Premature end of string while expecting Int"
+ readAsInt :: String -> Either GhciCommandMessage (Int,String)
+ readAsInt "" = failParse "Premature end of string while expecting Int"
readAsInt s0 = case reads s0 of
[s_rest] -> Right s_rest
- _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")
+ _ -> failParse $ "Couldn't read" <+> text (show s0) <+> "as Int"
- readAsString :: String -> Either SDoc (String,String)
+ readAsString :: String -> Either GhciCommandMessage (String,String)
readAsString s0
| '"':_ <- s0 = case reads s0 of
[s_rest] -> Right s_rest
@@ -2457,15 +2442,16 @@ parseSpanArg s = do
| s_rest@(_:_,_) <- breakWs s0 = Right s_rest
| otherwise = leftRes
where
- leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")
+ leftRes = failParse $ "Couldn't read" <+> text (show s0) <+> "as String"
- skipWs1 :: String -> Either SDoc String
+ skipWs1 :: String -> Either GhciCommandMessage String
skipWs1 (c:cs) | isWs c = Right (skipWs cs)
- skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))
+ skipWs1 s0 = failParse $ "Expected whitespace in" <+> text (show s0)
isWs = (`elem` [' ','\t'])
skipWs = dropWhile isWs
breakWs = break isWs
+ failParse = Left . GhciArgumentParseError
-- | Pretty-print \"real\" 'SrcSpan's as
@@ -2514,7 +2500,7 @@ scriptCmd :: String -> InputT GHCi ()
scriptCmd ws = do
case words' ws of
[s] -> runScript s
- _ -> throwGhcException (CmdLineError "syntax: :script <filename>")
+ _ -> reportError (GhciCommandSyntaxError "script <filename>")
-- | A version of 'words' that treats sequences enclosed in double quotes as
-- single words and that does not break on backslash-escaped spaces.
@@ -2562,7 +2548,7 @@ runScript filename = do
-- Displaying Safe Haskell properties of a module
-isSafeCmd :: GHC.GhcMonad m => String -> m ()
+isSafeCmd :: GhciMonad m => String -> m ()
isSafeCmd m =
case words m of
[s] | looksLikeModuleName s -> do
@@ -2570,7 +2556,7 @@ isSafeCmd m =
isSafeModule md
[] -> do md <- guessCurrentModule "issafe"
isSafeModule md
- _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")
+ _ -> reportError (GhciCommandSyntaxError "issafe <module>")
isSafeModule :: GHC.GhcMonad m => Module -> m ()
isSafeModule m = do
@@ -2741,7 +2727,7 @@ browseModule bang modl exports_only = do
moduleCmd :: GhciMonad m => String -> m ()
moduleCmd str
| all sensible strs = cmd
- | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ | otherwise = reportError (GhciCommandSyntaxError "module [+/-] [*]M1 ... [*]Mn")
where
(cmd, strs) =
case str of
@@ -2989,41 +2975,30 @@ setCmd "" = showOptions False
setCmd "-a" = showOptions True
setCmd str
= case getCmd str of
- Right ("args", rest) ->
- case toArgsNoLoc rest of
- Left err -> liftIO (hPutStrLn stderr err)
- Right args -> setArgs args
- Right ("prog", rest) ->
- case toArgsNoLoc rest of
- Right [prog] -> setProg prog
- _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
-
+ Right ("args", rest) -> toArgsNoLocWithErrorHandler rest setArgs
+ Right ("prog", rest) -> toArgsNoLocWithErrorHandler rest $ \case
+ [prog] -> setProg prog
+ _ -> reportError $ GhciCommandSyntaxError "set prog <progname>"
Right ("prompt", rest) ->
setPromptString setPrompt (dropWhile isSpace rest)
- "syntax: set prompt <string>"
+ (GhciCommandSyntaxError "set promp <string>")
Right ("prompt-function", rest) ->
setPromptFunc setPrompt $ dropWhile isSpace rest
Right ("prompt-cont", rest) ->
setPromptString setPromptCont (dropWhile isSpace rest)
- "syntax: :set prompt-cont <string>"
+ (GhciCommandSyntaxError "set prompt-cont <string>")
Right ("prompt-cont-function", rest) ->
setPromptFunc setPromptCont $ dropWhile isSpace rest
-
Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
Right ("stop", rest) -> setStop $ dropWhile isSpace rest
Right ("local-config", rest) ->
setLocalConfigBehaviour $ dropWhile isSpace rest
- _ -> case toArgsNoLoc str of
- Left err -> liftIO (hPutStrLn stderr err)
- Right wds -> () <$ keepGoing' setOptions wds
+ _ -> toArgsNoLocWithErrorHandler str $ \wds -> () <$ keepGoing' setOptions wds
setiCmd :: GhciMonad m => String -> m ()
setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
-setiCmd str =
- case toArgsNoLoc str of
- Left err -> liftIO (hPutStrLn stderr err)
- Right wds -> newDynFlags True wds
+setiCmd str = toArgsNoLocWithErrorHandler str (newDynFlags True)
showOptions :: GhciMonad m => Bool -> m ()
showOptions show_all
@@ -3096,8 +3071,7 @@ setLocalConfigBehaviour s
modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })
| s == "ignore" =
modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })
- | otherwise = throwGhcException
- (CmdLineError "syntax: :set local-config { source | ignore }")
+ | otherwise = reportError (GhciCommandSyntaxError "set local-config { source | ignore }")
setStop str@(c:_) | isDigit c
= do let (nm_str,rest) = break (not.isDigit) str
@@ -3134,18 +3108,17 @@ setPromptFunc fSetPrompt s = do
convertToPromptFunction func = (\mods line -> liftIO $
liftM text (func mods line))
-setPromptString :: MonadIO m
- => (PromptFunction -> m ()) -> String -> String -> m ()
+setPromptString :: GhciMonad m
+ => (PromptFunction -> m ()) -> String -> GhciCommandMessage -> m ()
setPromptString fSetPrompt value err = do
if null value
- then liftIO $ hPutStrLn stderr $ err
+ then reportError err
else case value of
('\"':_) ->
case reads value of
[(value', xs)] | all isSpace xs ->
setParsedPromptString fSetPrompt value'
- _ -> liftIO $ hPutStrLn stderr
- "Can't parse prompt string. Use Haskell syntax."
+ _ -> reportError GhciInvalidPromptString
_ ->
setParsedPromptString fSetPrompt value
@@ -3228,15 +3201,11 @@ newDynFlags interactive_only minus_opts = do
return ()
-unknownFlagsErr :: [String] -> a
-unknownFlagsErr fs = throwGhcException $ CmdLineError $ concatMap oneError fs
+
+unknownFlagsErr :: GhciMonad m => [String] -> m ()
+unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs
where
- oneError f =
- "unrecognised flag: " ++ f ++ "\n" ++
- (case flagSuggestions ghciFlags f of
- [] -> ""
- suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
- ghciFlags = nubSort $ flagsForCompletion True
+ suggestions f = flagSuggestions (nubSort $ flagsForCompletion True) f
unsetOptions :: GhciMonad m => String -> m ()
unsetOptions str
@@ -3357,13 +3326,13 @@ showCmd str = do
$ hang (text ":show") 6
$ brackets (fsep $ punctuate (text " |") helpCmds)
-showiCmd :: GHC.GhcMonad m => String -> m ()
+showiCmd :: GhciMonad m => String -> m ()
showiCmd str = do
case words str of
["languages"] -> showiLanguages -- backwards compat
["language"] -> showiLanguages
["lang"] -> showiLanguages -- useful abbreviation
- _ -> throwGhcException (CmdLineError ("syntax: :showi language"))
+ _ -> reportError (GhciCommandSyntaxError "showi language")
showImports :: GhciMonad m => m ()
showImports = do
@@ -3550,7 +3519,8 @@ completeCmd argLine0 = case parseLine argLine0 of
liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
liftIO $ print r
- _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
+ -- JADE_TODO
+ _ -> reportError (GhciCommandSyntaxError "complete repl [<range>] <quoted-string-to-complete>")
where
parseLine [] = Nothing
parseLine argLine = case breakSpace argLine of
@@ -4587,7 +4557,7 @@ failIfExprEvalMode = do
-- | When in expression evaluation mode (ghc -e), we want to exit immediately.
-- Otherwis, just print out the message.
printErrAndMaybeExit :: (GhciMonad m, MonadIO m, HasLogger m) => SourceError -> m ()
-printErrAndMaybeExit = (>> failIfExprEvalMode) . printGhciException
+printErrAndMaybeExit err = printGhciException err >> failIfExprEvalMode
-----------------------------------------------------------------------------
-- recursive exception handlers
=====================================
ghc/GHCi/UI/Exception.hs
=====================================
@@ -1,15 +1,19 @@
{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
-module GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where
+module GHCi.UI.Exception
+ ( GhciMessage(..)
+ , GhciMessageOpts(..)
+ , GhciCommandMessage(..)
+ , GHCi
+ ) where
import GHC.Prelude
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Errors
import GHC.Driver.Errors.Types
-import GHC.Driver.Session
import GHC.Iface.Errors.Ppr
import GHC.Iface.Errors.Types
@@ -19,40 +23,60 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Tc.Errors.Ppr
import GHC.Tc.Errors.Types
-import GHC.Types.Error
-import GHC.Types.SourceError
+import GHC.Types.Error.Codes
+import GHC.TypeLits
import GHC.Unit.State
-import GHC.Utils.Logger
import GHC.Utils.Outputable
-import Control.Monad.IO.Class
+import GHC.Generics
+import GHC.Types.Error
+import qualified GHC
+
+
+data GhciMessageOpts = GhciMessageOpts
+ { ghcMessageOpts :: DiagnosticOpts GhcMessage
+ , ghciCommandMessageOpts :: DiagnosticOpts GhciCommandMessage
+ }
+data GhciMessage where
+ GhciCommandMessage :: GhciCommandMessage -> GhciMessage
+ GhciGhcMessage :: GhcMessage -> GhciMessage
--- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting
--- for some error messages.
-printGhciException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()
-printGhciException err = do
- dflags <- getDynFlags
- logger <- getLogger
- let !diag_opts = initDiagOpts dflags
- !print_config = initPrintConfig dflags
- liftIO $ printMessages logger print_config diag_opts (GHCiMessage <$> (srcErrorMessages err))
+data GhciHint where
+ GhciCommandHint :: GhciCommandHint -> GhciHint
+ GhciGhcHint :: GhcHint -> GhciHint
+instance Outputable GhciHint where
+ ppr = \case
+ GhciCommandHint hint -> ppr hint
+ GhciGhcHint hint -> ppr hint
-newtype GHCiMessage = GHCiMessage { _getGhciMessage :: GhcMessage }
+instance HasDefaultDiagnosticOpts GhciMessageOpts where
+ defaultOpts = GhciMessageOpts
+ (defaultDiagnosticOpts @GhcMessage)
+ (defaultDiagnosticOpts @GhciCommandMessage)
-instance Diagnostic GHCiMessage where
- type DiagnosticOpts GHCiMessage = DiagnosticOpts GhcMessage
+instance Diagnostic GhciMessage where
+ type DiagnosticOpts GhciMessage = GhciMessageOpts
+ type DiagnosticHint GhciMessage = GhciHint
- diagnosticMessage opts (GHCiMessage msg) = ghciDiagnosticMessage opts msg
+ diagnosticMessage opts = \case
+ GhciGhcMessage m -> ghciDiagnosticMessage (ghcMessageOpts opts) m
+ GhciCommandMessage m -> diagnosticMessage (ghciCommandMessageOpts opts) m
- diagnosticReason (GHCiMessage msg) = diagnosticReason msg
+ diagnosticReason = \case
+ GhciGhcMessage m -> diagnosticReason m
+ GhciCommandMessage m -> diagnosticReason m
- diagnosticHints (GHCiMessage msg) = ghciDiagnosticHints msg
+ diagnosticHints = \case
+ GhciGhcMessage m -> map GhciGhcHint (ghciDiagnosticHints m)
+ GhciCommandMessage m -> map GhciCommandHint (diagnosticHints m)
- diagnosticCode (GHCiMessage msg) = diagnosticCode msg
+ diagnosticCode = \case
+ GhciGhcMessage m -> diagnosticCode m
+ GhciCommandMessage m -> diagnosticCode m
-- | Modifications to hint messages which we want to display in GHCi.
@@ -139,3 +163,157 @@ ghciDiagnosticMessage ghc_opts msg =
quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>
text "to expose it." $$
text "(Note: this unloads all the modules in the current scope.)"
+
+data GhciCommandMessage
+ -- macro errors
+ = GhciMacroAlreadyDefined String
+ | GhciMacroInvalidStart String
+ | GhciMacroNotDefined String
+ | GhciMacroOverwritesBuiltin String
+ -- module name errors
+ | GhciModuleNotFound String
+ | GhciNoModuleNameGuess
+ | GhciNoModuleInfoForCurrentFile
+ | GhciNoLocationInfoForModule GHC.ModuleName
+ | GhciNoResolvedModules
+ | GhciNoModuleForName GHC.Name
+ | GhciNoMatchingModuleExport
+ -- argument parse error
+ | GhciArgumentParseError SDoc
+ -- other errors
+ | GhciCommandNotSupportedInMultiMode
+ | GhciInvalidArgumentString String
+ | GhciFileNotFound String
+ | GhciCommandSyntaxError String -- TODO: [String] for Parameters
+ | GhciInvalidPromptString
+ | GhciPromptCallError String
+ | GhciUnknownCommand String
+ | GhciNoLastCommandAvailable
+ | GhciUnknownFlag String [String]
+ | GhciNoSetEditor
+ deriving Generic
+
+data GhciCommandHint
+ = HelpCommand
+ | SetEditor
+ | Overwrite
+ | MeantOther [String]
+
+
+instance Outputable GhciCommandHint where
+ ppr = \case
+ HelpCommand
+ -> use "?" <+> "for help"
+ MeantOther suggs
+ -> "did you mean one of" <> colon <+> nest 2 (hsep (map text suggs))
+ SetEditor
+ -> use "set editor"
+ Overwrite
+ -> use "def!" <+> "to overwrite"
+ where use cmd = "Use" <+> quotes (colon <> cmd)
+
+instance Diagnostic GhciCommandMessage where
+ type DiagnosticOpts GhciCommandMessage = NoDiagnosticOpts
+ type DiagnosticHint GhciCommandMessage = GhciCommandHint
+
+ diagnosticMessage NoDiagnosticOpts = mkSimpleDecorated . \case
+ GhciMacroAlreadyDefined name
+ -> "Macro" <+> quotes (text name) <+> "is already defined"
+ GhciMacroOverwritesBuiltin name
+ -> "Macro" <+> quotes (text name) <+> "overwrites builtin command"
+ GhciMacroInvalidStart str
+ -> "Macro name cannot start with" <+> text str
+ GhciMacroNotDefined name
+ -> "Macro" <+> quotes (text name) <+> "is not defined"
+ GhciModuleNotFound modN
+ -> "Module" <+> text modN <+> "not found"
+ GhciNoModuleNameGuess
+ -> "Couldn't guess that module name. Does it exist?"
+ GhciNoModuleInfoForCurrentFile
+ -> "No module info for current file! Try loading it?"
+ GhciNoLocationInfoForModule name
+ -> "Found a name, but no location information" <.> "The module is" <:> ppr name
+ GhciNoResolvedModules
+ -> "Couldn't resolve to any modules."
+ GhciNoModuleForName name
+ -> "No module for" <+> ppr name
+ GhciNoMatchingModuleExport
+ -> "No matching export in any local modules."
+ GhciArgumentParseError ape -> ape
+ GhciCommandNotSupportedInMultiMode
+ -> "Command is not supported (yet) in multi-mode"
+ GhciInvalidArgumentString str
+ -> text str
+ GhciCommandSyntaxError cmd
+ -> "Syntax" <> colon $+$ nest 2 (colon <> text cmd)
+ GhciInvalidPromptString
+ -> "Can't parse prompt string. Use Haskell syntax"
+ GhciUnknownCommand cmd
+ -> "Unknown command" <+> quotes (colon <> text cmd)
+ GhciNoLastCommandAvailable
+ -> "There is no last command to perform"
+ GhciFileNotFound f
+ -> "File" <+> text f <+> "not found"
+ GhciUnknownFlag flag _
+ -> "Unrecognised flag" <:> text flag
+ GhciPromptCallError err
+ -> text err -- JADE_TODO
+ GhciNoSetEditor
+ -> "editor not set"
+ where
+ l <:> r = l <> colon <+> r
+ l <.> r = l <> dot <+> r
+
+ -- JADE_TODO
+ diagnosticReason _ = ErrorWithoutFlag
+
+ diagnosticHints = \case
+ GhciUnknownCommand{}
+ -> [HelpCommand]
+ GhciNoLastCommandAvailable{}
+ -> [HelpCommand]
+ GhciUnknownFlag _ suggs@(_:_)
+ -> [MeantOther suggs]
+ GhciNoSetEditor{}
+ -> [SetEditor]
+ GhciMacroAlreadyDefined{}
+ -> [Overwrite]
+ GhciMacroOverwritesBuiltin{}
+ -> [Overwrite]
+ _ -> []
+
+ diagnosticCode = constructorCode @GHCi
+
+-- | type index for the ghci diagnostic code namespace
+data GHCi
+
+instance DiagnosticCodeNameSpace GHCi where
+ type instance NameSpaceTag GHCi = "GHCi"
+ type instance DiagnosticCodeFor GHCi con = GhciDiagnosticCode con
+ -- For now we don't recur into any error
+ type instance ConRecursIntoFor GHCi con = 'Nothing
+
+type GhciDiagnosticCode :: Symbol -> Nat
+type family GhciDiagnosticCode c = n | n -> c where
+ GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = 83514
+ GhciDiagnosticCode "GhciInvalidArgumentString" = 68894
+ GhciDiagnosticCode "GhciCommandSyntaxError" = 72682
+ GhciDiagnosticCode "GhciInvalidPromptString" = 50882
+ GhciDiagnosticCode "GhciPromptCallError" = 22747
+ GhciDiagnosticCode "GhciUnknownCommand" = 54713
+ GhciDiagnosticCode "GhciNoLastCommandAvailable" = 29130
+ GhciDiagnosticCode "GhciUnknownFlag" = 15670
+ GhciDiagnosticCode "GhciNoSetEditor" = 34086
+ GhciDiagnosticCode "GhciMacroInvalidStart" = 64996
+ GhciDiagnosticCode "GhciMacroAlreadyDefined" = 93909
+ GhciDiagnosticCode "GhciMacroNotDefined" = 40561
+ GhciDiagnosticCode "GhciMacroOverwritesBuiltin" = 86201
+ GhciDiagnosticCode "GhciFileNotFound" = 31901
+ GhciDiagnosticCode "GhciModuleNotFound" = 23305
+ GhciDiagnosticCode "GhciNoModuleNameGuess" = 21939
+ GhciDiagnosticCode "GhciNoModuleInfoForCurrentFile" = 96587
+ GhciDiagnosticCode "GhciNoLocationInfoForModule" = 12769
+ GhciDiagnosticCode "GhciNoResolvedModules" = 54909
+ GhciDiagnosticCode "GhciNoModuleForName" = 21847
+ GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723
+ GhciDiagnosticCode "GhciArgumentParseError" = 35671
=====================================
ghc/GHCi/UI/Info.hs
=====================================
@@ -50,6 +50,8 @@ import GHC.Types.SrcLoc
import GHC.Types.Var
import qualified GHC.Data.Strict as Strict
+import GHCi.UI.Exception
+
-- | Info about a module. This information is generated every time a
-- module is loaded.
data ModInfo = ModInfo
@@ -114,23 +116,19 @@ findLoc :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
- -> ExceptT SDoc m (ModInfo,Name,SrcSpan)
+ -> ExceptT GhciCommandMessage m (ModInfo,Name,SrcSpan)
findLoc infos span0 string = do
- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
+ name <- maybeToExceptT GhciNoModuleNameGuess $
guessModule infos (srcSpanFilePath span0)
- info <- maybeToExceptT "No module info for current file! Try loading it?" $
+ info <- maybeToExceptT GhciNoModuleInfoForCurrentFile $
MaybeT $ pure $ M.lookup name infos
name' <- findName infos span0 info string
case getSrcSpan name' of
- UnhelpfulSpan{} -> do
- throwE ("Found a name, but no location information." <+>
- "The module is:" <+>
- maybe "<unknown>" (ppr . moduleName)
- (nameModule_maybe name'))
-
+ UnhelpfulSpan{} -> throwE $ GhciNoLocationInfoForModule
+ (maybe (ModuleName "<unknown>") moduleName (nameModule_maybe name'))
span' -> return (info,name',span')
-- | Find any uses of the given identifier in the codebase.
@@ -138,7 +136,7 @@ findNameUses :: (GhcMonad m)
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
- -> ExceptT SDoc m [SrcSpan]
+ -> ExceptT GhciCommandMessage m [SrcSpan]
findNameUses infos span0 string =
locToSpans <$> findLoc infos span0 string
where
@@ -166,7 +164,7 @@ findName :: GhcMonad m
-> RealSrcSpan
-> ModInfo
-> String
- -> ExceptT SDoc m Name
+ -> ExceptT GhciCommandMessage m Name
findName infos span0 mi string =
case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
Nothing -> tryExternalModuleResolution
@@ -178,7 +176,7 @@ findName infos span0 mi string =
rdrs = modInfo_rdrs mi
tryExternalModuleResolution =
case find (matchName $ mkFastString string) rdrs of
- Nothing -> throwE "Couldn't resolve to any modules."
+ Nothing -> throwE GhciNoResolvedModules
Just imported -> resolveNameFromModule infos imported
matchName :: FastString -> Name -> Bool
@@ -190,18 +188,21 @@ findName infos span0 mi string =
resolveNameFromModule :: GhcMonad m
=> Map ModuleName ModInfo
-> Name
- -> ExceptT SDoc m Name
+ -> ExceptT GhciCommandMessage m Name
resolveNameFromModule infos name = do
- modL <- maybe (throwE $ "No module for" <+> ppr name) return $
+ modL <- maybe (throwE $ GhciNoModuleForName name) return $
nameModule_maybe name
- info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <>
- ppr modL)) return $
- M.lookup (moduleName modL) infos
+ -- BÄRBEL_TODO
+ -- info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <>
+ -- ppr modL)) return $
+ -- M.lookup (moduleName modL) infos
+ info <- maybe (throwE undefined) return $
+ M.lookup (moduleName modL) infos
let all_names = modInfo_rdrs info
- maybe (throwE "No matching export in any local modules.") return $
+ maybe (throwE GhciNoMatchingModuleExport) return $
find (matchName name) all_names
where
matchName :: Name -> Name -> Bool
@@ -218,12 +219,12 @@ findType :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
- -> ExceptT SDoc m (ModInfo, Type)
+ -> ExceptT GhciCommandMessage m (ModInfo, Type)
findType infos span0 string = do
- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
+ name <- maybeToExceptT GhciNoModuleNameGuess $
guessModule infos (srcSpanFilePath span0)
- info <- maybeToExceptT "No module info for current file! Try loading it?" $
+ info <- maybeToExceptT GhciNoModuleInfoForCurrentFile $
MaybeT $ pure $ M.lookup name infos
case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -24,9 +24,7 @@ module GHCi.UI.Monad (
runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
ActionStats(..), runAndPrintStats, runWithStats, printStats,
- printForUserNeverQualify,
- printForUserGlobalRdrEnv,
- printForUser, printForUserPartWay, prettyLocations,
+ prettyLocations,
compileGHCiExpr,
initInterpBuffering,
@@ -42,7 +40,6 @@ import GHC.Driver.Monad hiding (liftIO)
import GHC.Utils.Outputable
import qualified GHC.Driver.Ppr as Ppr
import GHC.Types.Name.Occurrence
-import GHC.Types.Name.Reader
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Driver.Env
@@ -51,12 +48,10 @@ import GHC.Types.SafeHaskell
import GHC.Driver.Make (ModIfaceCache(..))
import GHC.Unit
import GHC.Types.Name.Reader as RdrName (mkOrig)
-import qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx)
import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)
import GHC.Runtime.Interpreter
import GHC.Runtime.Context
import GHCi.RemoteTypes
-import GHCi.UI.Exception (printGhciException)
import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
import GHC.Hs.Utils
import GHC.Utils.Misc
@@ -82,6 +77,8 @@ import qualified Data.IntMap.Strict as IntMap
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.LanguageExtensions as LangExt
+import GHCi.UI.Print
+
-----------------------------------------------------------------------------
-- GHCi monad
@@ -155,9 +152,6 @@ data GHCiState = GHCiState
-- "import Prelude hiding (map)"
ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)
-
- short_help :: String,
- -- ^ help text to display to a user
long_help :: String,
lastErrorLocations :: IORef [(FastString, Int)],
@@ -360,36 +354,6 @@ unsetOption opt
= do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) })
-printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
-printForUserNeverQualify doc = do
- dflags <- GHC.getInteractiveDynFlags
- liftIO $ Ppr.printForUser dflags stdout neverQualify AllTheWay doc
-
-printForUserGlobalRdrEnv :: (GhcMonad m, Outputable info)
- => Maybe (GlobalRdrEnvX info) -> SDoc -> m ()
-printForUserGlobalRdrEnv mb_rdr_env doc = do
- dflags <- GHC.getInteractiveDynFlags
- name_ppr_ctx <- mkNamePprCtxFromGlobalRdrEnv dflags mb_rdr_env
- liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx AllTheWay doc
- where
- mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
- mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
- let unit_env = hsc_unit_env hsc_env
- ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
-
-printForUser :: GhcMonad m => SDoc -> m ()
-printForUser doc = do
- name_ppr_ctx <- GHC.getNamePprCtx
- dflags <- GHC.getInteractiveDynFlags
- liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx AllTheWay doc
-
-printForUserPartWay :: GhcMonad m => SDoc -> m ()
-printForUserPartWay doc = do
- name_ppr_ctx <- GHC.getNamePprCtx
- dflags <- GHC.getInteractiveDynFlags
- liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx DefaultDepth doc
-- | Run a single Haskell expression
runStmt
=====================================
ghc/GHCi/UI/Print.hs
=====================================
@@ -0,0 +1,85 @@
+module GHCi.UI.Print
+ ( printForUserNeverQualify
+ , printForUserGlobalRdrEnv
+ , printForUser
+ , printForUserPartWay
+ , printError -- TODO
+ , printGhciException
+ ) where
+
+import qualified GHC
+import GHC.Types.Name.Reader
+import GHC.Types.SourceError
+import GHC.Types.SrcLoc
+import GHC.Types.Error
+import GHC.Driver.Monad
+import GHC.Driver.Env
+import GHC.Driver.Session
+import GHC.Driver.Errors
+import GHC.Driver.Config.Diagnostic
+
+import GHC.Utils.Logger
+import GHC.Utils.Error
+import GHC.Utils.Outputable
+import qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx)
+import qualified GHC.Driver.Ppr as Ppr
+
+import Prelude hiding ((<>))
+import System.IO
+
+import GHCi.UI.Exception
+
+
+printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
+printForUserNeverQualify doc = do
+ dflags <- GHC.getInteractiveDynFlags
+ liftIO $ Ppr.printForUser dflags stdout neverQualify AllTheWay doc
+
+printForUserGlobalRdrEnv :: (GhcMonad m, Outputable info)
+ => Maybe (GlobalRdrEnvX info) -> SDoc -> m ()
+printForUserGlobalRdrEnv mb_rdr_env doc = do
+ dflags <- GHC.getInteractiveDynFlags
+ name_ppr_ctx <- mkNamePprCtxFromGlobalRdrEnv dflags mb_rdr_env
+ liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx AllTheWay doc
+ where
+ mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
+ mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
+ withSession $ \ hsc_env ->
+ let unit_env = hsc_unit_env hsc_env
+ ptc = initPromotionTickContext dflags
+ in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+
+printForUser :: GhcMonad m => SDoc -> m ()
+printForUser doc = do
+ name_ppr_ctx <- GHC.getNamePprCtx
+ dflags <- GHC.getInteractiveDynFlags
+ liftIO $ Ppr.printForUserColoured dflags stdout name_ppr_ctx AllTheWay doc
+
+printForUserPartWay :: GhcMonad m => SDoc -> m ()
+printForUserPartWay doc = do
+ name_ppr_ctx <- GHC.getNamePprCtx
+ dflags <- GHC.getInteractiveDynFlags
+ liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx DefaultDepth doc
+
+printError :: GhcMonad m => GhciCommandMessage -> m ()
+printError err = printError' (const NoDiagnosticOpts) $ singleMessage (mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err)
+
+-- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting
+-- for some error messages.
+printGhciException :: GhcMonad m => SourceError -> m ()
+printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err))
+
+printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m ()
+printError' get_config err = do
+ dflags <- getDynFlags
+ logger <- getLogger
+ let !diag_opts = initDiagOpts dflags
+ !print_config = get_config dflags
+ liftIO $ printMessages logger print_config diag_opts err
+
+
+initGhciPrintConfig :: DynFlags -> GhciMessageOpts
+initGhciPrintConfig dflags = GhciMessageOpts
+ { ghcMessageOpts = initPrintConfig dflags
+ , ghciCommandMessageOpts = NoDiagnosticOpts
+ }
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -68,6 +68,7 @@ Executable ghc
GHCi.UI
GHCi.UI.Info
GHCi.UI.Monad
+ GHCi.UI.Print
GHCi.UI.Exception
GHCi.Util
Other-Extensions:
=====================================
linters/lint-codes/LintCodes/Static.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
@@ -26,7 +27,7 @@ import GHC.Driver.Errors.Types
import GHC.Types.Error
( DiagnosticCode(..) )
import GHC.Types.Error.Codes
- ( constructorCodes )
+ ( GHC, constructorCodes )
-- ghc (API usage)
import GHC
@@ -77,7 +78,7 @@ import Language.Haskell.Syntax.Module.Name
-- | The diagnostic codes that are statically reachable from the
-- 'GhcMessage' datatype.
staticallyUsedCodes :: Map DiagnosticCode String
-staticallyUsedCodes = constructorCodes @GhcMessage
+staticallyUsedCodes = constructorCodes @GHC @GhcMessage
--------------------------------------------------------------------------------
=====================================
linters/lint-codes/Main.hs
=====================================
@@ -67,7 +67,7 @@ listOutdatedCodes famEqnCodes = do
--
-- Assumes we are in a GHC Git tree, as we look at all testsuite .stdout and
-- .stderr files.
-testCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
+testCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
testCodes famEqnCodes = do
------------------------------
=====================================
testsuite/tests/ghci/scripts/T10508.stderr
=====================================
@@ -1,4 +1,3 @@
-
<interactive>:1:15: error: [GHC-83865]
• Couldn't match type: a0 -> a0
with: [Char]
@@ -8,5 +7,8 @@
In the first argument of ‘return’, namely ‘id’
In the expression: return id
In the second argument of ‘(.)’, namely ‘(\ _ -> return id)’
-unknown command ':macro'
-use :? for help.
+
+<interactive>: error: [GHCi-54713]
+ Unknown command ‘:macro’
+ use :? for help
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e738c19d8c366b9779ae8f9e73360431f6222f6...8c1acd064a461c60b248226942845fe704c6b404
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5e738c19d8c366b9779ae8f9e73360431f6222f6...8c1acd064a461c60b248226942845fe704c6b404
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240731/7a34fa59/attachment-0001.html>
More information about the ghc-commits
mailing list