diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for auto-split + +## 0.1.0.0 -- 2025-02-01 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/auto-split.cabal b/auto-split.cabal new file mode 100644 --- /dev/null +++ b/auto-split.cabal @@ -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 diff --git a/src/AutoSplit.hs b/src/AutoSplit.hs new file mode 100644 --- /dev/null +++ b/src/AutoSplit.hs @@ -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" diff --git a/src/AutoSplit/GhcFacade.hs b/src/AutoSplit/GhcFacade.hs new file mode 100644 --- /dev/null +++ b/src/AutoSplit/GhcFacade.hs @@ -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 diff --git a/src/AutoSplit/Pattern.hs b/src/AutoSplit/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/AutoSplit/Pattern.hs @@ -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 <- _ diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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