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

Commit cb23e7d

Browse files
alanzalanz
committed
Merge pull request #162 from cocreature/bump-snapshot
Bump deps and adapt to new apis
2 parents 060a165 + d1e6648 commit cb23e7d

File tree

13 files changed

+80
-95
lines changed

13 files changed

+80
-95
lines changed

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

+31-38
Original file line numberDiff line numberDiff line change
@@ -2,16 +2,18 @@
22
{-# LANGUAGE GADTs #-}
33
module Haskell.Ide.ApplyRefactPlugin where
44

5+
import Control.Arrow
56
import Control.Monad.IO.Class
7+
import Control.Monad.Trans.Either
8+
import Data.Aeson
69
import qualified Data.Text as T
710
import qualified Data.Text.IO as T
811
import Data.Vinyl
912
import Haskell.Ide.Engine.MonadFunctions
1013
import Haskell.Ide.Engine.PluginDescriptor
1114
import Haskell.Ide.Engine.PluginUtils
1215
import Haskell.Ide.Engine.SemanticTypes
13-
import Language.Haskell.HLint
14-
import Language.Haskell.HLint3
16+
import Language.Haskell.HLint3 as Hlint
1517
import Refact.Apply
1618
import qualified Refact.Types as R
1719
import Refact.Types hiding (SrcSpan)
@@ -49,10 +51,10 @@ applyOneCmd = CmdSync $ \_ctxs req -> do
4951
logm $ "applyOneCmd:res=" ++ show res
5052
case res of
5153
Left err -> return $ IdeResponseFail (IdeError PluginError
52-
(T.pack $ "applyOne: " ++ show err) Nothing)
54+
(T.pack $ "applyOne: " ++ show err) Null)
5355
Right fs -> return (IdeResponseOk fs)
5456
Right _ -> return $ IdeResponseError (IdeError InternalError
55-
"ApplyRefactPlugin.applyOneCmd: ghc’s exhaustiveness checker is broken" Nothing)
57+
"ApplyRefactPlugin.applyOneCmd: ghc’s exhaustiveness checker is broken" Null)
5658

5759

5860
-- ---------------------------------------------------------------------
@@ -66,49 +68,40 @@ applyAllCmd = CmdSync $ \_ctxs req -> do
6668
logm $ "applyAllCmd:res=" ++ show res
6769
case res of
6870
Left err -> return $ IdeResponseFail (IdeError PluginError
69-
(T.pack $ "applyOne: " ++ show err) Nothing)
71+
(T.pack $ "applyOne: " ++ show err) Null)
7072
Right fs -> return (IdeResponseOk fs)
7173
Right _ -> return $ IdeResponseError (IdeError InternalError
72-
"ApplyRefactPlugin.applyOneCmd: ghc’s exhaustiveness checker is broken" Nothing)
74+
"ApplyRefactPlugin.applyOneCmd: ghc’s exhaustiveness checker is broken" Null)
7375

7476

7577
-- ---------------------------------------------------------------------
7678

7779
applyHint :: FilePath -> Maybe Pos -> IO (Either String HieDiff)
7880
applyHint file mpos = do
7981
withTempFile $ \f -> do
80-
-- absFile <- makeAbsolute file
81-
-- hlint /tmp/Foo.hs --refactor --refactor-options="-o /tmp/Bar.hs --pos 2,8"
82-
83-
let
84-
optsf = "-o " ++ f
85-
opts = case mpos of
86-
Nothing -> optsf
87-
Just (r,c) -> optsf ++ " --pos " ++ show r ++ "," ++ show c
88-
-- let hlintOpts = [file, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
89-
let hlintOpts = [file, "--quiet" ]
90-
logm $ "applyHint=" ++ show hlintOpts
91-
res <- catchException $ hlint hlintOpts
92-
logm $ "applyHint:res=" ++ show res
93-
-- res <- hlint hlintOpts
94-
case res of
95-
Left x -> return $ Left (show x)
96-
Right x -> do
97-
let commands = makeApplyRefact x
98-
logm $ "applyHint:commands=" ++ show commands
99-
appliedFile <- applyRefactorings mpos commands file
100-
diff <- makeDiffResult file (T.pack appliedFile)
101-
logm $ "applyHint:diff=" ++ show diff
102-
return $ Right diff
103-
104-
-- ---------------------------------------------------------------------
105-
106-
makeApplyRefact :: [Suggestion] -> [(String, [Refactoring R.SrcSpan])]
107-
makeApplyRefact suggestions =
108-
map (\(Suggestion i) -> (show i, ideaRefactoring i)) suggestions
109-
110-
-- ---------------------------------------------------------------------
111-
82+
let optsf = "-o " ++ f
83+
opts = case mpos of
84+
Nothing -> optsf
85+
Just (r,c) -> optsf ++ " --pos " ++ show r ++ "," ++ show c
86+
hlintOpts = [file, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
87+
runEitherT $ do
88+
ideas <- runHlint file hlintOpts
89+
liftIO $ logm $ "applyHint:ideas=" ++ show ideas
90+
let commands = map (show &&& ideaRefactoring) ideas
91+
appliedFile <- liftIO $ applyRefactorings mpos commands file
92+
diff <- liftIO $ makeDiffResult file (T.pack appliedFile)
93+
liftIO $ logm $ "applyHint:diff=" ++ show diff
94+
return diff
95+
96+
97+
runHlint :: FilePath -> [String] -> EitherT String IO [Idea]
98+
runHlint file args =
99+
do (flags,classify,hint) <- liftIO $ argsSettings args
100+
res <- bimapEitherT showParseError id $ EitherT $ parseModuleEx flags file Nothing
101+
pure $ applyHints classify hint [res]
102+
103+
showParseError :: Hlint.ParseError -> String
104+
showParseError (Hlint.ParseError loc message content) = unlines [show loc, message, content]
112105

113106
makeDiffResult :: FilePath -> T.Text -> IO HieDiff
114107
makeDiffResult orig new = do

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

+1
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ library
1818
, apply-refact
1919
, containers
2020
, directory
21+
, either
2122
, extra
2223
, filepath
2324
, ghc-mod

‎hie-base/Haskell/Ide/Engine/PluginTypes.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -213,7 +213,7 @@ data IdeErrorCode
213213
data IdeError = IdeError
214214
{ ideCode :: IdeErrorCode -- ^ The error code
215215
, ideMessage :: T.Text -- ^ A human readable message
216-
, ideInfo :: Maybe Value -- ^ Additional information
216+
, ideInfo :: Value -- ^ Additional information
217217
}
218218
deriving (Show,Read,Eq,Generic)
219219

@@ -291,7 +291,7 @@ instance ValidResponse CommandDescriptor where
291291
instance ValidResponse IdePlugins where
292292
jsWrite (IdePlugins m) = H.fromList ["plugins" .= H.fromList
293293
( map (uncurry (.=))
294-
$ Map.assocs m)]
294+
$ Map.assocs m :: [Pair])]
295295
jsRead v = do
296296
ps <- v .: "plugins"
297297
liftM (IdePlugins . Map.fromList) $ mapM (\(k,vp) -> do
@@ -378,7 +378,7 @@ instance FromJSON IdeError where
378378
parseJSON (Object v) = IdeError
379379
<$> v .: "code"
380380
<*> v .: "msg"
381-
<*> v .:? "info"
381+
<*> v .: "info"
382382
parseJSON _ = empty
383383

384384

‎hie-ghc-mod/Haskell/Ide/GhcModPlugin.hs

+11-10
Original file line numberDiff line numberDiff line change
@@ -7,22 +7,23 @@ module Haskell.Ide.GhcModPlugin where
77
import Haskell.Ide.Engine.PluginUtils
88

99
import Control.Exception
10-
import Data.Either
11-
import Data.Vinyl
1210
import Control.Monad.IO.Class
11+
import Data.Aeson
12+
import Data.Either
1313
import qualified Data.Map as M
1414
import qualified Data.Text as T
1515
import qualified Data.Text.Read as T
16+
import Data.Vinyl
17+
import qualified Exception as G
1618
import Haskell.Ide.Engine.PluginDescriptor
1719
import Haskell.Ide.Engine.PluginUtils
1820
import Haskell.Ide.Engine.SemanticTypes
1921
import qualified Language.Haskell.GhcMod as GM
2022
import qualified Language.Haskell.GhcMod.Monad as GM
2123
import qualified Language.Haskell.GhcMod.Types as GM
2224
import qualified Language.Haskell.GhcMod.Utils as GM
23-
import System.FilePath
2425
import System.Directory
25-
import qualified Exception as G
26+
import System.FilePath
2627

2728
-- ---------------------------------------------------------------------
2829

@@ -83,7 +84,7 @@ checkCmd = CmdSync $ \_ctxs req -> do
8384
Right (ParamFile fileName :& RNil) -> do
8485
fmap T.pack <$> runGhcModCommand fileName (\f->GM.checkSyntax [f])
8586
Right _ -> return $ IdeResponseError (IdeError InternalError
86-
"GhcModPlugin.checkCmd: ghc’s exhaustiveness checker is broken" Nothing)
87+
"GhcModPlugin.checkCmd: ghc’s exhaustiveness checker is broken" Null)
8788

8889
-- ---------------------------------------------------------------------
8990

@@ -105,7 +106,7 @@ findCmd = CmdSync $ \_ctxs req -> do
105106

106107
-- return (IdeResponseOk "Placholder:Need to debug this in ghc-mod, returns 'does not exist (No such file or directory)'")
107108
Right _ -> return $ IdeResponseError (IdeError InternalError
108-
"GhcModPlugin.findCmd: ghc’s exhaustiveness checker is broken" Nothing)
109+
"GhcModPlugin.findCmd: ghc’s exhaustiveness checker is broken" Null)
109110
where
110111
conv :: String -> (T.Text, [GM.ModuleString])
111112
conv = read
@@ -119,7 +120,7 @@ lintCmd = CmdSync $ \_ctxs req -> do
119120
Right (ParamFile fileName :& RNil) -> do
120121
fmap T.pack <$> runGhcModCommand fileName (GM.lint GM.defaultLintOpts)
121122
Right _ -> return $ IdeResponseError (IdeError InternalError
122-
"GhcModPlugin.lintCmd: ghc’s exhaustiveness checker is broken" Nothing)
123+
"GhcModPlugin.lintCmd: ghc’s exhaustiveness checker is broken" Null)
123124

124125
-- ---------------------------------------------------------------------
125126

@@ -130,7 +131,7 @@ infoCmd = CmdSync $ \_ctxs req -> do
130131
Right (ParamFile fileName :& ParamText expr :& RNil) -> do
131132
fmap T.pack <$> runGhcModCommand fileName (flip GM.info (GM.Expression (T.unpack expr)))
132133
Right _ -> return $ IdeResponseError (IdeError InternalError
133-
"GhcModPlugin.infoCmd: ghc’s exhaustiveness checker is broken" Nothing)
134+
"GhcModPlugin.infoCmd: ghc’s exhaustiveness checker is broken" Null)
134135

135136
-- ---------------------------------------------------------------------
136137

@@ -141,7 +142,7 @@ typeCmd = CmdSync $ \_ctxs req ->
141142
Right (ParamFile fileName :& ParamPos (r,c) :& RNil) -> do
142143
fmap (toTypeInfo . T.lines . T.pack) <$> runGhcModCommand fileName (\f->GM.types f r c)
143144
Right _ -> return $ IdeResponseError (IdeError InternalError
144-
"GhcModPlugin.typesCmd: ghc’s exhaustiveness checker is broken" Nothing)
145+
"GhcModPlugin.typesCmd: ghc’s exhaustiveness checker is broken" Null)
145146

146147

147148
-- | Transform output from ghc-mod type into TypeInfo
@@ -178,5 +179,5 @@ runGhcModCommand fp cmd = do
178179
tmp <- liftIO $ GM.newTempDir root
179180
let setRoot e = e{GM.gmCradle = (GM.gmCradle e){GM.cradleRootDir=root,GM.cradleTempDir=tmp}}
180181
(IdeResponseOk <$> GM.gmeLocal setRoot (cmd f)) `G.gcatch` \(e :: GM.GhcModError) ->
181-
return $ IdeResponseFail $ IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Nothing
182+
return $ IdeResponseFail $ IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null
182183
)

‎hie-hare/Haskell/Ide/HaRePlugin.hs

+8-7
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
module Haskell.Ide.HaRePlugin where
44

55
import Control.Monad.IO.Class
6+
import Data.Aeson
67
import qualified Data.Text as T
78
import Data.Vinyl
89
import Haskell.Ide.Engine.PluginDescriptor
@@ -61,7 +62,7 @@ demoteCmd = CmdSync $ \_ctxs req ->
6162
Right (ParamFile fileName :& ParamPos pos :& RNil) ->
6263
runHareCommand fileName "demote" (\s o f -> demote s o f pos)
6364
Right _ -> return $ IdeResponseError (IdeError InternalError
64-
"HaRePlugin.demoteCmd: ghc’s exhaustiveness checker is broken" Nothing)
65+
"HaRePlugin.demoteCmd: ghc’s exhaustiveness checker is broken" Null)
6566

6667
-- demote :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
6768

@@ -74,7 +75,7 @@ dupdefCmd = CmdSync $ \_ctxs req ->
7475
Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) ->
7576
runHareCommand fileName "duplicateDef" (\s o f -> duplicateDef s o f (T.unpack name) pos)
7677
Right _ -> return $ IdeResponseError (IdeError InternalError
77-
"HaRePlugin.dupdefCmd: ghc’s exhaustiveness checker is broken" Nothing)
78+
"HaRePlugin.dupdefCmd: ghc’s exhaustiveness checker is broken" Null)
7879

7980
-- duplicateDef :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath]
8081

@@ -87,7 +88,7 @@ iftocaseCmd = CmdSync $ \_ctxs req ->
8788
Right (ParamFile fileName :& ParamPos start :& ParamPos end :& RNil) ->
8889
runHareCommand fileName "ifToCase" (\s o f -> ifToCase s o f start end)
8990
Right _ -> return $ IdeResponseError (IdeError InternalError
90-
"HaRePlugin.ifToCaseCmd: ghc’s exhaustiveness checker is broken" Nothing)
91+
"HaRePlugin.ifToCaseCmd: ghc’s exhaustiveness checker is broken" Null)
9192

9293
-- ifToCase :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]
9394

@@ -100,7 +101,7 @@ liftonelevelCmd = CmdSync $ \_ctxs req ->
100101
Right (ParamFile fileName :& ParamPos pos :& RNil) ->
101102
runHareCommand fileName "liftOneLevel" (\s o f -> liftOneLevel s o f pos)
102103
Right _ -> return $ IdeResponseError (IdeError InternalError
103-
"HaRePlugin.liftOneLevel: ghc’s exhaustiveness checker is broken" Nothing)
104+
"HaRePlugin.liftOneLevel: ghc’s exhaustiveness checker is broken" Null)
104105

105106
-- liftOneLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
106107

@@ -113,7 +114,7 @@ lifttotoplevelCmd = CmdSync $ \_ctxs req ->
113114
Right (ParamFile fileName :& ParamPos pos :& RNil) ->
114115
runHareCommand fileName "liftToTopLevel" (\s o f -> liftToTopLevel s o f pos)
115116
Right _ -> return $ IdeResponseError (IdeError InternalError
116-
"HaRePlugin.liftToTopLevel: ghc’s exhaustiveness checker is broken" Nothing)
117+
"HaRePlugin.liftToTopLevel: ghc’s exhaustiveness checker is broken" Null)
117118

118119
-- liftToTopLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
119120

@@ -126,7 +127,7 @@ renameCmd = CmdSync $ \_ctxs req ->
126127
Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) ->
127128
runHareCommand fileName "rename" (\s o f -> rename s o f (T.unpack name) pos)
128129
Right _ -> return $ IdeResponseError (IdeError InternalError
129-
"HaRePlugin.renameCmd: ghc’s exhaustiveness checker is broken" Nothing)
130+
"HaRePlugin.renameCmd: ghc’s exhaustiveness checker is broken" Null)
130131

131132
-- rename :: RefactSettings -> Options -> FilePath -> String -> SimpPos -> IO [FilePath]
132133

@@ -167,7 +168,7 @@ runHareCommand fp name cmd = do
167168
liftIO $ setCurrentDirectory old
168169
case res of
169170
Left err -> return $ IdeResponseFail (IdeError PluginError
170-
(T.pack $ name ++ ": " ++ show err) Nothing)
171+
(T.pack $ name ++ ": " ++ show err) Null)
171172
Right fs -> do
172173
r <- liftIO $ makeRefactorResult fs
173174
return (IdeResponseOk r)

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

+3-3
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,7 @@ mapEithers _ _ = Right []
7777
missingParameter :: forall r. (ValidResponse r) => ParamId -> IdeResponse r
7878
missingParameter param = IdeResponseFail (IdeError MissingParameter
7979
("need `" <> param <> "` parameter")
80-
(Just $ toJSON param))
80+
(toJSON param))
8181

8282
-- |Incorrect parameter error
8383
incorrectParameter :: forall r a b. (ValidResponse r,Show a,Show b)
@@ -86,8 +86,8 @@ incorrectParameter name expected value = IdeResponseFail
8686
(IdeError IncorrectParameterType
8787
("got wrong parameter type for `" <> name <> "`, expected: " <>
8888
T.pack (show expected) <>" , got:" <> T.pack (show value))
89-
(Just $ object ["param" .= toJSON name,"expected".= toJSON (show expected),
90-
"value" .= toJSON (show value)]))
89+
(object ["param" .= toJSON name,"expected".= toJSON (show expected),
90+
"value" .= toJSON (show value)]))
9191

9292
-- ---------------------------------------------------------------------
9393

‎src/Haskell/Ide/Engine/BasePlugin.hs

+4-4
Original file line numberDiff line numberDiff line change
@@ -67,7 +67,7 @@ commandsCmd = CmdSync $ \_ req -> do
6767
Nothing -> return $ IdeResponseFail $ IdeError
6868
{ ideCode = UnknownPlugin
6969
, ideMessage = "Can't find plugin:" <> p
70-
, ideInfo = Just $ toJSON p
70+
, ideInfo = toJSON p
7171
}
7272
Just pl -> return $ IdeResponseOk $ map (cmdName . cmdDesc) (pdCommands pl)
7373
Just x -> return $ incorrectParameter "plugin" ("ParamText"::String) x
@@ -82,19 +82,19 @@ commandDetailCmd = CmdSync $ \_ req -> do
8282
Nothing -> return $ IdeResponseError $ IdeError
8383
{ ideCode = UnknownPlugin
8484
, ideMessage = "Can't find plugin:" <> p
85-
, ideInfo = Just $ toJSON p
85+
, ideInfo = toJSON p
8686
}
8787
Just pl -> case find (\cmd -> command == (cmdName $ cmdDesc cmd) ) (pdCommands pl) of
8888
Nothing -> return $ IdeResponseError $ IdeError
8989
{ ideCode = UnknownCommand
9090
, ideMessage = "Can't find command:" <> command
91-
, ideInfo = Just $ toJSON command
91+
, ideInfo = toJSON command
9292
}
9393
Just detail -> return $ IdeResponseOk (ExtendedCommandDescriptor (cmdDesc detail) p)
9494
Right _ -> return $ IdeResponseError $ IdeError
9595
{ ideCode = InternalError
9696
, ideMessage = "commandDetailCmd: ghc’s exhaustiveness checker is broken"
97-
, ideInfo = Nothing
97+
, ideInfo = Null
9898
}
9999

100100
-- ---------------------------------------------------------------------

‎src/Haskell/Ide/Engine/Dispatcher.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ doDispatch plugins creq = do
5454
return $ Just $ IdeResponseError $ IdeError
5555
{ ideCode = UnknownPlugin
5656
, ideMessage = "No plugin found for:" <> cinPlugin creq
57-
, ideInfo = Just $ toJSON $ cinPlugin creq
57+
, ideInfo = toJSON $ cinPlugin creq
5858
}
5959
Just desc -> do
6060
let pn = cinPlugin creq
@@ -66,7 +66,7 @@ doDispatch plugins creq = do
6666
return $ Just $ IdeResponseError $ IdeError
6767
{ ideCode = UnknownCommand
6868
, ideMessage = "No such command:" <> ideCommand req
69-
, ideInfo = Just $ toJSON $ ideCommand req
69+
, ideInfo = toJSON $ ideCommand req
7070
}
7171
Just (Command cdesc cfunc) -> do
7272
case validateContexts cdesc req of
@@ -105,7 +105,7 @@ validateContexts cd req = r
105105
([], []) -> Left $ IdeResponseFail $ IdeError
106106
{ ideCode = InvalidContext
107107
, ideMessage = T.pack ("no valid context found, expecting one of:" ++ show (cmdContexts cd))
108-
, ideInfo = Nothing
108+
, ideInfo = Null
109109
}
110110
(ctxs, _) ->
111111
case checkParams (cmdAdditionalParams cd) (ideParams req) of

‎src/Haskell/Ide/Engine/Transport/JsonStdio.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import Control.Applicative
99
import Control.Concurrent
1010
import Control.Concurrent.STM.TChan
1111
import Control.Lens (view)
12-
-- import Control.Logging
12+
import Data.Aeson
1313
import Control.Monad.IO.Class
1414
import Control.Monad.STM
1515
import Control.Monad.State.Strict
@@ -52,7 +52,7 @@ parseToJsonPipe oneShot cin cout cid =
5252
do let rsp =
5353
CResp "" cid $
5454
IdeResponseError
55-
(IdeError ParseError (T.pack $ show decodeErr) Nothing)
55+
(IdeError ParseError (T.pack $ show decodeErr) Null)
5656
liftIO $ debugm $ "jsonStdioTransport:parse error:" ++ show decodeErr
5757
liftIO $ atomically $ writeTChan cout rsp
5858
Right req ->

0 commit comments

Comments
 (0)