apply-refact 0.4.1.0 → 0.5.0.0
raw patch · 8 files changed
+323/−296 lines, 8 filesdep ~basedep ~ghcdep ~ghc-exactprint
Dependency ranges changed: base, ghc, ghc-exactprint
Files
- CHANGELOG +7/−3
- apply-refact.cabal +23/−11
- src/Main.hs +2/−259
- src/Refact/Apply.hs +7/−6
- src/Refact/Fixity.hs +8/−7
- src/Refact/Run.hs +266/−0
- src/Refact/Utils.hs +8/−8
- tests/Test.hs +2/−2
CHANGELOG view
@@ -1,10 +1,14 @@+v0.5.0.0++ * 8.4 release compatibility+ v0.4.1.0 - * 8.2 release compatability+ * 8.2 release compatibility v0.4.0.0 - * 8.2rc2 compatability+ * 8.2rc2 compatibility v0.3.0.1 @@ -12,7 +16,7 @@ v0.3 - * GHC 8.0 compatability+ * GHC 8.0 compatibility v0.2
apply-refact.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: apply-refact-version: 0.4.1.0+version: 0.5.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.0.1+tested-with: GHC == 8.4.1 source-repository head@@ -30,10 +30,10 @@ , Refact.Apply , Refact.Fixity GHC-Options: -Wall- build-depends: base >=4.8 && <4.11+ build-depends: base >=4.8 && < 5 , refact >= 0.2- , ghc-exactprint >= 0.5.3.1- , ghc >= 8.2.0 && < 8.3+ , ghc-exactprint >= 0.5.6.1+ , ghc >= 8.4.0 && < 8.6 , containers , syb , mtl@@ -48,13 +48,19 @@ executable refactor main-is: Main.hs+ other-modules:+ Paths_apply_refact+ Refact.Apply+ Refact.Fixity+ Refact.Utils+ Refact.Run hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind- build-depends: base >= 4.8 && < 4.11+ build-depends: base >= 4.8 && < 5 , refact >= 0.2- , ghc-exactprint >= 0.5.3.1- , ghc >= 8.2.0 && < 8.3+ , ghc-exactprint >= 0.5.6.1+ , ghc >= 8.4.0 && < 8.6 , containers , syb , mtl@@ -71,7 +77,13 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests, src main-is: Test.hs- GHC-Options: -threaded -main-is Test+ other-modules:+ Paths_apply_refact+ Refact.Run+ Refact.Apply+ Refact.Fixity+ Refact.Utils+ GHC-Options: -threaded Default-language: Haskell2010 if impl (ghc < 7.10) buildable: False@@ -80,8 +92,8 @@ , tasty-expected-failure , base < 5 , refact >= 0.2- , ghc-exactprint >= 0.5.3.1- , ghc >= 8.2.0 && < 8.3+ , ghc-exactprint >= 0.5.6.1+ , ghc >= 8.4.0 && < 8.6 , containers , syb , mtl
src/Main.hs view
@@ -1,265 +1,8 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}---{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoMonomorphismRestriction #-} module Main where -import Language.Haskell.GHC.ExactPrint-import Language.Haskell.GHC.ExactPrint.Print-import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleWithOptions)-import Language.Haskell.GHC.ExactPrint.Utils---import qualified Refact.Types as R-import Refact.Types hiding (SrcSpan)-import Refact.Apply-import Refact.Fixity-import Refact.Utils (toGhcSrcSpan, Module)-import qualified SrcLoc as GHC--import Options.Applicative-import Data.Maybe-import Data.Monoid ( (<>) )-import Control.Monad.Trans.Maybe-import Data.List hiding (find)--import System.IO-import System.IO.Temp-import System.FilePath.Find-import System.Exit-import qualified System.PosixCompat.Files as F--import Control.Monad-import Control.Monad.State-import Control.Monad.Identity--import Paths_apply_refact-import Data.Version--import Debug.Trace--import SrcLoc-import Text.Read-import Data.Char---parseVerbosity :: Monad m => String -> m Verbosity-parseVerbosity s =- return $ case s of- "0" -> Silent- "1" -> Normal- "2" -> Loud- _ -> Normal--parsePos :: Monad m => String -> m (Int, Int)-parsePos s =- case span isDigit s of- (line, ',':col) ->- case (,) <$> readMaybe line <*> readMaybe col of- Just l -> return l- Nothing -> fail "Invalid input"- _ -> fail "Invalid input"--data Target = StdIn | File FilePath--data Options = Options- { optionsTarget :: Maybe FilePath -- ^ Where to process hints- , optionsRefactFile :: Maybe FilePath -- ^ The refactorings to process- , optionsInplace :: Bool- , optionsOutput :: Maybe FilePath -- ^ Whether to overwrite the file inplace- , optionsVerbosity :: Verbosity- , optionsStep :: Bool -- ^ Ask before applying each hint- , optionsDebug :: Bool- , optionsRoundtrip :: Bool- , optionsVersion :: Bool- , optionsPos :: Maybe (Int, Int)- }--options :: Parser Options-options =- Options <$>- optional (argument str (metavar "TARGET"))- <*>- option (Just <$> str)- (long "refact-file"- <> value Nothing- <> help "A file which specifies which refactorings to perform")-- <*>- switch (long "inplace"- <> short 'i'- <> help "Whether to overwrite the target inplace")- <*>- optional (strOption (long "output"- <> short 'o'- <> help "Name of the file to output to"- <> metavar "FILE"))- <*>- option (str >>= parseVerbosity)- ( long "verbosity"- <> short 'v'- <> value Normal- <> help "Specify verbosity, 0, 1 or 2. The default is 1 and 0 is silent.")- <*>- switch (short 's'- <> long "step"- <> help "Ask before applying each refactoring")- <*>- switch (long "debug"- <> help "Output the GHC AST for debugging"- <> internal)- <*>- switch (long "roundtrip"- <> help "Run ghc-exactprint on the file"- <> internal)- <*>- switch (long "version"- <> help "Display version number")- <*>- option (Just <$> (str >>= parsePos))- (long "pos"- <> value Nothing- <> metavar "<line>,<col>"- <> help "Apply hints relevant to a specific position")---optionsWithHelp :: ParserInfo Options-optionsWithHelp- =- info (helper <*> options)- ( fullDesc- <> progDesc "Automatically perform refactorings on haskell source files"- <> header "refactor" )-+import Refact.Run main :: IO ()-main = do- o@Options{..} <- execParser optionsWithHelp- when optionsVersion (putStr ("v" ++ showVersion version) >> exitSuccess)- unless (isJust optionsTarget || isJust optionsRefactFile)- (error "Must specify either the target file or the refact file")- case optionsTarget of- Nothing ->- withSystemTempFile "stdin" (\fp hin -> do- getContents >>= hPutStrLn hin >> hClose hin- runPipe o fp)- Just target -> do- targetStatus <- F.getFileStatus target- if F.isDirectory targetStatus- then findHsFiles target >>= mapM_ (runPipe o)- else runPipe o target---- Given base directory finds all haskell source files-findHsFiles :: FilePath -> IO [FilePath]-findHsFiles = find filterDirectory filterFilename--filterDirectory :: FindClause Bool-filterDirectory =- p <$> fileName- where- p x- | "." `isPrefixOf` x = False- | otherwise = True--filterFilename :: FindClause Bool-filterFilename = do- ext <- extension- fname <- fileName- return (ext == ".hs" && p fname)- where- p x- | "Setup.hs" `isInfixOf` x = False- | otherwise = True----- Pipe---runPipe :: Options -> FilePath -> IO ()-runPipe Options{..} file = do- let verb = optionsVerbosity- when (verb == Loud) (traceM "Parsing module")- (as, m) <- either (error . show) (uncurry applyFixities)- <$> parseModuleWithOptions rigidLayout file- when optionsDebug (putStrLn (showAnnData as 0 m))- rawhints <- getHints optionsRefactFile- when (verb == Loud) (traceM "Got raw hints")- let inp :: [(String, [Refactoring R.SrcSpan])] = read rawhints- n = length inp- when (verb == Loud) (traceM $ "Read " ++ show n ++ " hints")- let noOverlapInp = removeOverlap verb inp- refacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp-- posFilter (_, rs) =- case optionsPos of- Nothing -> True- Just p -> any (flip spans p . pos) rs- filtRefacts = filter posFilter refacts--- when (verb >= Normal) (traceM $ "Applying " ++ show (length (concatMap snd filtRefacts)) ++ " hints")- when (verb == Loud) (traceM $ show filtRefacts)- -- need a check here to avoid overlap- (ares, res) <- if optionsStep- then fromMaybe (as, m) <$> runMaybeT (refactoringLoop as m filtRefacts)- else return . flip evalState 0 $- foldM (uncurry runRefactoring) (as, m) (concatMap snd filtRefacts)- when (optionsDebug) (putStrLn (showAnnData ares 0 res))- let output = runIdentity $ exactPrintWithOptions refactOptions res ares- if optionsInplace && isJust optionsTarget- then writeFile file output- else case optionsOutput of- Nothing -> putStr output- Just f -> do- when (verb == Loud) (traceM $ "Writing result to " ++ f)- writeFile f output--data LoopOption = LoopOption- { desc :: String- , perform :: MaybeT IO (Anns, Module) }--refactoringLoop :: Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])]- -> MaybeT IO (Anns, Module)-refactoringLoop as m [] = return (as, m)-refactoringLoop as m ((_, []): rs) = refactoringLoop as m rs-refactoringLoop as m hints@((hintDesc, rs): rss) =- do inp <- liftIO $ do- putStrLn hintDesc- putStrLn $ "Apply hint [" ++ intercalate ", " (map fst opts) ++ "]"- -- In case that the input also comes from stdin- withFile "/dev/tty" ReadMode hGetLine- case lookup inp opts of- Just opt -> perform opt- Nothing -> loopHelp- where- opts =- [ ("y", LoopOption "Apply current hint" yAction)- , ("n", LoopOption "Don't apply the current hint" (refactoringLoop as m rss))- , ("q", LoopOption "Apply no further hints" (return (as, m)))- , ("d", LoopOption "Discard previous changes" mzero )- , ("v", LoopOption "View current file" (liftIO (putStrLn (exactPrint m as))- >> refactoringLoop as m hints))- , ("?", LoopOption "Show this help menu" loopHelp)]- loopHelp = do- liftIO . putStrLn . unlines . map mkLine $ opts- refactoringLoop as m hints- mkLine (c, opt) = c ++ " - " ++ desc opt- -- Force to force bottoms- yAction =- let (!r1, !r2) = flip evalState 0 $ foldM (uncurry runRefactoring) (as, m) rs- in do- exactPrint r2 r1 `seq` return ()- refactoringLoop r1 r2 rss---getHints :: Maybe FilePath -> IO String-getHints (Just hintFile) = readFile hintFile-getHints Nothing = getContents+main = refactMain
src/Refact/Apply.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GADTs #-} module Refact.Apply ( runRefactoring@@ -20,7 +21,7 @@ import Language.Haskell.GHC.ExactPrint.Delta import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Print-import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn) import Language.Haskell.GHC.ExactPrint.Utils import Data.Maybe@@ -49,7 +50,6 @@ import Debug.Trace -import Data.Monoid import Refact.Fixity import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R@@ -181,7 +181,7 @@ return (as, removeAsKeyword m) where removeAsKeyword = everywhere (mkT go)- go :: LImportDecl GHC.RdrName -> LImportDecl GHC.RdrName+ go :: LImportDecl GHC.GhcPs -> LImportDecl GHC.GhcPs go imp@(GHC.L l i) | l == pos = GHC.L l (i { ideclAs = Nothing }) | otherwise = imp @@ -193,14 +193,14 @@ let newMN = GHC.L ss (GHC.mkModuleName s) newAnns = relativiseApiAnns newMN (Map.empty, Map.empty) in return (newAnns, newMN)-parseBind :: Parser (GHC.LHsBind GHC.RdrName)+parseBind :: Parser (GHC.LHsBind GHC.GhcPs) parseBind dyn fname s = case parseDecl dyn fname s of -- Safe as we add no annotations to the ValD Right (as, GHC.L l (GHC.ValD b)) -> Right (as, GHC.L l b) Right (_, GHC.L l _) -> Left (l, "Not a HsBind") Left e -> Left e-parseMatch :: Parser (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+parseMatch :: Parser (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) parseMatch dyn fname s = case parseBind dyn fname s of Right (as, GHC.L l GHC.FunBind{fun_matches}) ->@@ -255,7 +255,8 @@ where subst :: FunBind -> Name -> M FunBind subst (GHC.FunRhs n b s) new = do- let fakeExpr = GHC.L (getLoc new) (GHC.VarPat new)+ let fakeExpr :: Located (GHC.Pat GhcPs)+ fakeExpr = GHC.L (getLoc new) (GHC.VarPat new) -- Low level version as we need to combine the annotation information -- from the template RdrName and the original VarPat. modify (\r -> replaceAnnKey r (mkAnnKey n) (mkAnnKey fakeExpr) (mkAnnKey new) (mkAnnKey fakeExpr))
src/Refact/Fixity.hs view
@@ -9,11 +9,12 @@ import BasicTypes (Fixity(..), defaultFixity, compareFixity, negateFixity, FixityDirection(..), SourceText(..)) import HsExpr import RdrName+import HsExtension import OccName import PlaceHolder import Data.Generics hiding (Fixity) import Data.Maybe-import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, GhcTc, GhcRn) import Control.Monad.State import qualified Data.Map as Map@@ -25,7 +26,7 @@ applyFixities as m = let (as', m') = swap $ runState (everywhereM (mkM expFix) m) as in (as', m') --error (showAnnData as 0 m ++ showAnnData as' 0 m') -expFix :: LHsExpr RdrName -> M (LHsExpr RdrName)+expFix :: LHsExpr GhcPs -> M (LHsExpr GhcPs) expFix (L loc (OpApp l op _ r)) = mkOpAppRn baseFixities loc l op (findFixity baseFixities op) r @@ -47,11 +48,11 @@ mkOpAppRn :: [(String, Fixity)] -> SrcSpan- -> LHsExpr RdrName -- Left operand; already rearrange- -> LHsExpr RdrName -> Fixity -- Operator and fixity- -> LHsExpr RdrName -- Right operand (not an OpApp, but might+ -> LHsExpr GhcPs -- Left operand; already rearrange+ -> LHsExpr GhcPs -> Fixity -- Operator and fixity+ -> LHsExpr GhcPs -- Right operand (not an OpApp, but might -- be a NegApp)- -> M (LHsExpr RdrName)+ -> M (LHsExpr GhcPs) -- (e11 `op1` e12) `op2` e2 mkOpAppRn fs loc e1@(L _ (OpApp e11 op1 p e12)) op2 fix2 e2@@ -108,7 +109,7 @@ askFix :: [(String, Fixity)] -> String -> Fixity askFix xs = \k -> lookupWithDefault defaultFixity k xs where- lookupWithDefault def k mp1 = fromMaybe def $ lookup k mp1+ lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1
+ src/Refact/Run.hs view
@@ -0,0 +1,266 @@+{-# 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 Language.Haskell.GHC.ExactPrint.Utils+++import qualified Refact.Types as R+import Refact.Types hiding (SrcSpan)+import Refact.Apply+import Refact.Fixity+import Refact.Utils (toGhcSrcSpan, Module)+import qualified SrcLoc as GHC++import Options.Applicative+import Data.Maybe+import Data.Monoid ( (<>) )+import Control.Monad.Trans.Maybe+import Data.List hiding (find)++import System.IO+import System.IO.Temp+import System.FilePath.Find+import System.Exit+import qualified System.PosixCompat.Files as F++import Control.Monad+import Control.Monad.State+import Control.Monad.Identity++import Paths_apply_refact+import Data.Version++import Debug.Trace++import SrcLoc+import Text.Read+import Data.Char++refactMain :: IO ()+refactMain = do+ o@Options{..} <- execParser optionsWithHelp+ when optionsVersion (putStr ("v" ++ showVersion version) >> exitSuccess)+ unless (isJust optionsTarget || isJust optionsRefactFile)+ (error "Must specify either the target file or the refact file")+ case optionsTarget of+ Nothing ->+ withSystemTempFile "stdin" (\fp hin -> do+ getContents >>= hPutStrLn hin >> hClose hin+ runPipe o fp)+ Just target -> do+ targetStatus <- F.getFileStatus target+ if F.isDirectory targetStatus+ then findHsFiles target >>= mapM_ (runPipe o)+ else runPipe o target+++parseVerbosity :: Monad m => String -> m Verbosity+parseVerbosity s =+ return $ case s of+ "0" -> Silent+ "1" -> Normal+ "2" -> Loud+ _ -> Normal++parsePos :: Monad m => String -> m (Int, Int)+parsePos s =+ case span isDigit s of+ (line, ',':col) ->+ case (,) <$> readMaybe line <*> readMaybe col of+ Just l -> return l+ Nothing -> fail "Invalid input"+ _ -> fail "Invalid input"++data Target = StdIn | File FilePath++data Options = Options+ { optionsTarget :: Maybe FilePath -- ^ Where to process hints+ , optionsRefactFile :: Maybe FilePath -- ^ The refactorings to process+ , optionsInplace :: Bool+ , optionsOutput :: Maybe FilePath -- ^ Whether to overwrite the file inplace+ , optionsVerbosity :: Verbosity+ , optionsStep :: Bool -- ^ Ask before applying each hint+ , optionsDebug :: Bool+ , optionsRoundtrip :: Bool+ , optionsVersion :: Bool+ , optionsPos :: Maybe (Int, Int)+ }++options :: Parser Options+options =+ Options <$>+ optional (argument str (metavar "TARGET"))+ <*>+ option (Just <$> str)+ (long "refact-file"+ <> value Nothing+ <> help "A file which specifies which refactorings to perform")++ <*>+ switch (long "inplace"+ <> short 'i'+ <> help "Whether to overwrite the target inplace")+ <*>+ optional (strOption (long "output"+ <> short 'o'+ <> help "Name of the file to output to"+ <> metavar "FILE"))+ <*>+ option (str >>= parseVerbosity)+ ( long "verbosity"+ <> short 'v'+ <> value Normal+ <> help "Specify verbosity, 0, 1 or 2. The default is 1 and 0 is silent.")+ <*>+ switch (short 's'+ <> long "step"+ <> help "Ask before applying each refactoring")+ <*>+ switch (long "debug"+ <> help "Output the GHC AST for debugging"+ <> internal)+ <*>+ switch (long "roundtrip"+ <> help "Run ghc-exactprint on the file"+ <> internal)+ <*>+ switch (long "version"+ <> help "Display version number")+ <*>+ option (Just <$> (str >>= parsePos))+ (long "pos"+ <> value Nothing+ <> metavar "<line>,<col>"+ <> help "Apply hints relevant to a specific position")+++optionsWithHelp :: ParserInfo Options+optionsWithHelp+ =+ info (helper <*> options)+ ( fullDesc+ <> progDesc "Automatically perform refactorings on haskell source files"+ <> header "refactor" )++++-- Given base directory finds all haskell source files+findHsFiles :: FilePath -> IO [FilePath]+findHsFiles = find filterDirectory filterFilename++filterDirectory :: FindClause Bool+filterDirectory =+ p <$> fileName+ where+ p x+ | "." `isPrefixOf` x = False+ | otherwise = True++filterFilename :: FindClause Bool+filterFilename = do+ ext <- extension+ fname <- fileName+ return (ext == ".hs" && p fname)+ where+ p x+ | "Setup.hs" `isInfixOf` x = False+ | otherwise = True+++-- Pipe+++runPipe :: Options -> FilePath -> IO ()+runPipe Options{..} file = do+ let verb = optionsVerbosity+ when (verb == Loud) (traceM "Parsing module")+ (as, m) <- either (error . show) (uncurry applyFixities)+ <$> parseModuleWithOptions rigidLayout file+ when optionsDebug (putStrLn (showAnnData as 0 m))+ rawhints <- getHints optionsRefactFile+ when (verb == Loud) (traceM "Got raw hints")+ let inp :: [(String, [Refactoring R.SrcSpan])] = read rawhints+ n = length inp+ when (verb == Loud) (traceM $ "Read " ++ show n ++ " hints")+ let noOverlapInp = removeOverlap verb inp+ refacts = (fmap . fmap . fmap) (toGhcSrcSpan file) <$> noOverlapInp++ posFilter (_, rs) =+ case optionsPos of+ Nothing -> True+ Just p -> any (flip spans p . pos) rs+ filtRefacts = filter posFilter refacts+++ when (verb >= Normal) (traceM $ "Applying " ++ show (length (concatMap snd filtRefacts)) ++ " hints")+ when (verb == Loud) (traceM $ show filtRefacts)+ -- need a check here to avoid overlap+ (ares, res) <- if optionsStep+ then fromMaybe (as, m) <$> runMaybeT (refactoringLoop as m filtRefacts)+ else return . flip evalState 0 $+ foldM (uncurry runRefactoring) (as, m) (concatMap snd filtRefacts)+ when (optionsDebug) (putStrLn (showAnnData ares 0 res))+ let output = runIdentity $ exactPrintWithOptions refactOptions res ares+ if optionsInplace && isJust optionsTarget+ then writeFile file output+ else case optionsOutput of+ Nothing -> putStr output+ Just f -> do+ when (verb == Loud) (traceM $ "Writing result to " ++ f)+ writeFile f output++data LoopOption = LoopOption+ { desc :: String+ , perform :: MaybeT IO (Anns, Module) }++refactoringLoop :: Anns -> Module -> [(String, [Refactoring GHC.SrcSpan])]+ -> MaybeT IO (Anns, Module)+refactoringLoop as m [] = return (as, m)+refactoringLoop as m ((_, []): rs) = refactoringLoop as m rs+refactoringLoop as m hints@((hintDesc, rs): rss) =+ do inp <- liftIO $ do+ putStrLn hintDesc+ putStrLn $ "Apply hint [" ++ intercalate ", " (map fst opts) ++ "]"+ -- In case that the input also comes from stdin+ withFile "/dev/tty" ReadMode hGetLine+ case lookup inp opts of+ Just opt -> perform opt+ Nothing -> loopHelp+ where+ opts =+ [ ("y", LoopOption "Apply current hint" yAction)+ , ("n", LoopOption "Don't apply the current hint" (refactoringLoop as m rss))+ , ("q", LoopOption "Apply no further hints" (return (as, m)))+ , ("d", LoopOption "Discard previous changes" mzero )+ , ("v", LoopOption "View current file" (liftIO (putStrLn (exactPrint m as))+ >> refactoringLoop as m hints))+ , ("?", LoopOption "Show this help menu" loopHelp)]+ loopHelp = do+ liftIO . putStrLn . unlines . map mkLine $ opts+ refactoringLoop as m hints+ mkLine (c, opt) = c ++ " - " ++ desc opt+ -- Force to force bottoms+ yAction =+ let (!r1, !r2) = flip evalState 0 $ foldM (uncurry runRefactoring) (as, m) rs+ in do+ exactPrint r2 r1 `seq` return ()+ refactoringLoop r1 r2 rss+++getHints :: Maybe FilePath -> IO String+getHints (Just hintFile) = readFile hintFile+getHints Nothing = getContents+
src/Refact/Utils.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}@@ -35,6 +34,7 @@ import SrcLoc import qualified SrcLoc as GHC import qualified RdrName as GHC+import qualified HsExtension as GHC import qualified ApiAnnotation as GHC import qualified FastString as GHC import qualified GHC hiding (parseModule)@@ -55,21 +55,21 @@ -- type M a = State Anns a -type Module = (GHC.Located (GHC.HsModule GHC.RdrName))+type Module = (GHC.Located (GHC.HsModule GHC.GhcPs)) -type Expr = GHC.Located (GHC.HsExpr GHC.RdrName)+type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs) -type Type = GHC.Located (GHC.HsType GHC.RdrName)+type Type = GHC.Located (GHC.HsType GHC.GhcPs) -type Decl = GHC.Located (GHC.HsDecl GHC.RdrName)+type Decl = GHC.Located (GHC.HsDecl GHC.GhcPs) -type Pat = GHC.LPat GHC.RdrName+type Pat = GHC.LPat GHC.GhcPs type Name = GHC.Located GHC.RdrName -type Stmt = ExprLStmt GHC.RdrName+type Stmt = ExprLStmt GHC.GhcPs -type Import = LImportDecl GHC.RdrName+type Import = LImportDecl GHC.GhcPs type FunBind = HsMatchContext GHC.RdrName
tests/Test.hs view
@@ -1,4 +1,4 @@-module Test where+module Main where import Test.Tasty import Test.Tasty.Golden@@ -7,7 +7,7 @@ import Options.Applicative -import Main hiding (main)+import Refact.Run import Refact.Apply import System.IO.Silently