Refactor: Extract additional Prisms/Lenses into a common module

Author: sgillespie

ghcide/src/Development/IDE/GHC/Compat/Error.hs

@@ -17,16 +17,24 @@ module Development.IDE.GHC.Compat.Error (
   DriverMessage (..),
   -- * General Diagnostics
   Diagnostic(..),
-  -- * Prisms for error selection
+  -- * Prisms and lenses for error selection
   _TcRnMessage,
   _TcRnMessageWithCtx,
   _GhcPsMessage,
   _GhcDsMessage,
   _GhcDriverMessage,
   _TcRnMissingSignature,
+  _TcRnSolverReport,
+  _TcRnMessageWithInfo,
+  reportContextL,
+  reportContentL,
+  _MismatchMessage,
+  _TypeEqMismatchActual,
+  _TypeEqMismatchExpected,
   ) where
 
 import           Control.Lens
+import           Development.IDE.GHC.Compat (Type)
 import           GHC.Driver.Errors.Types
 import           GHC.HsToCore.Errors.Types
 import           GHC.Tc.Errors.Types
@@ -82,3 +90,36 @@ msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
 msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )
 
 makePrisms ''TcRnMessage
+
+makeLensesWith
+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
+    ''SolverReportWithCtxt
+
+-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be
+-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors.
+_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg
+_MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg
+_MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg
+_MismatchMessage _ report = pure report
+
+-- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'.
+_TypeEqMismatchExpected :: Traversal' MismatchMsg Type
+#if MIN_VERSION_ghc(9,12,0)
+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) =
+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
+#else
+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) =
+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
+#endif
+_TypeEqMismatchExpected _ mismatch = pure mismatch
+
+-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'.
+_TypeEqMismatchActual :: Traversal' MismatchMsg Type
+#if MIN_VERSION_ghc(9,12,0)
+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) =
+    (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual
+#else
+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) =
+    (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual
+#endif
+_TypeEqMismatchActual _ mismatch = pure mismatch

plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs

@@ -29,17 +29,19 @@ import           Development.IDE                   (FileDiagnostic,
 import           Development.IDE.Core.PluginUtils
 import           Development.IDE.Core.RuleTypes    (GetParsedModule (GetParsedModule))
 import           Development.IDE.GHC.Compat        hiding (vcat)
-import           Development.IDE.GHC.Compat.Error  (_TcRnMessageWithCtx,
-                                                    msgEnvelopeErrorL)
+import           Development.IDE.GHC.Compat.Error  (_MismatchMessage,
+                                                    _TcRnMessageWithCtx,
+                                                    _TcRnMessageWithInfo,
+                                                    _TcRnSolverReport,
+                                                    _TypeEqMismatchActual,
+                                                    _TypeEqMismatchExpected,
+                                                    msgEnvelopeErrorL,
+                                                    reportContentL)
 import           Development.IDE.GHC.Util          (printOutputable)
 import           Development.IDE.Types.Diagnostics (_SomeStructuredMessage)
 import           Generics.SYB                      (extQ, something)
 import           GHC.Tc.Errors.Types               (ErrInfo (..),
-                                                    MismatchMsg (..),
-                                                    SolverReportWithCtxt (..),
-                                                    TcRnMessage (..),
-                                                    TcRnMessageDetailed (..),
-                                                    TcSolverReportMsg (..))
+                                                    TcRnMessageDetailed (..))
 import qualified Ide.Logger                        as Logger
 import           Ide.Plugin.Error                  (PluginError,
                                                     getNormalizedFilePathE)
@@ -138,8 +140,8 @@ diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do
     (expectedType, actualType, errInfo) <- hoistMaybe $ do
         msg <- diagnostic ^. fdStructuredMessageL ^? _SomeStructuredMessage
         tcRnMsg <- msg ^. msgEnvelopeErrorL ^? _TcRnMessageWithCtx
-        TcRnMessageDetailed errInfo tcRnMsg' <- tcRnMsg ^? _TcRnMessageDetailed
-        solverReport <- tcRnMsg' ^? _TcRnSolverReport . tcSolverReportMsgL
+        (_, TcRnMessageDetailed errInfo tcRnMsg') <- tcRnMsg ^? _TcRnMessageWithInfo
+        solverReport <- tcRnMsg' ^? _TcRnSolverReport . _1 . reportContentL
         mismatch <- solverReport ^? _MismatchMessage
         expectedType <- mismatch ^? _TypeEqMismatchExpected
         actualType <- mismatch ^? _TypeEqMismatchActual
@@ -164,49 +166,6 @@ diagnosticToChangeSig recorder decls diagnostic = runMaybeT $ do
         showType :: Type -> Text
         showType = T.pack . showSDocUnsafe . pprTidiedType
 
-_TcRnMessageDetailed :: Traversal' TcRnMessage TcRnMessageDetailed
-_TcRnMessageDetailed focus (TcRnMessageWithInfo errInfo detailed) =
-    (\detailed' -> TcRnMessageWithInfo errInfo detailed') <$> focus detailed
-_TcRnMessageDetailed _ msg = pure msg
-
-_TcRnSolverReport :: Traversal' TcRnMessage SolverReportWithCtxt
-#if MIN_VERSION_ghc(9,10,0)
-_TcRnSolverReport focus (TcRnSolverReport report reason) =
-    (\report' -> TcRnSolverReport report' reason) <$> focus report
-#else
-_TcRnSolverReport focus (TcRnSolverReport report reason hints) =
-    (\report' -> TcRnSolverReport report' reason hints) <$> focus report
-#endif
-_TcRnSolverReport _ msg = pure msg
-
-tcSolverReportMsgL :: Lens' SolverReportWithCtxt TcSolverReportMsg
-tcSolverReportMsgL = lens reportContent (\report content' -> report { reportContent = content' })
-
-_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg
-_MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg
-_MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg
-_MismatchMessage _ report = pure report
-
-_TypeEqMismatchExpected :: Traversal' MismatchMsg Type
-#if MIN_VERSION_ghc(9,12,0)
-_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) =
-    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
-#else
-_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) =
-    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
-#endif
-_TypeEqMismatchExpected _ mismatch = pure mismatch
-
-_TypeEqMismatchActual :: Traversal' MismatchMsg Type
-#if MIN_VERSION_ghc(9,12,0)
-_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) =
-    (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual
-#else
-_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) =
-    (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual
-#endif
-_TypeEqMismatchActual _ mismatch = pure mismatch
-
 -- | If a diagnostic has the proper message create a ChangeSignature from it
 matchingDiagnostic :: ErrInfo -> Maybe DeclName
 matchingDiagnostic ErrInfo{errInfoContext} =