auto-split 0.1.0.3 → 0.1.0.4
raw patch · 10 files changed
+663/−358 lines, 10 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ AutoSplit: instance GHC.Types.Error.Diagnostic AutoSplit.ImproperUse
+ AutoSplit.Pattern: pattern FIELDS :: a -> a
Files
- CHANGELOG.md +4/−0
- README.md +15/−0
- auto-split.cabal +4/−1
- src/AutoSplit.hs +111/−355
- src/AutoSplit/Fields.hs +120/−0
- src/AutoSplit/GhcFacade.hs +24/−1
- src/AutoSplit/Pattern.hs +9/−1
- src/AutoSplit/Shared.hs +67/−0
- src/AutoSplit/Split.hs +303/−0
- test/Main.hs +6/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for auto-split +## 0.1.0.4 -- 2025-03-29++* Add FIELDS pattern for autocompletion of missing record fields+ ## 0.1.0.3 -- 2025-03-04 * Remove unnecessary parens for lambda case patterns
README.md view
@@ -78,6 +78,21 @@ been updated. This is done by having GHC emit a custom error. This error does not indicate that something went wrong. +### Bonus feature: Automatic record field enumeration++Using `FIELDS` with an incomplete record initialization will result in the+missing fields being added. For example, compiling this module++```haskell+mkFoo = FIELDS Foo { }+```++will result in++```haskell+mkFoo = Foo { field1 :: _, field2 :: _ }+```+ ### Known limitations - A module must pass the type checker for splitting to occur, unless the
auto-split.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: auto-split-version: 0.1.0.3+version: 0.1.0.4 synopsis: Case splitting plugin description: A GHC plugin that performs automatic case splitting license: BSD-3-Clause@@ -26,6 +26,9 @@ exposed-modules: AutoSplit AutoSplit.Pattern other-modules: AutoSplit.GhcFacade+ AutoSplit.Shared+ AutoSplit.Fields+ AutoSplit.Split -- other-extensions: build-depends: base <5, ghc >=9.6 && <9.13,
src/AutoSplit.hs view
@@ -6,27 +6,17 @@ ) where import Control.Exception-import qualified Control.Monad.Trans.Writer.CPS as Writer-import qualified Data.Char as Char-import Data.Foldable import Data.Functor-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 import qualified Language.Haskell.GHC.ExactPrint.Utils as EP-import Text.Read (readMaybe) +import qualified AutoSplit.Fields as Fields import qualified AutoSplit.GhcFacade as Ghc+import qualified AutoSplit.Split as Split plugin :: Ghc.Plugin plugin = Ghc.defaultPlugin@@ -55,39 +45,58 @@ case Ghc.errMsgDiagnostic msgEnv of Ghc.GhcDsMessage (Ghc.DsNonExhaustivePatterns _ _ _ patIds nablas) | Just srcSpan <- Ghc.srcSpanToRealSrcSpan (Ghc.errMsgSpan msgEnv) ->- Left NonExhaustivePatterns- { patternIds = patIds- , patternNablas = nablas- , srcCodeLoc = srcSpan+ Left Split.NonExhaustivePatterns+ { Split.patternIds = patIds+ , Split.patternNablas = nablas+ , Split.srcCodeLoc = srcSpan } _ -> Right msgEnv+ isMissingFieldsErr msgEnv =+ case Ghc.errMsgDiagnostic msgEnv of+ Ghc.GhcTcRnMessage (Ghc.TcRnMessageWithInfo _ (Ghc.TcRnMessageDetailed _ (Ghc.TcRnMissingFields conLike _fields)))+ | Just srcSpan <- Ghc.srcSpanToRealSrcSpan (Ghc.errMsgSpan msgEnv) ->+ Left Fields.MissingFields+ { Fields.conLike = conLike+ , Fields.srcCodeLoc = srcSpan+ }+ Ghc.GhcTcRnMessage (Ghc.TcRnMessageWithInfo _ (Ghc.TcRnMessageDetailed _ (Ghc.TcRnMissingStrictFields conLike _fields)))+ | Just srcSpan <- Ghc.srcSpanToRealSrcSpan (Ghc.errMsgSpan msgEnv) ->+ Left Fields.MissingFields+ { Fields.conLike = conLike+ , Fields.srcCodeLoc = srcSpan+ }+ _ -> Right msgEnv isAutoSplitError msgEnv = case Ghc.errMsgDiagnostic msgEnv of Ghc.GhcUnknownMessage (Ghc.UnknownDiagnostic' a) | Just PatternSplitDiag <- Typeable.cast a -> True _ -> False+ parseFailedErr filePath =+ Ghc.mkPlainErrorMsgEnvelope+ (Ghc.mkGeneralSrcSpan $ fromString filePath)+ (Ghc.ghcUnknownMessage ParseFailed)+ patSplitErr filePath =+ Ghc.mkPlainErrorMsgEnvelope+ (Ghc.mkGeneralSrcSpan $ fromString filePath)+ (Ghc.ghcUnknownMessage PatternSplitDiag)+ improperUseErr filePath =+ Ghc.mkPlainErrorMsgEnvelope+ (Ghc.mkGeneralSrcSpan $ fromString filePath)+ (Ghc.ghcUnknownMessage ImproperUse) runPhaseOrExistingHook :: Ghc.TPhase res -> IO res runPhaseOrExistingHook = maybe Ghc.runPhase (\(Ghc.PhaseHook h) -> h) mExistingHook case tPhase of Ghc.T_HscPostTc env modSum tcResult@(Ghc.FrontendTypecheck gblEnv) warns mOldHash -> do usedGres <- readIORef $ Ghc.tcg_used_gres gblEnv- let usesSplit = any ((== splitName) . Ghc.occNameFS . Ghc.occName . Ghc.gre_name) usedGres+ let usesSplit = any ((== Split.splitName) . Ghc.occNameFS . Ghc.occName . Ghc.gre_name) usedGres mFilePath = Ghc.ml_hs_file (Ghc.ms_location modSum) case mFilePath of Just filePath | usesSplit -> do- let patSplitErr =- Ghc.mkPlainErrorMsgEnvelope- (Ghc.mkGeneralSrcSpan $ fromString filePath)- (Ghc.ghcUnknownMessage PatternSplitDiag)- noMissingPatErr =+ let 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+ warnsWithError = Ghc.addMessage (patSplitErr filePath) 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.@@ -109,17 +118,75 @@ (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+ updated <- Split.modifyModule gblRdrEnv parsedMod usesCpp missingPatWarns filePath+ if updated+ then throw . Ghc.SourceError $ Ghc.mkMessages otherDiags+ else throw . Ghc.SourceError . Ghc.mkMessages+ . Ghc.consBag (improperUseErr filePath)+ $ Ghc.filterBag (not . isAutoSplitError) 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.consBag (parseFailedErr filePath) $ Ghc.filterBag (not . isAutoSplitError) otherDiags ) _ -> runPhaseOrExistingHook tPhase -- no SPLIT or no file path++ -- Missing fields+ Ghc.T_Hsc env modSum -> do+ gblEnvRef <- newIORef Nothing :: IO (IORef (Maybe Ghc.TcGblEnv))+ let rnPlugin =+ Ghc.defaultPlugin+ { Ghc.renamedResultAction = \_ gblEnv group -> do+ Ghc.liftIO $ writeIORef gblEnvRef (Just gblEnv)+ pure (gblEnv, group)+ }+ staticPlugin = Ghc.StaticPlugin+ { Ghc.spPlugin = Ghc.PluginWithArgs rnPlugin []+#if MIN_VERSION_ghc(9,12,0)+ , Ghc.spInitialised = True+#endif+ }+ envWithPlugin = env+ { Ghc.hsc_plugins = let ps = Ghc.hsc_plugins env in ps+ { Ghc.staticPlugins = staticPlugin : Ghc.staticPlugins ps }+ }+ eTcRes <- try . runPhaseOrExistingHook $ Ghc.T_Hsc envWithPlugin modSum+ let msgs = case eTcRes of+ Right (_res, m) -> m+ Left (Ghc.SourceError m) -> m+ result = case eTcRes of+ Right res -> pure res+ Left err -> throw err+ mGblEnv <- readIORef gblEnvRef+ case mGblEnv of+ Nothing -> result -- renaming failed+ Just gblEnv -> do+ usedGres <- readIORef $ Ghc.tcg_used_gres gblEnv+ let usesFields = any ((== Fields.fieldsName) . Ghc.occNameFS . Ghc.occName . Ghc.gre_name) usedGres+ mFilePath = Ghc.ml_hs_file (Ghc.ms_location modSum)+ (missingFields, otherDiags) = Ghc.partitionBagWith isMissingFieldsErr (Ghc.getMessages msgs)+ case mFilePath of+ Just filePath | usesFields, not (null missingFields) -> do+ -- Parse module+ let dynFlags = Ghc.ms_hspp_opts modSum `Ghc.gopt_set` Ghc.Opt_KeepRawTokenStream+ eParseRes <- parseModule env dynFlags filePath+ case eParseRes of+ (Right parsedMod, usesCpp) -> do+ let gblRdrEnv = Ghc.tcg_rdr_env gblEnv+ updated <- Fields.modifyModule gblRdrEnv parsedMod usesCpp missingFields filePath+ if updated+ then throw . Ghc.SourceError . Ghc.mkMessages+ $ Ghc.consBag (patSplitErr filePath) otherDiags+ else throw . Ghc.SourceError . Ghc.mkMessages+ $ Ghc.consBag (improperUseErr filePath) otherDiags+ (Left _, _) ->+ throw . Ghc.SourceError . Ghc.mkMessages+ $ Ghc.consBag (parseFailedErr filePath) otherDiags+ _ -> result -- no FIELDS or no file path+ _ -> runPhaseOrExistingHook tPhase -- | Parse the given module file. Accounts for CPP comments@@ -142,31 +209,6 @@ , hasCpp ) --- | Applies pattern split transformation and updates the module file.-modifyModule- :: Ghc.GlobalRdrEnv- -> Ghc.ParsedSource- -> Bool- -> Ghc.Bag NonExhaustivePatterns- -> FilePath- -> IO ()-modifyModule gblRdrEnv parsedMod usesCpp missingPatWarns filePath = do- let ast = EP.makeDeltaAst- $ searchAndMark (Ghc.bagToList missingPatWarns) parsedMod- case splitPattern gblRdrEnv (Ghc.bagToList missingPatWarns) ast of- (ps, Any True) ->- -- If the source contains CPP, newlines are appended- -- to the end of the file when exact printing. The simple- -- solution is to remove trailing newlines after exact printing- -- if the source contains CPP comments.- let removeTrailingNewlines- | usesCpp =- reverse . ('\n' :) . dropWhile (== '\n') . reverse- | otherwise = id- printed = removeTrailingNewlines $ EP.exactPrint ps- in writeFile filePath printed- _ -> pure ()- -- | Diagnostic thrown when case splitting should be attempted. data PatternSplitDiag = PatternSplitDiag @@ -195,6 +237,20 @@ defaultDiagnosticOpts = Ghc.NoDiagnosticOpts #endif +-- | Diagnostic thrown when SPLIT is used but there are no resulting warnings+data ImproperUse = ImproperUse++instance Ghc.Diagnostic ImproperUse where+ type DiagnosticOpts ImproperUse = Ghc.NoDiagnosticOpts+ diagnosticMessage _ _ = Ghc.mkSimpleDecorated $+ Ghc.text "It appears that an auto-split pattern was used improperly. The module has not been updated."+ 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 @@ -209,285 +265,6 @@ defaultDiagnosticOpts = Ghc.NoDiagnosticOpts #endif -data NonExhaustivePatterns = NonExhaustivePatterns- { patternIds :: [Ghc.Id]- , patternNablas :: [Ghc.Nabla]- , srcCodeLoc :: Ghc.RealSrcSpan- }---- | Before applying delta transformation, find the expressions that go with--- non exhaustive patterns and mark them with a special comment containing the--- index of that pattern. This must be done first because source code locations--- are removed by delta transformation.--- Problematic if delta moves comments to a different node, hopefully it won't.-searchAndMark- :: [NonExhaustivePatterns]- -> Ghc.ParsedSource- -> Ghc.ParsedSource-searchAndMark nePats =- Syb.everywhere (Syb.mkT goExpr `Syb.extT` goDecl `Syb.extT` goBind)- where- goExpr :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs- goExpr (Ghc.L ann c@Ghc.HsCase{})- | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann- , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats- = Ghc.L (addIndexComment ann neIdx) c-#if MIN_VERSION_ghc(9,10,0)- goExpr (Ghc.L ann l@(Ghc.HsLam _ lamType _))- | lamType /= Ghc.LamSingle- , Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann- , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats- = Ghc.L (addIndexComment ann neIdx) l-#elif MIN_VERSION_ghc(9,6,0)- goExpr (Ghc.L ann l@(Ghc.HsLamCase _ _ _))- | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann- , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats- = Ghc.L (addIndexComment ann neIdx) l-#endif- goExpr x = x-- goDecl :: Ghc.LHsDecl Ghc.GhcPs -> Ghc.LHsDecl Ghc.GhcPs- goDecl (Ghc.L ann f@(Ghc.ValD _ Ghc.FunBind{}))- | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann- , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats- = Ghc.L (addIndexComment ann neIdx) f- goDecl x = x-- goBind :: Ghc.LHsBind Ghc.GhcPs -> Ghc.LHsBind Ghc.GhcPs- goBind (Ghc.L ann f@Ghc.FunBind{})- | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann- , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats- = Ghc.L (addIndexComment ann neIdx) f- goBind x = x-- addIndexComment ann neIdx =- let com :: Ghc.LEpaComment- com = Ghc.L Ghc.fakeCommentLocation- (Ghc.EpaComment (Ghc.EpaLineComment (show neIdx)) Ghc.placeholderRealSpan)- newComms = case Ghc.getComments ann of- Ghc.EpaComments cs -> Ghc.EpaComments $ com : cs- Ghc.EpaCommentsBalanced cs1 cs2 -> Ghc.EpaCommentsBalanced (com : cs1) cs2- in Ghc.setComments newComms mempty ann---- | Finds the target pattern and splits it. Returns the modified source and True if successful.--- Applied post delta transformation.-splitPattern- :: Ghc.GlobalRdrEnv- -> [NonExhaustivePatterns]- -> Ghc.ParsedSource- -> (Ghc.ParsedSource, Any)-splitPattern gblRdrEnv nePats ps =- Writer.runWriter $- Syb.everywhereM- ( Syb.mkM (Writer.writer . goExpr)- `Syb.extM` (Writer.writer . goDecl)- `Syb.extM` (Writer.writer . goBind)- ) ps- where- isIdxComment (Ghc.L _ (Ghc.EpaComment (Ghc.EpaLineComment str) realSpan))- = realSpan == Ghc.placeholderRealSpan && all Char.isDigit str- isIdxComment _ = False-- extractIdxComment (Ghc.EpaComments comms)- | (before, Ghc.L _ (Ghc.EpaComment (Ghc.EpaLineComment str) _) : rest)- <- break isIdxComment comms- , Just idx <- readMaybe str- , let newComments = Ghc.EpaComments $ before ++ rest- = Just (idx, newComments)- extractIdxComment Ghc.EpaCommentsBalanced{} = Nothing- extractIdxComment _ = Nothing-- goExpr :: Ghc.LHsExpr Ghc.GhcPs -> (Ghc.LHsExpr Ghc.GhcPs, Any)- goExpr (Ghc.L ann (Ghc.HsCase x scrut matchGroup))- | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)- , Just nePat <- listToMaybe $ drop neIdx nePats- , Just newMG <- splitMG gblRdrEnv False False 0 nePat matchGroup- = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.HsCase x scrut newMG)- , Any True- )-#if MIN_VERSION_ghc(9,10,0)- goExpr (Ghc.L ann (Ghc.HsLam x lamType matchGroup@(Ghc.MG _ (Ghc.L matchesAnn _))))- | lamType /= Ghc.LamSingle- , Just (neIdx, otherComms) <- extractIdxComment (Ghc.comments ann)- , Just nePat <- nePats List.!? neIdx- , Just newMG <- splitMG gblRdrEnv (lamType == Ghc.LamCases) False (Ghc.colDelta matchesAnn) nePat matchGroup- = ( Ghc.L ann {Ghc.comments = otherComms} (Ghc.HsLam x lamType newMG)- , Any True- )-#elif MIN_VERSION_ghc(9,6,0)- goExpr (Ghc.L ann (Ghc.HsLamCase x lamType matchGroup@(Ghc.MG _ (Ghc.L matchesAnn _))))- | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)- , Just nePat <- listToMaybe $ drop neIdx nePats- , Just newMG <- splitMG gblRdrEnv (lamType == Ghc.LamCases) False (Ghc.colDelta matchesAnn) nePat matchGroup- = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.HsLamCase x lamType newMG)- , Any True- )-#endif- goExpr expr = (expr, Any False)-- goDecl :: Ghc.LHsDecl Ghc.GhcPs -> (Ghc.LHsDecl Ghc.GhcPs, Any)- goDecl (Ghc.L ann (Ghc.ValD x (Ghc.FunBind x2 fid matchGroup)))- | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)- , Just nePat <- listToMaybe $ drop neIdx nePats- , Just newMG <- splitMG gblRdrEnv True True 0 nePat matchGroup- = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.ValD x (Ghc.FunBind x2 fid newMG))- , Any True- )- goDecl decl = (decl, Any False)-- goBind :: Ghc.LHsBind Ghc.GhcPs -> (Ghc.LHsBind Ghc.GhcPs, Any)- goBind (Ghc.L ann (Ghc.FunBind x2 fid matchGroup))- | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)- , Just nePat <- listToMaybe $ drop neIdx nePats- , Just newMG <- splitMG gblRdrEnv True True 0 nePat matchGroup- = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.FunBind x2 fid newMG)- , Any True- )- goBind bind = (bind, Any False)--splitMG- :: Ghc.GlobalRdrEnv- -> Bool -- True => match group can have multiple patterns- -> Bool -- True => add left padding to each new pattern- -> Int -- Number of horizontal spaces at the front of inserted pattern match- -> NonExhaustivePatterns- -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)- -> Maybe (Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs))-splitMG gblRdrEnv multiplePats offsetFirstPat colOffset nePat (Ghc.MG x2 (Ghc.L ann2 matches))- | (beforeSplit, Ghc.L splitAnn targetMatch@(Ghc.Match _ ctx _ rhs) : afterSplit)- <- break matchHasSplit matches- , let mUpdatedMatch = Ghc.L splitAnn <$> removeSplitFromOrPat targetMatch- -- If splitting the first match, trailing matches need to have a delta- -- putting it on a new line- correctDeltas [] = []- correctDeltas (x : xs) | isNothing mUpdatedMatch =- x :- (Ghc.L (Ghc.nextLine colOffset) . Ghc.unLoc- <$> xs)- correctDeltas xs = Ghc.L (Ghc.nextLine colOffset) . Ghc.unLoc <$> xs- newMatches = correctDeltas $ do- nabla <- patternNablas nePat- let pats =- zipWith (mkPat gblRdrEnv nabla $ not multiplePats)- (offsetFirstPat : repeat True)- (patternIds nePat)- [ Ghc.L splitAnn $ Ghc.Match Ghc.noExtFieldCpp ctx (Ghc.noLocCpp pats) rhs ]- removeSplits m =- case traverse removeSplitFromOrPat m of- Nothing -> if matchHasSplit m then Nothing else Just m- Just newM -> Just newM- afterSplitUpdated = mapMaybe removeSplits afterSplit- newMatchGroup- = beforeSplit- ++ maybeToList mUpdatedMatch- ++ newMatches- ++ afterSplitUpdated- = Just $ Ghc.MG x2 (Ghc.L ann2 newMatchGroup)- | otherwise = Nothing--matchHasSplit :: Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> Bool-matchHasSplit (Ghc.L _ (Ghc.Match _ _ pats _)) =- Syb.everything (||) (Syb.mkQ False isSplitCon) pats--isSplitCon :: Ghc.Pat Ghc.GhcPs -> Bool-isSplitCon (Ghc.ConPat _ (Ghc.L _ rdr) _) =- Ghc.rdrNameOcc rdr == Ghc.mkDataOcc splitName-isSplitCon _ = False---- | Remove SPLIT pattern from OrPat groups. Returns Just if the match was modified.-removeSplitFromOrPat- :: Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)- -> Maybe (Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs))-#if MIN_VERSION_ghc(9,12,0)-removeSplitFromOrPat (Ghc.Match a b pats c) =- let mNewPats = Syb.everywhereM (Syb.mkM (Writer.writer . go)) pats- patHasSplit = Syb.everything (||) (Syb.mkQ False isSplitCon)- dropSemicolon ann = ann { Ghc.anns = Ghc.noAnn }- go :: Ghc.Pat Ghc.GhcPs -> (Ghc.Pat Ghc.GhcPs, Any)- go (Ghc.OrPat x oPats) =- case reverse (NE.filter (not . patHasSplit) oPats) of- [] -> (Ghc.WildPat Ghc.noExtField, Any True)- (Ghc.L patAnn lastPat : fPats)- | length fPats + 1 /= NE.length oPats ->- ( Ghc.OrPat x- (NE.reverse $ Ghc.L (dropSemicolon patAnn) lastPat NE.:| fPats)- , Any True)- | otherwise -> (Ghc.OrPat x oPats, Any False)- go other = (other, Any False)- in case Writer.runWriter mNewPats of- (newPats, Any True) -> Just (Ghc.Match a b newPats c)- _ -> Nothing-#else-removeSplitFromOrPat _ = Nothing-#endif---- | Produce a 'Pat' for a missing pattern-mkPat- :: Ghc.GlobalRdrEnv- -> Ghc.Nabla- -> Bool -- ^ True => is a singular pattern which doesn't need outer parens- -> Bool -- ^ True => needs left padding to separate it from another pattern- -> Ghc.Id- -> Ghc.LPat Ghc.GhcPs-mkPat gblRdrEnv nabla isOutermost needsLeftPad x = Ghc.L delta $- case Ghc.lookupSolution nabla x of- Nothing -> Ghc.WildPat Ghc.noExtField- Just (Ghc.PACA (Ghc.PmAltConLike con) _tvs args) -> paren con args $- case Ghc.conLikeIsInfix con of- True | [arg1, arg2] <- args ->- Ghc.ConPat Ghc.noAnn- ( Ghc.L Ghc.nameAnchorD1- . nameToRdrName gblRdrEnv- $ Ghc.conLikeName con- )- $ Ghc.InfixCon (mkPat gblRdrEnv nabla False False arg1)- (mkPat gblRdrEnv nabla False True arg2)- _ | Ghc.RealDataCon dc <- con- , Ghc.isUnboxedTupleDataCon dc- -> Ghc.TuplePat Ghc.parenHashAnns- (addCommaAnns $ zipWith (mkPat gblRdrEnv nabla True) (False : repeat True) args)- Ghc.Unboxed- _ | Ghc.RealDataCon dc <- con- , Ghc.isTupleDataCon dc- -> Ghc.TuplePat Ghc.parenAnns- (addCommaAnns $ zipWith (mkPat gblRdrEnv nabla True) (False : repeat True) args)- Ghc.Boxed- _ ->- -- If GHC tries to use SPLIT as a missing pattern, replace it with wildcard- if Ghc.occName (Ghc.conLikeName con) == Ghc.mkDataOcc splitName- then Ghc.WildPat Ghc.noExtField- else Ghc.ConPat Ghc.noAnn- ( Ghc.L Ghc.nameAnchorD0- . nameToRdrName gblRdrEnv $ Ghc.conLikeName con- )- $ Ghc.PrefixCon [] (mkPat gblRdrEnv nabla False True <$> args)- Just (Ghc.PACA (Ghc.PmAltLit lit) _tvs _args) ->- case Ghc.pm_lit_val lit of- Ghc.PmLitInt integer ->- Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsIntegral $ Ghc.IL (Ghc.SourceText . fromString $ show integer) (integer < 0) integer) Nothing Ghc.noExtField- Ghc.PmLitRat rational ->- Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsFractional $ Ghc.mkTHFractionalLit rational) Nothing Ghc.noExtField- Ghc.PmLitChar char -> Ghc.LitPat Ghc.noExtField $ Ghc.HsChar Ghc.NoSourceText char- Ghc.PmLitString fastString -> Ghc.LitPat Ghc.noExtField $ Ghc.HsString Ghc.NoSourceText fastString- Ghc.PmLitOverInt _minuses integer ->- Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsIntegral $ Ghc.IL (Ghc.SourceText . fromString $ show integer) (integer < 0) integer) Nothing Ghc.noExtField- Ghc.PmLitOverRat _minuses fractionalLit ->- Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsFractional fractionalLit) Nothing Ghc.noExtField- Ghc.PmLitOverString fastString -> Ghc.LitPat Ghc.noExtField $ Ghc.HsString Ghc.NoSourceText fastString- where- delta = if needsLeftPad- then Ghc.anchorD1- else Ghc.anchorD0- paren _ [] inner = inner- paren (Ghc.RealDataCon dc) _ inner | Ghc.isTupleDataCon dc = inner -- No parens for tuple pats- paren _ _ inner =- if not isOutermost- then Ghc.mkParPat' (Ghc.L Ghc.anchorD0 inner)- else inner- addCommaAnns [] = []- addCommaAnns [a] = [a]- addCommaAnns (Ghc.L epAnn a : rest) = Ghc.L (EP.addComma epAnn) a : addCommaAnns rest- -- | Adds the import for SPLIT to the module being compiled. Otherwise users -- would have to manually add this import everytime they want to do pattern splitting. addImport :: Ghc.ParsedResult -> Ghc.ParsedResult@@ -532,27 +309,6 @@ (before, _ : after) -> Ghc.mkMessages . Ghc.listToBag . reverse $ before ++ after _ -> msgs #endif--nameToRdrName :: Ghc.GlobalRdrEnv -> Ghc.Name -> Ghc.RdrName-nameToRdrName rdrEnv n =- case Ghc.lookupOccEnv rdrEnv occName of- Just gres- | Just gre <- find greMatches gres- , rdrName : _ <- Ghc.greRdrNames gre- -> rdrName- Nothing- | not (Ghc.isWiredInName n)- , not (Ghc.isBuiltInSyntax n)- , not (Ghc.isSystemName n)- , not (Ghc.isInternalName n)- -> Ghc.mkRdrQual (Ghc.mkModuleName "NOT_IN_SCOPE") occName- _ -> Ghc.nameRdrName n- where- occName = Ghc.getOccName n- greMatches gre = Ghc.greToName gre == n--splitName :: IsString a => a-splitName = "SPLIT" patternModName :: IsString a => a patternModName = "AutoSplit.Pattern"
+ src/AutoSplit/Fields.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module AutoSplit.Fields+ ( MissingFields(..)+ , modifyModule+ , fieldsName+ ) where++import Control.Monad+import qualified Control.Monad.Trans.Writer.CPS as Writer+import qualified Data.Generics as Syb+import qualified Data.List as List+import Data.Maybe+import Data.Monoid (Any(..))+import Data.String (IsString)+import qualified Language.Haskell.GHC.ExactPrint as EP++import qualified AutoSplit.GhcFacade as Ghc+import AutoSplit.Shared++data MissingFields = MissingFields+ { conLike :: Ghc.ConLike+ , srcCodeLoc :: Ghc.RealSrcSpan+ }++-- | Applies field enumeration transformation and updates the module file.+modifyModule+ :: Ghc.GlobalRdrEnv+ -> Ghc.ParsedSource+ -> Bool+ -> Ghc.Bag MissingFields+ -> FilePath+ -> IO Bool -- ^ True if module was updated+modifyModule gblRdrEnv parsedMod usesCpp missingFields filePath = do+ let ast = EP.makeDeltaAst+ $ searchAndMark (Ghc.bagToList missingFields) parsedMod+ case enumFields gblRdrEnv (Ghc.bagToList missingFields) ast of+ (ps, Any True) ->+ -- If the source contains CPP, newlines are appended+ -- to the end of the file when exact printing. The simple+ -- solution is to remove trailing newlines after exact printing+ -- if the source contains CPP comments.+ let removeTrailingNewlines+ | usesCpp =+ reverse . ('\n' :) . dropWhile (== '\n') . reverse+ | otherwise = id+ printed = removeTrailingNewlines $ EP.exactPrint ps+ in True <$ writeFile filePath printed+ _ -> pure False++searchAndMark+ :: [MissingFields]+ -> Ghc.ParsedSource+ -> Ghc.ParsedSource+searchAndMark missingFields =+ Syb.everywhere (Syb.mkT goExpr)+ where+ goExpr :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+ goExpr (Ghc.L outerAnn+ a@(Ghc.HsApp _+ (Ghc.L _ (Ghc.HsVar _ (Ghc.L _ rdrName)))+ (Ghc.L ann Ghc.RecordCon{}))+ )+ | Ghc.rdrNameOcc rdrName == Ghc.mkDataOcc fieldsName+ , Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann+ , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) missingFields+ = Ghc.L (addIndexComment outerAnn neIdx) a+ goExpr x = x++enumFields+ :: Ghc.GlobalRdrEnv+ -> [MissingFields]+ -> Ghc.ParsedSource+ -> (Ghc.ParsedSource, Any)+enumFields gblRdrEnv missingFields ps =+ Writer.runWriter $+ Syb.everywhereM ( Syb.mkM (Writer.writer . goExpr)) ps+ where+ goExpr :: Ghc.LHsExpr Ghc.GhcPs -> (Ghc.LHsExpr Ghc.GhcPs, Any)+ goExpr (Ghc.L outerAnn+ (Ghc.HsApp _+ (Ghc.L _ (Ghc.HsVar _ _))+ (Ghc.L _ann (Ghc.RecordCon x cLike (Ghc.HsRecFields{..}))))+ )+ | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments outerAnn)+ , Just mf <- listToMaybe $ drop neIdx missingFields+ , let newFields = addMissingFields gblRdrEnv mf rec_flds+ = ( Ghc.L (Ghc.setComments otherComms mempty outerAnn) (Ghc.RecordCon x cLike+ (Ghc.HsRecFields {Ghc.rec_flds = newFields, ..}))+ , Any True+ )+ goExpr x = (x, Any False)++addMissingFields+ :: Ghc.GlobalRdrEnv+ -> MissingFields+ -> [Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]+ -> [Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)]+addMissingFields gblRdrEnv missingFields existing =+ let fieldNames = Ghc.flSelector+ <$> Ghc.conLikeFieldLabels (conLike missingFields) :: [Ghc.Name]+ existingOccNames =+ Ghc.occNameFS . Ghc.rdrNameOcc . Ghc.unLoc . Ghc.foLabel+ . Ghc.unLoc . Ghc.hfbLHS . Ghc.unLoc <$> existing+ toFieldBind :: Ghc.Name -> Maybe (Ghc.LHsRecField Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs))+ toFieldBind name = do+ guard $ Ghc.getOccFS name `notElem` existingOccNames+ Just $ Ghc.noLocA+ Ghc.HsFieldBind+ { Ghc.hfbAnn = Ghc.equalsAnns+ , Ghc.hfbLHS = Ghc.L Ghc.anchorD1 $ Ghc.FieldOcc Ghc.noExtField (Ghc.noLocA $ nameToRdrName gblRdrEnv name)+ , Ghc.hfbRHS = Ghc.L Ghc.anchorD1 $ Ghc.HsVar Ghc.noExtField (Ghc.noLocA . Ghc.mkRdrUnqual $ Ghc.mkVarOcc "_")+ , Ghc.hfbPun = False+ }+ in case reverse existing of+ (r : rs) -> reverse rs ++ addCommaAnns (r : mapMaybe toFieldBind fieldNames)+ _ -> addCommaAnns (mapMaybe toFieldBind fieldNames)++fieldsName :: IsString a => a+fieldsName = "FIELDS"
src/AutoSplit/GhcFacade.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-}@@ -18,6 +20,7 @@ , greToName , noLocCpp , noExtFieldCpp+ , equalsAnns , pattern UnknownDiagnostic' ) where @@ -93,7 +96,12 @@ :: Ghc.NoAnn ann => Ghc.EpAnn ann anchorD1 = Ghc.EpAnn EP.d1 Ghc.noAnn Ghc.emptyComments #elif MIN_VERSION_ghc(9,6,0)- :: Ghc.SrcSpanAnnA+ :: Monoid ann => Ghc.SrcAnn ann++-- blarg+instance Monoid Ghc.NoEpAnns where+ mempty = Ghc.NoEpAnns+ anchorD1 = Ghc.SrcSpanAnn (Ghc.EpAnn@@ -212,6 +220,21 @@ #elif MIN_VERSION_ghc(9,6,0) :: Ghc.Anchor fakeCommentLocation = Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.DifferentLine (-1) 0))+#endif++#if MIN_VERSION_ghc(9,12,0)+equalsAnns :: Maybe (Ghc.EpToken "=")+equalsAnns = Just (Ghc.EpTok EP.d1)+#elif MIN_VERSION_ghc(9,10,0)+equalsAnns :: [Ghc.AddEpAnn]+equalsAnns = [Ghc.AddEpAnn Ghc.AnnEqual EP.d1]+#else+equalsAnns :: Ghc.EpAnn [Ghc.AddEpAnn]+equalsAnns = Ghc.EpAnn+ { Ghc.entry = Ghc.Anchor Ghc.placeholderRealSpan EP.m0+ , Ghc.anns = [ Ghc.AddEpAnn Ghc.AnnEqual EP.d1 ]+ , Ghc.comments = Ghc.emptyComments+ } #endif #if MIN_VERSION_ghc(9,12,0)
src/AutoSplit/Pattern.hs view
@@ -1,8 +1,16 @@ {-# LANGUAGE PatternSynonyms #-} module AutoSplit.Pattern ( pattern SPLIT+ , pattern FIELDS ) where --- | Used to induce the incomplete patterns warning from GHC+-- | Used to induce the incomplete patterns warning from GHC so that the plugin+-- can modify the source code to contain all the missing patterns. pattern SPLIT :: a pattern SPLIT <- _++-- | When applied to a record initialization with missing fields, the plugin+-- will add the missing fields. It must be applied directly to the record+-- initialization, i.e. no parens or use of @$@.+pattern FIELDS :: a -> a+pattern FIELDS a = a
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+module AutoSplit.Shared+ ( isIdxComment+ , extractIdxComment+ , addIndexComment+ , nameToRdrName+ , addCommaAnns+ ) where++import Data.Foldable+import qualified Data.Char as Char+import qualified Language.Haskell.GHC.ExactPrint as EP+import Text.Read (readMaybe)++import qualified AutoSplit.GhcFacade as Ghc++isIdxComment :: Ghc.GenLocated l Ghc.EpaComment -> Bool+isIdxComment (Ghc.L _ (Ghc.EpaComment (Ghc.EpaLineComment str) realSpan))+ = realSpan == Ghc.placeholderRealSpan && all Char.isDigit str+isIdxComment _ = False++extractIdxComment :: Ghc.EpAnnComments -> Maybe (Int, Ghc.EpAnnComments)+extractIdxComment (Ghc.EpaComments comms)+ | (before, Ghc.L _ (Ghc.EpaComment (Ghc.EpaLineComment str) _) : rest)+ <- break isIdxComment comms+ , Just idx <- readMaybe str+ , let newComments = Ghc.EpaComments $ before ++ rest+ = Just (idx, newComments)+extractIdxComment Ghc.EpaCommentsBalanced{} = Nothing+extractIdxComment _ = Nothing++#if MIN_VERSION_ghc(9,10,0)+addIndexComment :: Ghc.EpAnn ann -> Int -> Ghc.EpAnn ann+#else+addIndexComment :: Monoid ann => Ghc.SrcSpanAnn' (Ghc.EpAnn ann) -> Int -> Ghc.SrcSpanAnn' (Ghc.EpAnn ann)+#endif+addIndexComment ann neIdx =+ let com :: Ghc.LEpaComment+ com = Ghc.L Ghc.fakeCommentLocation+ (Ghc.EpaComment (Ghc.EpaLineComment (show neIdx)) Ghc.placeholderRealSpan)+ newComms = case Ghc.getComments ann of+ Ghc.EpaComments cs -> Ghc.EpaComments $ com : cs+ Ghc.EpaCommentsBalanced cs1 cs2 -> Ghc.EpaCommentsBalanced (com : cs1) cs2+ in Ghc.setComments newComms mempty ann++nameToRdrName :: Ghc.GlobalRdrEnv -> Ghc.Name -> Ghc.RdrName+nameToRdrName rdrEnv n =+ case Ghc.lookupOccEnv rdrEnv occName of+ Just gres+ | Just gre <- find greMatches gres+ , rdrName : _ <- Ghc.greRdrNames gre+ -> rdrName+ Nothing+ | not (Ghc.isWiredInName n)+ , not (Ghc.isBuiltInSyntax n)+ , not (Ghc.isSystemName n)+ , not (Ghc.isInternalName n)+ -> Ghc.mkRdrQual (Ghc.mkModuleName "NOT_IN_SCOPE") occName+ _ -> Ghc.nameRdrName n+ where+ occName = Ghc.getOccName n+ greMatches gre = Ghc.greToName gre == n++addCommaAnns :: [Ghc.GenLocated Ghc.SrcSpanAnnA e] -> [Ghc.GenLocated Ghc.SrcSpanAnnA e]+addCommaAnns [] = []+addCommaAnns [a] = [a]+addCommaAnns (Ghc.L epAnn a : rest) = Ghc.L (EP.addComma epAnn) a : addCommaAnns rest
+ src/AutoSplit/Split.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module AutoSplit.Split+ ( NonExhaustivePatterns(..)+ , modifyModule+ , splitName+ ) where++import qualified Control.Monad.Trans.Writer.CPS as Writer+import qualified Data.Generics as Syb+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 Language.Haskell.GHC.ExactPrint as EP++import qualified AutoSplit.GhcFacade as Ghc+import AutoSplit.Shared++data NonExhaustivePatterns = NonExhaustivePatterns+ { patternIds :: [Ghc.Id]+ , patternNablas :: [Ghc.Nabla]+ , srcCodeLoc :: Ghc.RealSrcSpan+ }++-- | Applies pattern split transformation and updates the module file.+modifyModule+ :: Ghc.GlobalRdrEnv+ -> Ghc.ParsedSource+ -> Bool+ -> Ghc.Bag NonExhaustivePatterns+ -> FilePath+ -> IO Bool -- ^ True if module was updated+modifyModule gblRdrEnv parsedMod usesCpp missingPatWarns filePath = do+ let ast = EP.makeDeltaAst+ $ searchAndMark (Ghc.bagToList missingPatWarns) parsedMod+ case splitPattern gblRdrEnv (Ghc.bagToList missingPatWarns) ast of+ (ps, Any True) ->+ -- If the source contains CPP, newlines are appended+ -- to the end of the file when exact printing. The simple+ -- solution is to remove trailing newlines after exact printing+ -- if the source contains CPP comments.+ let removeTrailingNewlines+ | usesCpp =+ reverse . ('\n' :) . dropWhile (== '\n') . reverse+ | otherwise = id+ printed = removeTrailingNewlines $ EP.exactPrint ps+ in True <$ writeFile filePath printed+ _ -> pure False++-- | Before applying delta transformation, find the expressions that go with+-- non exhaustive patterns and mark them with a special comment containing the+-- index of that pattern. This must be done first because source code locations+-- are removed by delta transformation.+-- Problematic if delta moves comments to a different node, hopefully it won't.+searchAndMark+ :: [NonExhaustivePatterns]+ -> Ghc.ParsedSource+ -> Ghc.ParsedSource+searchAndMark nePats =+ Syb.everywhere (Syb.mkT goExpr `Syb.extT` goDecl `Syb.extT` goBind)+ where+ goExpr :: Ghc.LHsExpr Ghc.GhcPs -> Ghc.LHsExpr Ghc.GhcPs+ goExpr (Ghc.L ann c@Ghc.HsCase{})+ | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann+ , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats+ = Ghc.L (addIndexComment ann neIdx) c+#if MIN_VERSION_ghc(9,10,0)+ goExpr (Ghc.L ann l@(Ghc.HsLam _ lamType _))+ | lamType /= Ghc.LamSingle+ , Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann+ , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats+ = Ghc.L (addIndexComment ann neIdx) l+#elif MIN_VERSION_ghc(9,6,0)+ goExpr (Ghc.L ann l@(Ghc.HsLamCase _ _ _))+ | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann+ , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats+ = Ghc.L (addIndexComment ann neIdx) l+#endif+ goExpr x = x++ goDecl :: Ghc.LHsDecl Ghc.GhcPs -> Ghc.LHsDecl Ghc.GhcPs+ goDecl (Ghc.L ann f@(Ghc.ValD _ Ghc.FunBind{}))+ | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann+ , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats+ = Ghc.L (addIndexComment ann neIdx) f+ goDecl x = x++ goBind :: Ghc.LHsBind Ghc.GhcPs -> Ghc.LHsBind Ghc.GhcPs+ goBind (Ghc.L ann f@Ghc.FunBind{})+ | Just caseLoc <- Ghc.srcSpanToRealSrcSpan $ Ghc.locA ann+ , Just neIdx <- List.findIndex ((caseLoc ==) . srcCodeLoc) nePats+ = Ghc.L (addIndexComment ann neIdx) f+ goBind x = x++-- | Finds the target pattern and splits it. Returns the modified source and True if successful.+-- Applied post delta transformation.+splitPattern+ :: Ghc.GlobalRdrEnv+ -> [NonExhaustivePatterns]+ -> Ghc.ParsedSource+ -> (Ghc.ParsedSource, Any)+splitPattern gblRdrEnv nePats ps =+ Writer.runWriter $+ Syb.everywhereM+ ( Syb.mkM (Writer.writer . goExpr)+ `Syb.extM` (Writer.writer . goDecl)+ `Syb.extM` (Writer.writer . goBind)+ ) ps+ where+ goExpr :: Ghc.LHsExpr Ghc.GhcPs -> (Ghc.LHsExpr Ghc.GhcPs, Any)+ goExpr (Ghc.L ann (Ghc.HsCase x scrut matchGroup))+ | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)+ , Just nePat <- listToMaybe $ drop neIdx nePats+ , Just newMG <- splitMG gblRdrEnv False False 0 nePat matchGroup+ = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.HsCase x scrut newMG)+ , Any True+ )+#if MIN_VERSION_ghc(9,10,0)+ goExpr (Ghc.L ann (Ghc.HsLam x lamType matchGroup@(Ghc.MG _ (Ghc.L matchesAnn _))))+ | lamType /= Ghc.LamSingle+ , Just (neIdx, otherComms) <- extractIdxComment (Ghc.comments ann)+ , Just nePat <- nePats List.!? neIdx+ , Just newMG <- splitMG gblRdrEnv (lamType == Ghc.LamCases) False (Ghc.colDelta matchesAnn) nePat matchGroup+ = ( Ghc.L ann {Ghc.comments = otherComms} (Ghc.HsLam x lamType newMG)+ , Any True+ )+#elif MIN_VERSION_ghc(9,6,0)+ goExpr (Ghc.L ann (Ghc.HsLamCase x lamType matchGroup@(Ghc.MG _ (Ghc.L matchesAnn _))))+ | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)+ , Just nePat <- listToMaybe $ drop neIdx nePats+ , Just newMG <- splitMG gblRdrEnv (lamType == Ghc.LamCases) False (Ghc.colDelta matchesAnn) nePat matchGroup+ = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.HsLamCase x lamType newMG)+ , Any True+ )+#endif+ goExpr expr = (expr, Any False)++ goDecl :: Ghc.LHsDecl Ghc.GhcPs -> (Ghc.LHsDecl Ghc.GhcPs, Any)+ goDecl (Ghc.L ann (Ghc.ValD x (Ghc.FunBind x2 fid matchGroup)))+ | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)+ , Just nePat <- listToMaybe $ drop neIdx nePats+ , Just newMG <- splitMG gblRdrEnv True True 0 nePat matchGroup+ = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.ValD x (Ghc.FunBind x2 fid newMG))+ , Any True+ )+ goDecl decl = (decl, Any False)++ goBind :: Ghc.LHsBind Ghc.GhcPs -> (Ghc.LHsBind Ghc.GhcPs, Any)+ goBind (Ghc.L ann (Ghc.FunBind x2 fid matchGroup))+ | Just (neIdx, otherComms) <- extractIdxComment (Ghc.getComments ann)+ , Just nePat <- listToMaybe $ drop neIdx nePats+ , Just newMG <- splitMG gblRdrEnv True True 0 nePat matchGroup+ = ( Ghc.L (Ghc.setComments otherComms mempty ann) (Ghc.FunBind x2 fid newMG)+ , Any True+ )+ goBind bind = (bind, Any False)++splitMG+ :: Ghc.GlobalRdrEnv+ -> Bool -- True => match group can have multiple patterns+ -> Bool -- True => add left padding to each new pattern+ -> Int -- Number of horizontal spaces at the front of inserted pattern match+ -> NonExhaustivePatterns+ -> Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+ -> Maybe (Ghc.MatchGroup Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs))+splitMG gblRdrEnv multiplePats offsetFirstPat colOffset nePat (Ghc.MG x2 (Ghc.L ann2 matches))+ | (beforeSplit, Ghc.L splitAnn targetMatch@(Ghc.Match _ ctx _ rhs) : afterSplit)+ <- break matchHasSplit matches+ , let mUpdatedMatch = Ghc.L splitAnn <$> removeSplitFromOrPat targetMatch+ -- If splitting the first match, trailing matches need to have a delta+ -- putting it on a new line+ correctDeltas [] = []+ correctDeltas (x : xs) | isNothing mUpdatedMatch =+ x :+ (Ghc.L (Ghc.nextLine colOffset) . Ghc.unLoc+ <$> xs)+ correctDeltas xs = Ghc.L (Ghc.nextLine colOffset) . Ghc.unLoc <$> xs+ newMatches = correctDeltas $ do+ nabla <- patternNablas nePat+ let pats =+ zipWith (mkPat gblRdrEnv nabla $ not multiplePats)+ (offsetFirstPat : repeat True)+ (patternIds nePat)+ [ Ghc.L splitAnn $ Ghc.Match Ghc.noExtFieldCpp ctx (Ghc.noLocCpp pats) rhs ]+ removeSplits m =+ case traverse removeSplitFromOrPat m of+ Nothing -> if matchHasSplit m then Nothing else Just m+ Just newM -> Just newM+ afterSplitUpdated = mapMaybe removeSplits afterSplit+ newMatchGroup+ = beforeSplit+ ++ maybeToList mUpdatedMatch+ ++ newMatches+ ++ afterSplitUpdated+ = Just $ Ghc.MG x2 (Ghc.L ann2 newMatchGroup)+ | otherwise = Nothing++matchHasSplit :: Ghc.LMatch Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs) -> Bool+matchHasSplit (Ghc.L _ (Ghc.Match _ _ pats _)) =+ Syb.everything (||) (Syb.mkQ False isSplitCon) pats++isSplitCon :: Ghc.Pat Ghc.GhcPs -> Bool+isSplitCon (Ghc.ConPat _ (Ghc.L _ rdr) _) =+ Ghc.rdrNameOcc rdr == Ghc.mkDataOcc splitName+isSplitCon _ = False++-- | Remove SPLIT pattern from OrPat groups. Returns Just if the match was modified.+removeSplitFromOrPat+ :: Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs)+ -> Maybe (Ghc.Match Ghc.GhcPs (Ghc.LHsExpr Ghc.GhcPs))+#if MIN_VERSION_ghc(9,12,0)+removeSplitFromOrPat (Ghc.Match a b pats c) =+ let mNewPats = Syb.everywhereM (Syb.mkM (Writer.writer . go)) pats+ patHasSplit = Syb.everything (||) (Syb.mkQ False isSplitCon)+ dropSemicolon ann = ann { Ghc.anns = Ghc.noAnn }+ go :: Ghc.Pat Ghc.GhcPs -> (Ghc.Pat Ghc.GhcPs, Any)+ go (Ghc.OrPat x oPats) =+ case reverse (NE.filter (not . patHasSplit) oPats) of+ [] -> (Ghc.WildPat Ghc.noExtField, Any True)+ (Ghc.L patAnn lastPat : fPats)+ | length fPats + 1 /= NE.length oPats ->+ ( Ghc.OrPat x+ (NE.reverse $ Ghc.L (dropSemicolon patAnn) lastPat NE.:| fPats)+ , Any True)+ | otherwise -> (Ghc.OrPat x oPats, Any False)+ go other = (other, Any False)+ in case Writer.runWriter mNewPats of+ (newPats, Any True) -> Just (Ghc.Match a b newPats c)+ _ -> Nothing+#else+removeSplitFromOrPat _ = Nothing+#endif++-- | Produce a 'Pat' for a missing pattern+mkPat+ :: Ghc.GlobalRdrEnv+ -> Ghc.Nabla+ -> Bool -- ^ True => is a singular pattern which doesn't need outer parens+ -> Bool -- ^ True => needs left padding to separate it from another pattern+ -> Ghc.Id+ -> Ghc.LPat Ghc.GhcPs+mkPat gblRdrEnv nabla isOutermost needsLeftPad x = Ghc.L delta $+ case Ghc.lookupSolution nabla x of+ Nothing -> Ghc.WildPat Ghc.noExtField+ Just (Ghc.PACA (Ghc.PmAltConLike con) _tvs args) -> paren con args $+ case Ghc.conLikeIsInfix con of+ True | [arg1, arg2] <- args ->+ Ghc.ConPat Ghc.noAnn+ ( Ghc.L Ghc.nameAnchorD1+ . nameToRdrName gblRdrEnv+ $ Ghc.conLikeName con+ )+ $ Ghc.InfixCon (mkPat gblRdrEnv nabla False False arg1)+ (mkPat gblRdrEnv nabla False True arg2)+ _ | Ghc.RealDataCon dc <- con+ , Ghc.isUnboxedTupleDataCon dc+ -> Ghc.TuplePat Ghc.parenHashAnns+ (addCommaAnns $ zipWith (mkPat gblRdrEnv nabla True) (False : repeat True) args)+ Ghc.Unboxed+ _ | Ghc.RealDataCon dc <- con+ , Ghc.isTupleDataCon dc+ -> Ghc.TuplePat Ghc.parenAnns+ (addCommaAnns $ zipWith (mkPat gblRdrEnv nabla True) (False : repeat True) args)+ Ghc.Boxed+ _ ->+ -- If GHC tries to use SPLIT as a missing pattern, replace it with wildcard+ if Ghc.occName (Ghc.conLikeName con) == Ghc.mkDataOcc splitName+ then Ghc.WildPat Ghc.noExtField+ else Ghc.ConPat Ghc.noAnn+ ( Ghc.L Ghc.nameAnchorD0+ . nameToRdrName gblRdrEnv $ Ghc.conLikeName con+ )+ $ Ghc.PrefixCon [] (mkPat gblRdrEnv nabla False True <$> args)+ Just (Ghc.PACA (Ghc.PmAltLit lit) _tvs _args) ->+ case Ghc.pm_lit_val lit of+ Ghc.PmLitInt integer ->+ Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsIntegral $ Ghc.IL (Ghc.SourceText . fromString $ show integer) (integer < 0) integer) Nothing Ghc.noExtField+ Ghc.PmLitRat rational ->+ Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsFractional $ Ghc.mkTHFractionalLit rational) Nothing Ghc.noExtField+ Ghc.PmLitChar char -> Ghc.LitPat Ghc.noExtField $ Ghc.HsChar Ghc.NoSourceText char+ Ghc.PmLitString fastString -> Ghc.LitPat Ghc.noExtField $ Ghc.HsString Ghc.NoSourceText fastString+ Ghc.PmLitOverInt _minuses integer ->+ Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsIntegral $ Ghc.IL (Ghc.SourceText . fromString $ show integer) (integer < 0) integer) Nothing Ghc.noExtField+ Ghc.PmLitOverRat _minuses fractionalLit ->+ Ghc.NPat Ghc.noAnn (Ghc.noLocA $ Ghc.OverLit Ghc.noExtField $ Ghc.HsFractional fractionalLit) Nothing Ghc.noExtField+ Ghc.PmLitOverString fastString -> Ghc.LitPat Ghc.noExtField $ Ghc.HsString Ghc.NoSourceText fastString+ where+ delta = if needsLeftPad+ then Ghc.anchorD1+ else Ghc.anchorD0+ paren _ [] inner = inner+ paren (Ghc.RealDataCon dc) _ inner | Ghc.isTupleDataCon dc = inner -- No parens for tuple pats+ paren _ _ inner =+ if not isOutermost+ then Ghc.mkParPat' (Ghc.L Ghc.anchorD0 inner)+ else inner++splitName :: IsString a => a+splitName = "SPLIT"
test/Main.hs view
@@ -50,6 +50,12 @@ , testCase "5" $ runTest "Fun5.hs" , testCase "6" $ runTest "Fun6.hs" ]+ , testGroup "auto fields"+ [ testCase "1" $ runTest "Fields1.hs"+ , testCase "2" $ runTest "Fields2.hs"+ , testCase "3" $ runTest "Fields3.hs"+ , testCase "4" $ runTest "Fields4.hs"+ ] ] testModulePath :: String -> FilePath