auto-split 0.1.0.0 → 0.1.0.1

raw patch · 6 files changed

+110/−36 lines, 6 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +4/−2
• auto-split.cabal +1/−1
• src/AutoSplit.hs +83/−33
• src/AutoSplit/GhcFacade.hs +16/−0
• test/Main.hs +2/−0

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"     ]   ]