auto-split (empty) → 0.1.0.0
raw patch · 8 files changed
+1041/−0 lines, 8 filesdep +basedep +directorydep +ghc
Dependencies added: base, directory, ghc, ghc-exactprint, ghc-paths, process, syb, tasty, tasty-hunit, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +90/−0
- auto-split.cabal +53/−0
- src/AutoSplit.hs +508/−0
- src/AutoSplit/GhcFacade.hs +278/−0
- src/AutoSplit/Pattern.hs +8/−0
- test/Main.hs +69/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for auto-split++## 0.1.0.0 -- 2025-02-01++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, Aaron Allen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Aaron Allen nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,90 @@+# auto-split++A GHC plugin that performs automatic case splitting.++### Usage++This plugin is intended to be used with GHCi or adjacent utilities such as+`ghcid` and `ghciwatch` as a developement tool, not as a package dependency.+Here is an example command for starting a REPL for a stack project with the+`auto-split` plugin enabled:++```+stack repl my-project --package auto-split --ghci-options='-fplugin AutoSplit'+```++likewise for a cabal project:++```+cabal repl my-project --build-depends auto-split --repl-options='-fplugin AutoSplit'+```++With the plugin enabled, use `SPLIT` in a pattern match for a case statement or+function declaration. Compiling the module will then result in that pattern+match being expanded to cover all missing cases.++For example, compiling this module++```haskell+module Foo where++foo :: Maybe Bool -> String+foo x = case x of+ SPLIT -> undefined+```++results in the module file being updated to++```haskell+module Foo where++foo :: Maybe Bool -> String+foo x = case x of+ Just _ -> undefined+ Nothing -> undefined+```++if the module is then changed to++```haskell+module Foo where++foo :: Maybe Bool -> String+foo x = case x of+ Just SPLIT -> "foo"+ Nothing -> "bar"+```++compiling will result in++```haskell+module Foo where++foo :: Maybe Bool -> String+foo x = case x of+ Just True -> "foo"+ Just False -> "foo"+ Nothing -> "bar"+```++The `SPLIT` pattern can be used in this way anywhere a pattern match group+occurs: case statements, lamba case, or function declarations.++If case splitting results in constructors or patterns that are not in scope,+they will be qualified with `NOT_IN_SCOPE`.++Compilation will abort when case splitting occurs since the module file has+been updated. This is done by having GHC emit a custom error. This error does+not indicate that something went wrong.++### Known limitations++- 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.+- 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+ the four latest release series, i.e. `9.6.*` thru `9.12.*`. The cabal file+ indicates the currently supported versions.
+ auto-split.cabal view
@@ -0,0 +1,53 @@+cabal-version: 3.0+name: auto-split+version: 0.1.0.0+synopsis: Case splitting plugin+description: A GHC plugin that performs automatic case splitting+license: BSD-3-Clause+license-file: LICENSE+author: Aaron Allen+maintainer: aaronallen8455@gmail.com+category: Development+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ README.md+tested-with: GHC == 9.12.1, GHC == 9.10.1, GHC == 9.8.2, GHC == 9.6.6++source-repository head+ type: git+ location: https://github.com/aaronallen8455/auto-split++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: AutoSplit+ AutoSplit.Pattern+ other-modules: AutoSplit.GhcFacade+ -- other-extensions:+ build-depends: base <5,+ ghc >=9.6 && <9.13,+ syb <0.8,+ ghc-exactprint <1.13,+ ghc-paths <0.2,+ transformers <0.7+ hs-source-dirs: src+ default-language: GHC2021++test-suite auto-split-test+ import: warnings+ default-language: GHC2021+ -- other-modules:+ -- other-extensions:+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base <5,+ process,+ directory,+ tasty,+ tasty-hunit
+ src/AutoSplit.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module AutoSplit+ ( plugin+ ) 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+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Monoid (Any(..))+import Data.String (IsString, fromString)+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.GhcFacade as Ghc++plugin :: Ghc.Plugin+plugin = Ghc.defaultPlugin+ { Ghc.driverPlugin = \_ hscEnv -> pure $ addDsHook hscEnv+ , Ghc.parsedResultAction = \_ _ result -> pure $ addImport result+ , Ghc.pluginRecompile = Ghc.purePlugin+ , Ghc.typeCheckResultAction = \_ _ env ->+ removeUnusedImportWarn >> pure env+ }++-- | Incomplete patterns warning is emitted by the desugarer. Some shenanigans+-- are needed to intercept these warnings: a custom error is added to the+-- frontend result which causes the desugarer to throw a 'SourceError'+-- exception containing all diagnostics after running. This exception is then+-- caught (and later rethrown) by the plugin.+addDsHook :: Ghc.HscEnv -> Ghc.HscEnv+addDsHook hscEnv = hscEnv+ { Ghc.hsc_hooks =+ let hooks = Ghc.hsc_hooks hscEnv+ in hooks+ { Ghc.runPhaseHook = Just $ phaseHook (Ghc.runPhaseHook hooks) }+ }+ where+ phaseHook mExistingHook = Ghc.PhaseHook $ \tPhase -> do+ let isMissingPatWarn msgEnv =+ case Ghc.errMsgDiagnostic msgEnv of+ Ghc.GhcDsMessage (Ghc.DsNonExhaustivePatterns _ _ _ patIds nablas)+ | Just srcSpan <- Ghc.srcSpanToRealSrcSpan (Ghc.errMsgSpan msgEnv) -> Left+ NonExhaustivePattern+ { patternIds = patIds+ , patternNablas = nablas+ , srcCodeLoc = srcSpan+ }+ _ -> Right msgEnv+ 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+ 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+ )+ _ -> runPhaseOrExistingHook tPhase++-- | Parse the given module file. Accounts for CPP comments+parseModule+ :: Ghc.HscEnv+ -> Ghc.DynFlags+ -> String+ -> IO (EP.ParseResult Ghc.ParsedSource, Bool)+parseModule env dynFlags filePath = EP.ghcWrapper Paths.libdir $ do+ Ghc.setSession env { Ghc.hsc_dflags = dynFlags }+ res <- EP.parseModuleEpAnnsWithCppInternal EP.defaultCppOptions dynFlags filePath+ let eCppComments = fmap (\(c, _, _) -> c) res+ hasCpp = case eCppComments of+ Right cs -> not $ null cs+ _ -> False+ pure+ ( liftA2 EP.insertCppComments+ (EP.postParseTransform res)+ eCppComments+ , hasCpp+ )++-- | Applies pattern split transformation and updates the module file.+modifyModule+ :: Ghc.GlobalRdrEnv+ -> Ghc.ParsedSource+ -> Bool+ -> Ghc.Bag NonExhaustivePattern+ -> 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++instance Ghc.Diagnostic PatternSplitDiag where+ 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++data NonExhaustivePattern = NonExhaustivePattern+ { 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+ :: [NonExhaustivePattern]+ -> 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+ -> [NonExhaustivePattern]+ -> 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 True 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 True 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+ -> NonExhaustivePattern+ -> 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+addImport result = result+ { Ghc.parsedResultModule =+ let resMod = Ghc.parsedResultModule result+ in resMod+ { Ghc.hpm_module = Ghc.hpm_module resMod <&> \pMod ->+ pMod+ { Ghc.hsmodImports =+ caseXImport : Ghc.hsmodImports pMod+ }+ }+ }+ where+ caseXImport = Ghc.noLocA . Ghc.simpleImportDecl $ Ghc.mkModuleName patternModName++-- | The automatically added import gets flagged as unused even if it is used.+-- The solution here is to simply suppress the warning.+removeUnusedImportWarn :: Ghc.TcM ()+removeUnusedImportWarn = do+ errsVar <- Ghc.getErrsVar+#if MIN_VERSION_ghc(9,8,0)+ let isAutoSplitImportWarn msgEnv =+ case Ghc.errMsgDiagnostic msgEnv of+ Ghc.TcRnMessageWithInfo _ (Ghc.TcRnMessageDetailed _ (Ghc.TcRnUnusedImport decl _)) ->+ Ghc.unLoc (Ghc.ideclName decl) == Ghc.mkModuleName patternModName+ _ -> False+ Ghc.liftIO . modifyIORef errsVar $+ Ghc.mkMessages . Ghc.filterBag (not . isAutoSplitImportWarn) . Ghc.getMessages+#else+ -- 9.6 lacks the specific diagnostic+ let isAutoSplitImportWarn msgEnv =+ case Ghc.errMsgDiagnostic msgEnv of+ Ghc.TcRnMessageWithInfo _ (Ghc.TcRnMessageDetailed _ (Ghc.TcRnUnknownMessage (Ghc.UnknownDiagnostic diag)))+ | Ghc.WarningWithFlag Ghc.Opt_WarnUnusedImports <- Ghc.diagnosticReason diag+ -> True+ _ -> False+ Ghc.liftIO . modifyIORef errsVar $ \msgs ->+ -- the target import warning always shows up as the last occurrence+ case break isAutoSplitImportWarn . reverse . Ghc.bagToList $ Ghc.getMessages msgs of+ (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/GhcFacade.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE CPP #-}+module AutoSplit.GhcFacade+ ( module Ghc+ , mkParPat'+ , anchorD0+ , anchorD1+ , nameAnchorD0+ , nameAnchorD1+ , colDelta+ , nextLine+ , getComments+ , setComments+ , fakeCommentLocation+ , parenAnns+ , parenHashAnns+ , greToName+ , noLocCpp+ , noExtFieldCpp+ ) where++#if MIN_VERSION_ghc(9,8,0)+import GHC.Driver.DynFlags as Ghc+import GHC.Types.Var as Ghc+#else+import GHC.Driver.Flags as Ghc+import GHC.Types.Var as Ghc hiding (varName)+import GHC.Driver.Session as Ghc+#endif+import GHC as Ghc (ParsedSource)+import GHC.Core.ConLike as Ghc+import GHC.Core.DataCon as Ghc+import GHC.Data.Bag as Ghc+import GHC.Driver.Env as Ghc+import GHC.Driver.Errors.Types as Ghc+import GHC.Driver.Hooks as Ghc+import GHC.Driver.Main as Ghc+import GHC.Driver.Pipeline.Execute as Ghc+import GHC.Driver.Pipeline.Phases as Ghc+import GHC.Driver.Plugins as Ghc+import GHC.Driver.Monad as Ghc+import GHC.Hs as Ghc+import GHC.HsToCore.Errors.Types as Ghc+import GHC.HsToCore.Pmc.Solver.Types as Ghc+import GHC.Tc.Errors.Types as Ghc+import GHC.Tc.Utils.Monad as Ghc hiding (DefaultingPlugin, TcPlugin)+import GHC.Types.Error as Ghc+import GHC.Types.Name as Ghc+import GHC.Types.Name.Reader as Ghc+import GHC.Types.SourceError as Ghc+import GHC.Types.SourceText as Ghc+import GHC.Types.SrcLoc as Ghc+import GHC.Unit.Module.Location as Ghc+import GHC.Unit.Module.ModSummary as Ghc+import GHC.Unit.Types as Ghc+import GHC.Utils.Error as Ghc+import GHC.Utils.Outputable as Ghc+import Language.Haskell.Syntax.Basic as Ghc++#if !MIN_VERSION_ghc(9,10,0)+import Data.Maybe+#endif+import qualified Language.Haskell.GHC.ExactPrint as EP++mkParPat' :: Ghc.LPat Ghc.GhcPs -> Ghc.Pat Ghc.GhcPs+#if MIN_VERSION_ghc(9,10,0)+mkParPat' inner = Ghc.ParPat (Ghc.EpTok EP.d0, Ghc.EpTok EP.d0) inner+#elif MIN_VERSION_ghc(9,6,0)+mkParPat' inner = Ghc.ParPat Ghc.noAnn (Ghc.L (Ghc.TokenLoc EP.d0) Ghc.HsTok) inner (Ghc.L (Ghc.TokenLoc EP.d0) Ghc.HsTok)+#endif++anchorD0+#if MIN_VERSION_ghc(9,10,0)+ :: Ghc.NoAnn ann => Ghc.EpAnn ann+anchorD0 = Ghc.EpAnn EP.d0 Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,6,0)+ :: Ghc.SrcSpanAnnA+anchorD0 =+ Ghc.SrcSpanAnn+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 0)))+ mempty+ Ghc.emptyComments+ )+ Ghc.generatedSrcSpan+#endif++anchorD1+#if MIN_VERSION_ghc(9,10,0)+ :: Ghc.NoAnn ann => Ghc.EpAnn ann+anchorD1 = Ghc.EpAnn EP.d1 Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,6,0)+ :: Ghc.SrcSpanAnnA+anchorD1 =+ Ghc.SrcSpanAnn+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 1)))+ mempty+ Ghc.emptyComments+ )+ Ghc.generatedSrcSpan+#endif++nameAnchorD0+#if MIN_VERSION_ghc(9,10,0)+ :: Ghc.NoAnn ann => Ghc.EpAnn ann+nameAnchorD0 = Ghc.EpAnn EP.d0 Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,6,0)+ :: Ghc.SrcSpanAnnN+nameAnchorD0 =+ Ghc.SrcSpanAnn+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 0)))+ mempty+ Ghc.emptyComments+ )+ Ghc.generatedSrcSpan --Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 0))+#endif++nameAnchorD1+#if MIN_VERSION_ghc(9,10,0)+ :: Ghc.NoAnn ann => Ghc.EpAnn ann+nameAnchorD1 = Ghc.EpAnn EP.d1 Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,6,0)+ :: Ghc.SrcSpanAnnN+nameAnchorD1 =+ Ghc.SrcSpanAnn+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 1)))+ mempty+ Ghc.emptyComments+ )+ Ghc.generatedSrcSpan --Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 0))+#endif++nextLine+ :: Int+#if MIN_VERSION_ghc(9,12,0)+ -> Ghc.NoAnn ann => Ghc.EpAnn ann+nextLine colOffset =+ Ghc.EpAnn (Ghc.EpaDelta Ghc.noSrcSpan (Ghc.DifferentLine 1 colOffset) []) Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,10,0)+ -> Ghc.NoAnn ann => Ghc.EpAnn ann+nextLine colOffset =+ Ghc.EpAnn (Ghc.EpaDelta (Ghc.DifferentLine 1 colOffset) []) Ghc.noAnn Ghc.emptyComments+#elif MIN_VERSION_ghc(9,6,0)+ -> Ghc.SrcSpanAnnA+nextLine colOffset =+ Ghc.SrcSpanAnn+ (Ghc.EpAnn+ (Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.DifferentLine 1 colOffset)))+ mempty+ Ghc.emptyComments+ )+ Ghc.generatedSrcSpan --Ghc.Anchor Ghc.placeholderRealSpan (Ghc.MovedAnchor (Ghc.SameLine 0))+#endif++#if MIN_VERSION_ghc(9,12,0)+colDelta :: Ghc.EpAnn ann -> Int+colDelta (Ghc.EpAnn (Ghc.EpaDelta _ delta _) _ _)+#elif MIN_VERSION_ghc(9,10,0)+colDelta :: Ghc.EpAnn ann -> Int+colDelta (Ghc.EpAnn (Ghc.EpaDelta delta _) _ _)+#elif MIN_VERSION_ghc(9,6,0)+colDelta :: Ghc.SrcSpanAnn' (Ghc.EpAnn ann) -> Int+colDelta (Ghc.SrcSpanAnn (Ghc.EpAnn (Ghc.Anchor _ (Ghc.MovedAnchor delta)) _ _) _)+#endif+ = case delta of+ Ghc.DifferentLine _ c -> c+ Ghc.SameLine c -> c+colDelta _ = 0++#if MIN_VERSION_ghc(9,10,0)+getComments :: Ghc.EpAnn ann -> Ghc.EpAnnComments+getComments = Ghc.comments+#elif MIN_VERSION_ghc(9,6,0)+getComments :: Ghc.SrcSpanAnn' (Ghc.EpAnn ann) -> Ghc.EpAnnComments+getComments a = case Ghc.ann a of+ Ghc.EpAnnNotUsed -> Ghc.emptyComments+ epAn -> Ghc.comments epAn+#endif++#if MIN_VERSION_ghc(9,10,0)+setComments :: Ghc.EpAnnComments -> () -> Ghc.EpAnn ann -> Ghc.EpAnn ann+setComments comms () a = a {Ghc.comments = comms}+#elif MIN_VERSION_ghc(9,6,0)+setComments :: Ghc.EpAnnComments -> ann -> Ghc.SrcSpanAnn' (Ghc.EpAnn ann) -> Ghc.SrcSpanAnn' (Ghc.EpAnn ann)+setComments comms defAnn a =+ case Ghc.ann a of+ Ghc.EpAnnNotUsed ->+ a { Ghc.ann = Ghc.EpAnn+ (Ghc.Anchor+ (fromMaybe Ghc.placeholderRealSpan . Ghc.srcSpanToRealSrcSpan $ Ghc.locA a)+ Ghc.UnchangedAnchor+ ) defAnn comms+ }+ _ -> a {Ghc.ann = (Ghc.ann a) {Ghc.comments = comms}}+#endif++-- | A location used for the comments that are inserted for targeted elements.+-- By using a negative column delta, the layout is not affected.+fakeCommentLocation+#if MIN_VERSION_ghc(9,12,0)+ :: Ghc.NoCommentsLocation+fakeCommentLocation = Ghc.EpaDelta Ghc.noSrcSpan (Ghc.DifferentLine (-1) 0) Ghc.NoComments+#elif MIN_VERSION_ghc(9,10,0)+ :: Ghc.NoCommentsLocation+fakeCommentLocation = Ghc.EpaDelta (Ghc.DifferentLine (-1) 0) Ghc.NoComments+#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)+parenAnns :: (Ghc.EpaLocation, Ghc.EpaLocation)+parenAnns = (EP.d0, EP.d0)++parenHashAnns :: (Ghc.EpaLocation, Ghc.EpaLocation)+parenHashAnns = (EP.d0, EP.d0)+#elif MIN_VERSION_ghc(9,10,0)+parenAnns :: [Ghc.AddEpAnn]+parenAnns =+ [ Ghc.AddEpAnn Ghc.AnnOpenP EP.d0+ , Ghc.AddEpAnn Ghc.AnnCloseP EP.d0+ ]++parenHashAnns :: [Ghc.AddEpAnn]+parenHashAnns =+ [ Ghc.AddEpAnn Ghc.AnnOpenPH EP.d0+ , Ghc.AddEpAnn Ghc.AnnClosePH EP.d0+ ]+#else+parenAnns :: Ghc.EpAnn [Ghc.AddEpAnn]+parenAnns = Ghc.EpAnn+ { Ghc.entry = Ghc.Anchor Ghc.placeholderRealSpan EP.m0+ , Ghc.anns =+ [ Ghc.AddEpAnn Ghc.AnnOpenP EP.d0+ , Ghc.AddEpAnn Ghc.AnnCloseP EP.d0+ ]+ , Ghc.comments = Ghc.emptyComments+ }++parenHashAnns :: Ghc.EpAnn [Ghc.AddEpAnn]+parenHashAnns = Ghc.EpAnn+ { Ghc.entry = Ghc.Anchor Ghc.placeholderRealSpan EP.m0+ , Ghc.anns =+ [ Ghc.AddEpAnn Ghc.AnnOpenPH EP.d0+ , Ghc.AddEpAnn Ghc.AnnClosePH EP.d0+ ]+ , Ghc.comments = Ghc.emptyComments+ }+#endif++greToName :: Ghc.GlobalRdrElt -> Ghc.Name+greToName =+#if MIN_VERSION_ghc(9,8,0)+ Ghc.greName+#else+ Ghc.grePrintableName+#endif++#if MIN_VERSION_ghc(9,12,0)+noLocCpp :: Ghc.HasAnnotation e => a -> Ghc.GenLocated e a+noLocCpp = Ghc.noLocA+#else+noLocCpp :: a -> a+noLocCpp = id+#endif++#if MIN_VERSION_ghc(9,12,0)+noExtFieldCpp :: Ghc.NoExtField+noExtFieldCpp = Ghc.noExtField+#elif MIN_VERSION_ghc(9,10,0)+noExtFieldCpp :: [a]+noExtFieldCpp = []+#else+noExtFieldCpp :: Ghc.EpAnn a+noExtFieldCpp = Ghc.noAnn+#endif
+ src/AutoSplit/Pattern.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}+module AutoSplit.Pattern+ ( pattern SPLIT+ ) where++-- | Used to induce the incomplete patterns warning from GHC+pattern SPLIT :: a+pattern SPLIT <- _
+ test/Main.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Control.Monad+import Test.Tasty+import Test.Tasty.HUnit+import qualified System.Directory as Dir+import qualified System.Process as Proc++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ testGroup "case"+ [ testCase "1" $ runTest "Case1.hs"+ , testCase "2" $ runTest "Case2.hs"+ , testCase "3" $ runTest "Case3.hs"+ , testCase "4" $ runTest "Case4.hs"+ , testCase "5" $ runTest "Case5.hs"+ , testCase "6" $ runTest "Case6.hs"+ , testCase "7" $ runTest "Case7.hs"+ , testCase "8" $ runTest "Case8.hs"+ , testCase "9" $ runTest "Case9.hs"+ , testCase "10" $ runTest "Case10.hs"+ , testCase "11" $ runTest "Case11.hs"+ , testCase "13" $ runTest "Case13.hs"+#if __GLASGOW_HASKELL__ >= 912+ , testCase "12" $ runTest "Case12.hs"+ , testCase "14" $ runTest "Case14.hs"+ , testCase "15" $ runTest "Case15.hs"+ , testCase "16" $ runTest "Case16.hs"+#endif+ , testCase "17" $ runTest "Case17.hs"+ , testCase "18" $ runTest "Case18.hs"+ ]+ , testGroup "lambda case"+ [ testCase "1" $ runTest "LambdaCase1.hs"+ ]+ , testGroup "lambda cases"+ [ testCase "1" $ runTest "LambdaCases1.hs"+ , testCase "2" $ runTest "LambdaCases2.hs"+ ]+ , testGroup "fun cases"+ [ testCase "1" $ runTest "Fun1.hs"+ , testCase "2" $ runTest "Fun2.hs"+ , testCase "3" $ runTest "Fun3.hs"+ , testCase "4" $ runTest "Fun4.hs"+ , testCase "5" $ runTest "Fun5.hs"+ ]+ ]++testModulePath :: String -> FilePath+testModulePath name = "test-modules/" <> name++-- copy the input file contents to the module file to be compiled+prepTest :: FilePath -> IO ()+prepTest modFile = do+ inp <- readFile (modFile ++ ".input")+ writeFile modFile inp++runTest :: FilePath -> Assertion+runTest name = do+ let modFile = testModulePath name+ prepTest modFile+ (_, _, _, h) <- Proc.createProcess $+ Proc.proc "cabal" ["build", "test-modules:" ++ takeWhile (/= '.') name]+ void $ Proc.waitForProcess h+ updatedMod <- readFile modFile+ expectedMod <- readFile $ modFile ++ ".expected"+ assertEqual "Expected update" expectedMod updatedMod+ Dir.removeFile modFile