apply-refact 0.6.0.0 → 0.7.0.0
raw patch · 11 files changed
+74/−31 lines, 11 filesdep ~ghcdep ~ghc-exactprint
Dependency ranges changed: ghc, ghc-exactprint
Files
- CHANGELOG +9/−0
- README.md +2/−0
- apply-refact.cabal +7/−7
- src/Main.hs +0/−1
- src/Refact/Apply.hs +18/−12
- src/Refact/Run.hs +25/−10
- src/Refact/Utils.hs +1/−1
- tests/Test.hs +1/−0
- tests/examples/LambdaCase01.hs +5/−0
- tests/examples/LambdaCase01.hs.expected +5/−0
- tests/examples/LambdaCase01.hs.refact +1/−0
CHANGELOG view
@@ -1,3 +1,12 @@+v0.7.0.0++ * 8.8 release compatability+ * Specify language extensions using -X++v0.6.0.0++ * 8.6 release compatibility+ v0.5.0.0 * 8.4 release compatibility
README.md view
@@ -48,6 +48,8 @@ The `--pos` option is intended to be used by tooling in order to specify which specific hint should be performed. +Multiple `-X` options may be provided to specify additional default language pragmas which might affect parsing, such as `-XLambdaCase` or `-XRankNTypes`.+ ## Refact Files Refact files should be the result of `show` on a value of type `[(String,
apply-refact.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: apply-refact-version: 0.6.0.0+version: 0.7.0.0 synopsis: Perform refactorings specified by the refact library. description: Perform refactorings specified by the refact library. It is primarily used with HLint's --refactor flag. license: BSD3@@ -18,7 +18,7 @@ , tests/examples/*.hs.refact , tests/examples/*.hs.expected cabal-version: >=1.10-tested-with: GHC == 8.4.1+tested-with: GHC == 8.8.1 source-repository head@@ -32,8 +32,8 @@ GHC-Options: -Wall build-depends: base >=4.8 && < 5 , refact >= 0.2- , ghc-exactprint >= 0.5.7.0- , ghc >= 8.6.0 && < 8.8+ , ghc-exactprint >= 0.6.2+ , ghc >= 8.8.1 , containers , syb , mtl@@ -59,8 +59,8 @@ ghc-options: -Wall -fno-warn-unused-do-bind build-depends: base >= 4.8 && < 5 , refact >= 0.2- , ghc-exactprint >= 0.5.7.0- , ghc >= 8.6.0 && < 8.8+ , ghc-exactprint >= 0.6.2+ , ghc >= 8.8.1 , containers , syb , mtl@@ -93,7 +93,7 @@ , base < 5 , refact >= 0.2 , ghc-exactprint >= 0.5.7.0- , ghc >= 8.6.0 && < 8.8+ , ghc >= 8.8.1 , containers , syb , mtl
src/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} module Main where import Refact.Run
src/Refact/Apply.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE GADTs #-} module Refact.Apply (@@ -303,23 +303,29 @@ -- Substitute the template into the original AST.-doGenReplacement :: (Data ast, Data a)+doGenReplacement :: (Data (SrcSpanLess ast), HasSrcSpan ast, Data a) => a- -> (GHC.Located ast -> Bool)- -> GHC.Located ast- -> GHC.Located ast- -> State (Anns, Bool) (GHC.Located ast)+ -> (ast -> Bool)+ -> ast+ -> ast+ -> State (Anns, Bool) ast doGenReplacement m p new old = if p old then do s <- get- let (v, st) = runState (modifyAnnKey m old new) (fst s)+ let n = decomposeSrcSpan new+ o = decomposeSrcSpan old+ (v, st) = runState (modifyAnnKey m o n) (fst s) modify (const (st, True))- return v+ return $ composeSrcSpan v else return old -replaceWorker :: (Annotate a, Data mod) => Anns -> mod- -> Parser (GHC.Located a) -> Int- -> Refactoring GHC.SrcSpan -> (Anns, mod)+replaceWorker :: (Annotate a, HasSrcSpan a, Data mod, Data (SrcSpanLess a))+ => Anns+ -> mod+ -> Parser a+ -> Int+ -> Refactoring GHC.SrcSpan+ -> (Anns, mod) replaceWorker as m parser seed Replace{..} = let replExprLocation = pos uniqueName = "template" ++ show seed@@ -329,7 +335,7 @@ Left err -> error (show err) (newExpr, newAnns) = runState (substTransform m subts template) (mergeAnns as relat) replacementPred (GHC.L l _) = l == replExprLocation- transformation = everywhereM (mkM (doGenReplacement m replacementPred newExpr))+ transformation = everywhereM (mkM (doGenReplacement m (replacementPred . decomposeSrcSpan) newExpr)) in case runState (transformation m) (newAnns, False) of (finalM, (finalAs, True)) -> (finalAs, finalM) -- Failed to find a replacment so don't make any changes
src/Refact/Run.hs view
@@ -1,19 +1,18 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-}-- {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoMonomorphismRestriction #-} module Refact.Run where import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Print-import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleWithOptions)+import qualified Language.Haskell.GHC.ExactPrint.Parsers as EP+ ( defaultCppOptions+ , ghcWrapper+ , initDynFlags+ , parseModuleApiAnnsWithCppInternal+ , postParseTransform+ ) import Language.Haskell.GHC.ExactPrint.Utils @@ -23,6 +22,8 @@ import Refact.Fixity import Refact.Utils (toGhcSrcSpan, Module) import qualified SrcLoc as GHC+import qualified DynFlags as GHC (parseDynamicFlagsCmdLine)+import qualified GHC as GHC (setSessionDynFlags, ParsedSource) import Options.Applicative import Data.Maybe@@ -75,7 +76,7 @@ "2" -> Loud _ -> Normal -parsePos :: Monad m => String -> m (Int, Int)+parsePos :: MonadFail m => String -> m (Int, Int) parsePos s = case span isDigit s of (line, ',':col) ->@@ -96,6 +97,7 @@ , optionsDebug :: Bool , optionsRoundtrip :: Bool , optionsVersion :: Bool+ , optionsLanguage :: [String] , optionsPos :: Maybe (Int, Int) } @@ -140,6 +142,11 @@ switch (long "version" <> help "Display version number") <*>+ many (strOption (long "language"+ <> short 'X'+ <> help "Language extensions (e.g. LambdaCase, RankNTypes)"+ <> metavar "Extensions"))+ <*> option (Just <$> (str >>= parsePos)) (long "pos" <> value Nothing@@ -182,13 +189,21 @@ -- Pipe +parseModuleWithArgs :: [String] -> FilePath -> IO (Either (SrcSpan, String) (Anns, GHC.ParsedSource))+parseModuleWithArgs ghcArgs fp = EP.ghcWrapper $ do+ dflags1 <- EP.initDynFlags fp+ (dflags2, _, _) <- GHC.parseDynamicFlagsCmdLine dflags1 (map GHC.noLoc ghcArgs)+ _ <- GHC.setSessionDynFlags dflags2+ res <- EP.parseModuleApiAnnsWithCppInternal EP.defaultCppOptions dflags2 fp+ return $ EP.postParseTransform res rigidLayout runPipe :: Options -> FilePath -> IO () runPipe Options{..} file = do let verb = optionsVerbosity+ let ghcArgs = map ("-X" ++) optionsLanguage when (verb == Loud) (traceM "Parsing module") (as, m) <- either (error . show) (uncurry applyFixities)- <$> parseModuleWithOptions rigidLayout file+ <$> parseModuleWithArgs ghcArgs file when optionsDebug (putStrLn (showAnnData as 0 m)) rawhints <- getHints optionsRefactFile when (verb == Loud) (traceM "Got raw hints")
src/Refact/Utils.hs view
@@ -63,7 +63,7 @@ type Decl = GHC.Located (GHC.HsDecl GHC.GhcPs) -type Pat = GHC.LPat GHC.GhcPs+type Pat = GHC.Located (GHC.Pat GHC.GhcPs) type Name = GHC.Located GHC.RdrName
tests/Test.hs view
@@ -47,6 +47,7 @@ , optionsRoundtrip = False , optionsDebug = False , optionsVersion = False+ , optionsLanguage = ["LambdaCase"] , optionsPos = Nothing } action =
+ tests/examples/LambdaCase01.hs view
@@ -0,0 +1,5 @@+-- NOTE: The tests run with `-XLambdaCase`.+-- If that option is not preserved, parsing here will fail.+foo = \case+ 1 -> \x -> x+ _ -> \x -> 0
+ tests/examples/LambdaCase01.hs.expected view
@@ -0,0 +1,5 @@+-- NOTE: The tests run with `-XLambdaCase`.+-- If that option is not preserved, parsing here will fail.+foo = \case+ 1 -> id+ _ -> const 0
+ tests/examples/LambdaCase01.hs.refact view
@@ -0,0 +1,1 @@+[("LambdaCase01.hs:4:8: Warning: Use id\nFound:\n \\ x -> x\nPerhaps:\n id\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 4, startCol = 8, endLine = 4, endCol = 15}, subts = [], orig = "id"}]),("LambdaCase01.hs:5:8: Suggestion: Use const\nFound:\n \\ x -> 0\nPerhaps:\n (const 0)\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 8, endLine = 5, endCol = 15}, subts = [("y",SrcSpan {startLine = 5, startCol = 14, endLine = 5, endCol = 15})], orig = "const y"}])]