diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/apply-refact.cabal b/apply-refact.cabal --- a/apply-refact.cabal +++ b/apply-refact.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 "," - <> 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 diff --git a/src/Refact/Apply.hs b/src/Refact/Apply.hs --- a/src/Refact/Apply.hs +++ b/src/Refact/Apply.hs @@ -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)) diff --git a/src/Refact/Fixity.hs b/src/Refact/Fixity.hs --- a/src/Refact/Fixity.hs +++ b/src/Refact/Fixity.hs @@ -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 diff --git a/src/Refact/Run.hs b/src/Refact/Run.hs new file mode 100644 --- /dev/null +++ b/src/Refact/Run.hs @@ -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 "," + <> 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 + diff --git a/src/Refact/Utils.hs b/src/Refact/Utils.hs --- a/src/Refact/Utils.hs +++ b/src/Refact/Utils.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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