diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for auto-split +## 0.1.0.1 -- 2025-02-08 + +* Improvements to error reporting + ## 0.1.0.0 -- 2025-02-01 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -81,8 +81,10 @@ - A module must pass the type checker for splitting to occur, unless the `-fdefer-type-errors` GHC flag is used. -- Using SPLIT in pattern match will insert patterns for _all_ missing cases in - the group. It doesn't restrict to the position where SPLIT is used. +- Using `SPLIT` in a pattern match will insert patterns for _all_ missing cases + in the group. It doesn't restrict to the position where `SPLIT` is used. +- If the pattern match where `SPLIT` is being used contains a wildcard case + then the plugin will have no effect because there are no missing patterns. - Doesn't work well with the view patterns syntax extension - Doesn't apply to code inside CPP conditional blocks - The plugin only supports certain GHC versions with the intent of supporting diff --git a/auto-split.cabal b/auto-split.cabal --- a/auto-split.cabal +++ b/auto-split.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: auto-split -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Case splitting plugin description: A GHC plugin that performs automatic case splitting license: BSD-3-Clause diff --git a/src/AutoSplit.hs b/src/AutoSplit.hs --- a/src/AutoSplit.hs +++ b/src/AutoSplit.hs @@ -13,10 +13,13 @@ import qualified Data.Generics as Syb import Data.IORef import qualified Data.List as List +#if MIN_VERSION_ghc(9,12,0) import qualified Data.List.NonEmpty as NE +#endif import Data.Maybe import Data.Monoid (Any(..)) import Data.String (IsString, fromString) +import qualified Data.Typeable as Typeable import qualified GHC.Paths as Paths import qualified Language.Haskell.GHC.ExactPrint as EP import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP @@ -58,6 +61,11 @@ , srcCodeLoc = srcSpan } _ -> Right msgEnv + isAutoSplitError msgEnv = + case Ghc.errMsgDiagnostic msgEnv of + Ghc.GhcUnknownMessage (Ghc.UnknownDiagnostic' a) + | Just PatternSplitDiag <- Typeable.cast a -> True + _ -> False runPhaseOrExistingHook :: Ghc.TPhase res -> IO res runPhaseOrExistingHook = maybe Ghc.runPhase (\(Ghc.PhaseHook h) -> h) mExistingHook case tPhase of @@ -65,39 +73,53 @@ usedGres <- readIORef $ Ghc.tcg_used_gres gblEnv let usesSplit = any ((== splitName) . Ghc.occNameFS . Ghc.occName . Ghc.gre_name) usedGres mFilePath = Ghc.ml_hs_file (Ghc.ms_location modSum) - if not usesSplit - then runPhaseOrExistingHook tPhase - else do - let customError = - Ghc.mkPlainErrorMsgEnvelope - (maybe Ghc.noSrcSpan (Ghc.mkGeneralSrcSpan . fromString) mFilePath) - (Ghc.ghcUnknownMessage PatternSplitDiag) - warnsWithError = Ghc.addMessage customError warns - -- Plugin only functions if incomplete patterns warning is enabled, so we force it on. - updEnv = env - -- Plugin only functions if incomplete patterns warning is enabled, so we force it on. - -- If this is instead done as driver plugin, ghci sessions won't pick it up. - { Ghc.hsc_dflags = (Ghc.hsc_dflags env `Ghc.wopt_set` Ghc.Opt_WarnIncompletePatterns) - -- Need to override the number of uncovered patterns reported. - { Ghc.maxUncoveredPatterns = maxBound - 1 } - } - catch - (runPhaseOrExistingHook $ Ghc.T_HscPostTc updEnv modSum tcResult warnsWithError mOldHash) - (\(Ghc.SourceError msgs) -> do - let (missingPatWarns, otherWarns) = Ghc.partitionBagWith isMissingPatWarn (Ghc.getMessages msgs) - -- Need to parse the module because GHC removes - -- ParsedResult from ModSummary after the frontend finishes. - -- Use the options from compilation to parse the module, otherwise certain - -- syntax extensions won't parse correctly. - dynFlags = Ghc.ms_hspp_opts modSum `Ghc.gopt_set` Ghc.Opt_KeepRawTokenStream - eResult <- traverse (parseModule env dynFlags) mFilePath - case eResult of - Just (Right parsedMod, usesCpp) -> do - let gblRdrEnv = Ghc.tcg_rdr_env gblEnv - traverse_ (modifyModule gblRdrEnv parsedMod usesCpp missingPatWarns) mFilePath - _ -> pure () - throw . Ghc.SourceError $ Ghc.mkMessages otherWarns - ) + case mFilePath of + Just filePath | usesSplit -> do + let patSplitErr = + Ghc.mkPlainErrorMsgEnvelope + (Ghc.mkGeneralSrcSpan $ fromString filePath) + (Ghc.ghcUnknownMessage PatternSplitDiag) + noMissingPatErr = + Ghc.mkPlainErrorMsgEnvelope + (Ghc.mkGeneralSrcSpan $ fromString filePath) + (Ghc.ghcUnknownMessage NoMissingPat) + parseFailedErr = + Ghc.mkPlainErrorMsgEnvelope + (Ghc.mkGeneralSrcSpan $ fromString filePath) + (Ghc.ghcUnknownMessage ParseFailed) + warnsWithError = Ghc.addMessage patSplitErr warns + updEnv = env + -- Plugin only functions if incomplete patterns warning is enabled, so we force it on. + -- If this is instead done as driver plugin, ghci sessions won't pick it up. + { Ghc.hsc_dflags = (Ghc.hsc_dflags env `Ghc.wopt_set` Ghc.Opt_WarnIncompletePatterns) + -- Need to override the number of uncovered patterns reported. + { Ghc.maxUncoveredPatterns = maxBound - 1 } + } + catch + (runPhaseOrExistingHook $ Ghc.T_HscPostTc updEnv modSum tcResult warnsWithError mOldHash) + (\(Ghc.SourceError msgs) -> do + let (missingPatWarns, otherDiags) = Ghc.partitionBagWith isMissingPatWarn (Ghc.getMessages msgs) + -- Need to parse the module because GHC removes + -- ParsedResult from ModSummary after the frontend finishes. + -- Use the options from compilation to parse the module, otherwise certain + -- syntax extensions won't parse correctly. + dynFlags = Ghc.ms_hspp_opts modSum `Ghc.gopt_set` Ghc.Opt_KeepRawTokenStream + eResult <- parseModule env dynFlags filePath + case eResult of + (Right parsedMod, usesCpp) + | not (null missingPatWarns) -> do + let gblRdrEnv = Ghc.tcg_rdr_env gblEnv + modifyModule gblRdrEnv parsedMod usesCpp missingPatWarns filePath + throw . Ghc.SourceError $ Ghc.mkMessages otherDiags + | otherwise -> throw . Ghc.SourceError . Ghc.mkMessages + . Ghc.consBag noMissingPatErr + $ Ghc.filterBag (not . isAutoSplitError) otherDiags + (Left _, _) -> + throw . Ghc.SourceError . Ghc.mkMessages + . Ghc.consBag parseFailedErr + $ Ghc.filterBag (not . isAutoSplitError) otherDiags + ) + _ -> runPhaseOrExistingHook tPhase -- no SPLIT or no file path _ -> runPhaseOrExistingHook tPhase -- | Parse the given module file. Accounts for CPP comments @@ -152,6 +174,34 @@ type DiagnosticOpts PatternSplitDiag = Ghc.NoDiagnosticOpts diagnosticMessage _ _ = Ghc.mkSimpleDecorated $ Ghc.text "Module updated by auto-split, compilation aborted" + diagnosticReason _ = Ghc.ErrorWithoutFlag + diagnosticHints _ = [] + diagnosticCode _ = Nothing +#if !MIN_VERSION_ghc(9,8,0) + defaultDiagnosticOpts = Ghc.NoDiagnosticOpts +#endif + +-- | Diagnostic thrown when SPLIT is used but there are no resulting warnings +data NoMissingPat = NoMissingPat + +instance Ghc.Diagnostic NoMissingPat where + type DiagnosticOpts NoMissingPat = Ghc.NoDiagnosticOpts + diagnosticMessage _ _ = Ghc.mkSimpleDecorated $ + Ghc.text "Module was not updated because all cases are already covered where SPLIT occurs" + diagnosticReason _ = Ghc.ErrorWithoutFlag + diagnosticHints _ = [] + diagnosticCode _ = Nothing +#if !MIN_VERSION_ghc(9,8,0) + defaultDiagnosticOpts = Ghc.NoDiagnosticOpts +#endif + +-- | Diagnostic thrown if the module fails to parse +data ParseFailed = ParseFailed + +instance Ghc.Diagnostic ParseFailed where + type DiagnosticOpts ParseFailed = Ghc.NoDiagnosticOpts + diagnosticMessage _ _ = Ghc.mkSimpleDecorated $ + Ghc.text "auto-split failed to parse the module" diagnosticReason _ = Ghc.ErrorWithoutFlag diagnosticHints _ = [] diagnosticCode _ = Nothing diff --git a/src/AutoSplit/GhcFacade.hs b/src/AutoSplit/GhcFacade.hs --- a/src/AutoSplit/GhcFacade.hs +++ b/src/AutoSplit/GhcFacade.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} module AutoSplit.GhcFacade ( module Ghc , mkParPat' @@ -16,6 +18,7 @@ , greToName , noLocCpp , noExtFieldCpp + , pattern UnknownDiagnostic' ) where #if MIN_VERSION_ghc(9,8,0) @@ -59,6 +62,7 @@ #if !MIN_VERSION_ghc(9,10,0) import Data.Maybe #endif +import Data.Typeable import qualified Language.Haskell.GHC.ExactPrint as EP mkParPat' :: Ghc.LPat Ghc.GhcPs -> Ghc.Pat Ghc.GhcPs @@ -275,4 +279,16 @@ #else noExtFieldCpp :: Ghc.EpAnn a noExtFieldCpp = Ghc.noAnn +#endif + +pattern UnknownDiagnostic' + :: () + => (Ghc.Diagnostic a, Typeable a) + => a +#if MIN_VERSION_ghc(9,8,0) + -> Ghc.UnknownDiagnostic opts +pattern UnknownDiagnostic' a <- Ghc.UnknownDiagnostic _ a +#else + -> Ghc.UnknownDiagnostic +pattern UnknownDiagnostic' a <- Ghc.UnknownDiagnostic a #endif diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -30,6 +30,7 @@ #endif , testCase "17" $ runTest "Case17.hs" , testCase "18" $ runTest "Case18.hs" + , testCase "19" $ runTest "Case19.hs" ] , testGroup "lambda case" [ testCase "1" $ runTest "LambdaCase1.hs" @@ -44,6 +45,7 @@ , testCase "3" $ runTest "Fun3.hs" , testCase "4" $ runTest "Fun4.hs" , testCase "5" $ runTest "Fun5.hs" + , testCase "6" $ runTest "Fun6.hs" ] ]