Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit d633537

Browse files
JPMoresmauJPMoresmau
committed
Merge pull request #133 from alanz/apply-refact-plugin
Apply refact plugin
2 parents 5f6f792 + 8425de6 commit d633537

File tree

10 files changed

+295
-12
lines changed

10 files changed

+295
-12
lines changed

‎app/MainHie.hs

+6-4
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ import System.Environment
3434
-- ---------------------------------------------------------------------
3535
-- plugins
3636

37+
import Haskell.Ide.ApplyRefactPlugin
3738
import Haskell.Ide.Engine.BasePlugin
3839
import Haskell.Ide.ExamplePlugin2
3940
import Haskell.Ide.GhcModPlugin
@@ -47,11 +48,12 @@ plugins = Map.fromList
4748
[
4849
-- Note: statically including known plugins. In future this map could be set
4950
-- up via a config file of some kind.
50-
("eg2", example2Descriptor)
51-
, ("ghcmod", ghcmodDescriptor)
52-
, ("hare", hareDescriptor)
51+
("applyrefact", applyRefactDescriptor)
52+
, ("eg2", example2Descriptor)
53+
, ("ghcmod", ghcmodDescriptor)
54+
, ("hare", hareDescriptor)
5355
-- The base plugin, able to answer questions about the IDE Engine environment.
54-
, ("base", baseDescriptor)
56+
, ("base", baseDescriptor)
5557
]
5658

5759
-- ---------------------------------------------------------------------

‎haskell-ide-engine.cabal

+4
Original file line numberDiff line numberDiff line change
@@ -68,13 +68,15 @@ executable hie
6868
build-depends: base
6969
, Cabal >= 1.22
7070
, aeson
71+
, apply-refact
7172
, containers
7273
, directory
7374
, fast-logger
7475
, ghc
7576
, ghc-mod
7677
, gitrev >= 1.1
7778
, haskell-ide-engine
79+
, hie-apply-refact
7880
, hie-example-plugin2
7981
, hie-ghc-mod
8082
, hie-hare
@@ -94,6 +96,7 @@ test-suite haskell-ide-test
9496
hs-source-dirs: test
9597
main-is: Spec.hs
9698
other-modules:
99+
ApplyRefactPluginSpec
97100
DispatcherSpec
98101
GhcModPluginSpec
99102
HaRePluginSpec
@@ -108,6 +111,7 @@ test-suite haskell-ide-test
108111
, directory
109112
, fast-logger
110113
, haskell-ide-engine
114+
, hie-apply-refact
111115
, hie-ghc-mod
112116
, hie-hare
113117
, hie-plugin-api

‎hie-apply-refact/Haskell/Ide/ApplyRefactPlugin.hs

+134
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,134 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE GADTs #-}
3+
module Haskell.Ide.ApplyRefactPlugin where
4+
5+
import Control.Exception
6+
import Control.Monad.IO.Class
7+
import qualified Data.Text as T
8+
import qualified Data.Text.IO as T
9+
import Data.Vinyl
10+
import Haskell.Ide.Engine.MonadFunctions
11+
import Haskell.Ide.Engine.PluginDescriptor
12+
import Haskell.Ide.Engine.PluginUtils
13+
import Haskell.Ide.Engine.SemanticTypes
14+
import qualified Language.Haskell.GhcMod as GM (defaultOptions)
15+
import Language.Haskell.HLint
16+
import Language.Haskell.HLint3
17+
import Refact.Apply
18+
import qualified Refact.Types as R
19+
import Refact.Types hiding (SrcSpan)
20+
import System.Directory
21+
import System.Exit
22+
import System.FilePath.Posix
23+
import System.IO
24+
import System.IO.Extra
25+
26+
-- ---------------------------------------------------------------------
27+
28+
applyRefactDescriptor :: PluginDescriptor
29+
applyRefactDescriptor = PluginDescriptor
30+
{
31+
pdUIShortName = "ApplyRefact"
32+
, pdUIOverview = "apply-refact applies refactorings specified by the refact package. It is currently integrated into hlint to enable the automatic application of suggestions."
33+
, pdCommands =
34+
[
35+
buildCommand applyOneCmd "applyOne" "Apply a single hint"
36+
[".hs"] [CtxPoint] []
37+
38+
, buildCommand applyAllCmd "applyAll" "Apply all hints to the file"
39+
[".hs"] [CtxFile] []
40+
41+
]
42+
, pdExposedServices = []
43+
, pdUsedServices = []
44+
}
45+
46+
-- ---------------------------------------------------------------------
47+
48+
applyOneCmd :: CommandFunc HieDiff
49+
applyOneCmd = CmdSync $ \_ctxs req -> do
50+
case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
51+
Left err -> return err
52+
Right (ParamFile fileName :& ParamPos pos :& RNil) -> do
53+
res <- liftIO $ applyHint (T.unpack fileName) (Just pos)
54+
logm $ "applyOneCmd:res=" ++ show res
55+
case res of
56+
Left err -> return $ IdeResponseFail (IdeError PluginError
57+
(T.pack $ "applyOne: " ++ show err) Nothing)
58+
Right fs -> return (IdeResponseOk fs)
59+
Right _ -> return $ IdeResponseError (IdeError InternalError
60+
"ApplyRefactPlugin.applyOneCmd: ghc’s exhaustiveness checker is broken" Nothing)
61+
62+
63+
-- ---------------------------------------------------------------------
64+
65+
applyAllCmd :: CommandFunc HieDiff
66+
applyAllCmd = CmdSync $ \_ctxs req -> do
67+
case getParams (IdFile "file" :& RNil) req of
68+
Left err -> return err
69+
Right (ParamFile fileName :& RNil) -> do
70+
res <- liftIO $ applyHint (T.unpack fileName) Nothing
71+
logm $ "applyAllCmd:res=" ++ show res
72+
case res of
73+
Left err -> return $ IdeResponseFail (IdeError PluginError
74+
(T.pack $ "applyOne: " ++ show err) Nothing)
75+
Right fs -> return (IdeResponseOk fs)
76+
Right _ -> return $ IdeResponseError (IdeError InternalError
77+
"ApplyRefactPlugin.applyOneCmd: ghc’s exhaustiveness checker is broken" Nothing)
78+
79+
80+
-- ---------------------------------------------------------------------
81+
82+
applyHint :: FilePath -> Maybe Pos -> IO (Either String HieDiff)
83+
applyHint file mpos = do
84+
withTempFile $ \f -> do
85+
-- absFile <- makeAbsolute file
86+
-- hlint /tmp/Foo.hs --refactor --refactor-options="-o /tmp/Bar.hs --pos 2,8"
87+
88+
let
89+
optsf = "-o " ++ f
90+
opts = case mpos of
91+
Nothing -> optsf
92+
Just (r,c) -> optsf ++ " --pos " ++ show r ++ "," ++ show c
93+
-- let hlintOpts = [file, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
94+
let hlintOpts = [file, "--quiet" ]
95+
logm $ "applyHint=" ++ show hlintOpts
96+
res <- catchException $ hlint hlintOpts
97+
logm $ "applyHint:res=" ++ show res
98+
-- res <- hlint hlintOpts
99+
case res of
100+
Left x -> return $ Left (show x)
101+
Right x -> do
102+
let commands = makeApplyRefact x
103+
logm $ "applyHint:commands=" ++ show commands
104+
appliedFile <- applyRefactorings mpos commands file
105+
diff <- makeDiffResult file (T.pack appliedFile)
106+
logm $ "applyHint:diff=" ++ show diff
107+
return $ Right diff
108+
109+
-- ---------------------------------------------------------------------
110+
111+
makeApplyRefact :: [Suggestion] -> [(String, [Refactoring R.SrcSpan])]
112+
makeApplyRefact suggestions =
113+
map (\(Suggestion i) -> (show i, ideaRefactoring i)) suggestions
114+
115+
-- ---------------------------------------------------------------------
116+
117+
118+
makeDiffResult :: FilePath -> T.Text -> IO HieDiff
119+
makeDiffResult orig new = do
120+
origText <- T.readFile orig
121+
let (HieDiff f s d) = diffText (orig,origText) ("changed",new)
122+
f' <- liftIO $ makeRelativeToCurrentDirectory f
123+
-- return (HieDiff f' s' d)
124+
return (HieDiff f' "changed" d)
125+
126+
-- ---------------------------------------------------------------------
127+
128+
catchException :: (IO t) -> IO (Either String t)
129+
catchException f = do
130+
res <- handle handler (f >>= \r -> return $ Right r)
131+
return res
132+
where
133+
handler:: SomeException -> IO (Either String t)
134+
handler e = return (Left (show e))

‎hie-apply-refact/Setup.hs

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
import Distribution.Simple
2+
main = defaultMain

‎hie-apply-refact/hie-apply-refact.cabal

+31
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
name: hie-apply-refact
2+
version: 0.1.0.0
3+
synopsis: Haskell IDE Apply Refact plugin
4+
license: BSD3
5+
license-file: ../LICENSE
6+
author: Alan Zimmerman
7+
maintainer: [email protected] (for now)
8+
copyright: 2015 TBD
9+
category: Web
10+
build-type: Simple
11+
-- extra-source-files:
12+
cabal-version: >=1.10
13+
14+
library
15+
exposed-modules: Haskell.Ide.ApplyRefactPlugin
16+
build-depends: base >= 4.7 && < 5
17+
, aeson
18+
, apply-refact
19+
, containers
20+
, directory
21+
, extra
22+
, filepath
23+
, ghc-mod
24+
, hie-plugin-api
25+
, hlint
26+
, refact
27+
, text
28+
, transformers
29+
, vinyl >= 0.5 && < 0.6
30+
ghc-options: -Wall
31+
default-language: Haskell2010

‎hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs

+13-7
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Haskell.Ide.Engine.PluginUtils
88
getParams
99
, mapEithers
1010
, diffFiles
11+
, diffText
1112
-- * Helper functions for errors
1213
, missingParameter
1314
, incorrectParameter
@@ -89,11 +90,16 @@ diffFiles :: FilePath -> FilePath -> IO HieDiff
8990
diffFiles f1 f2 = do
9091
f1Text <- T.readFile f1
9192
f2Text <- T.readFile f2
92-
let diffb = getDiffBy (\(_,a) (_,b) -> a == b)
93-
(zip [1..] (T.lines f1Text))
94-
(zip [1..] (T.lines f2Text))
95-
isDiff (Both {}) = False
96-
isDiff _ = True
93+
return $ diffText (f1,f1Text) (f2,f2Text)
9794

98-
diff = filter isDiff diffb
99-
return (HieDiff f1 f2 diff)
95+
-- |Generate a 'HieDiff' value from a pair of source Text
96+
diffText :: (FilePath,T.Text) -> (FilePath,T.Text) -> HieDiff
97+
diffText (f1,f1Text) (f2,f2Text) = HieDiff f1 f2 diff
98+
where
99+
diffb = getDiffBy (\(_,a) (_,b) -> a == b)
100+
(zip [1..] (T.lines f1Text))
101+
(zip [1..] (T.lines f2Text))
102+
isDiff (Both {}) = False
103+
isDiff _ = True
104+
105+
diff = filter isDiff diffb

‎hie-plugin-api/Haskell/Ide/Engine/SemanticTypes.hs

+4
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,10 @@ instance ValidResponse RefactorResult where
6868
jsWrite (RefactorResult t) = H.fromList ["refactor" .= t]
6969
jsRead v = RefactorResult <$> v .: "refactor"
7070

71+
instance ValidResponse HieDiff where
72+
jsWrite d = H.fromList ["diff" .= d]
73+
jsRead v = v .: "diff"
74+
7175
instance ToJSON HieDiff where
7276
toJSON (HieDiff f s d) =
7377
object [ "first" .= toJSON f

‎stack.yaml

+10-1
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,9 @@
11
#resolver: lts-3.11
22
# Nightly has ghc-mod/cabal-helper, not in lts yet
3-
resolver: nightly-2015-12-02
3+
resolver: nightly-2015-12-11
44
packages:
55
- .
6+
- hie-apply-refact
67
- hie-example-plugin2
78
- hie-plugin-api
89
- hie-ghc-mod
@@ -13,6 +14,14 @@ packages:
1314
commit: b9bd4ebf77b22d2d9061d647d7799ddcc7c51228
1415
# commit: bff86be69f556f80a8dcd9dd42774ab77cb00eba
1516
extra-dep: true
17+
- location:
18+
git: https://github.com/alanz/hlint.git
19+
commit: e32f4d3cf32d15003e54d4f42afae7bf06b50168
20+
extra-dep: true
21+
- location:
22+
git: https://github.com/alanz/apply-refact.git
23+
commit: ba98a2902e5333519e60d38803f30f82c44eaffc
24+
extra-dep: true
1625
extra-deps:
1726
- HaRe-0.8.2.1
1827
- rosezipper-0.2

‎test/ApplyRefactPluginSpec.hs

+87
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,87 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
module ApplyRefactPluginSpec where
3+
4+
import Control.Concurrent.STM.TChan
5+
import Control.Monad.STM
6+
import Data.Aeson
7+
import Data.Algorithm.Diff
8+
import qualified Data.Map as Map
9+
import Haskell.Ide.Engine.Dispatcher
10+
import Haskell.Ide.Engine.Monad
11+
import Haskell.Ide.Engine.MonadFunctions
12+
import Haskell.Ide.Engine.PluginDescriptor
13+
import Haskell.Ide.Engine.SemanticTypes
14+
import Haskell.Ide.Engine.Types
15+
import Haskell.Ide.ApplyRefactPlugin
16+
import Test.Hspec
17+
18+
-- ---------------------------------------------------------------------
19+
20+
main :: IO ()
21+
main = hspec spec
22+
23+
spec :: Spec
24+
spec = do
25+
describe "apply-refact plugin" applyRefactSpec
26+
27+
-- -- |Used when running from ghci, and it sets the current directory to ./tests
28+
-- tt :: IO ()
29+
-- tt = do
30+
-- cd ".."
31+
-- hspec spec
32+
33+
-- ---------------------------------------------------------------------
34+
35+
testPlugins :: Plugins
36+
testPlugins = Map.fromList [("applyrefact",applyRefactDescriptor)]
37+
38+
-- TODO: break this out into a TestUtils file
39+
dispatchRequest :: IdeRequest -> IO (Maybe (IdeResponse Object))
40+
dispatchRequest req = do
41+
testChan <- atomically newTChan
42+
let cr = CReq "applyrefact" 1 req testChan
43+
r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch testPlugins cr)
44+
return r
45+
46+
-- ---------------------------------------------------------------------
47+
48+
applyRefactSpec :: Spec
49+
applyRefactSpec = do
50+
describe "apply-refact plugin commands" $ do
51+
52+
-- ---------------------------------
53+
54+
it "applies one hint only" $ do
55+
56+
let req = IdeRequest "applyOne" (Map.fromList [("file",ParamValP $ ParamFile "./test/testdata/ApplyRefact.hs")
57+
,("start_pos",ParamValP $ ParamPos (2,8))
58+
])
59+
r <- dispatchRequest req
60+
r `shouldBe`
61+
Just (IdeResponseOk (jsWrite (HieDiff
62+
{ dFirst = "./test/testdata/ApplyRefact.hs"
63+
, dSecond = "changed"
64+
, dDiff =
65+
[First (2,"main = (putStrLn \"hello\")")
66+
,Second (2,"main = putStrLn \"hello\"")]}
67+
)))
68+
69+
-- ---------------------------------
70+
71+
it "applies all hints" $ do
72+
73+
let req = IdeRequest "applyAll" (Map.fromList [("file",ParamValP $ ParamFile "./test/testdata/ApplyRefact.hs")
74+
])
75+
r <- dispatchRequest req
76+
r `shouldBe`
77+
Just (IdeResponseOk (jsWrite (HieDiff
78+
{ dFirst = "./test/testdata/ApplyRefact.hs"
79+
, dSecond = "changed"
80+
, dDiff =
81+
[First (2,"main = (putStrLn \"hello\")")
82+
,Second (2,"main = putStrLn \"hello\"")
83+
,First (4,"foo x = (x + 1)")
84+
,Second (4,"foo x = x + 1")]}
85+
)))
86+
87+
-- ---------------------------------

‎test/testdata/ApplyRefact.hs

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
2+
main = (putStrLn "hello")
3+
4+
foo x = (x + 1)

0 commit comments

Comments
 (0)