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.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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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.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, diff --git a/src/AutoSplit.hs b/src/AutoSplit.hs --- a/src/AutoSplit.hs +++ b/src/AutoSplit.hs @@ -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" diff --git a/src/AutoSplit/Fields.hs b/src/AutoSplit/Fields.hs new file mode 100644 --- /dev/null +++ b/src/AutoSplit/Fields.hs @@ -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" diff --git a/src/AutoSplit/GhcFacade.hs b/src/AutoSplit/GhcFacade.hs --- a/src/AutoSplit/GhcFacade.hs +++ b/src/AutoSplit/GhcFacade.hs @@ -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) diff --git a/src/AutoSplit/Pattern.hs b/src/AutoSplit/Pattern.hs --- a/src/AutoSplit/Pattern.hs +++ b/src/AutoSplit/Pattern.hs @@ -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 diff --git a/src/AutoSplit/Shared.hs b/src/AutoSplit/Shared.hs new file mode 100644 --- /dev/null +++ b/src/AutoSplit/Shared.hs @@ -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 diff --git a/src/AutoSplit/Split.hs b/src/AutoSplit/Split.hs new file mode 100644 --- /dev/null +++ b/src/AutoSplit/Split.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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