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

Commit 6078c36

Browse files
alanzalanz
committed
Merge pull request #176 from cocreature/ghc-mod-5.5
ghc-mod 5.5
2 parents 4aa8a94 + 1190e8d commit 6078c36

File tree

9 files changed

+142
-148
lines changed

9 files changed

+142
-148
lines changed

‎app/MainHie.hs

+3-18
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,6 @@ import Control.Exception
1818
import Control.Monad
1919
import Control.Monad.Logger
2020
import Control.Monad.STM
21-
import Control.Monad.Trans.Maybe
2221
import qualified Data.Map as Map
2322
import Data.Proxy
2423
import qualified Data.Text as T
@@ -41,7 +40,6 @@ import Haskell.Ide.Engine.Utils
4140
import Options.Applicative.Simple
4241
import qualified Paths_haskell_ide_engine as Meta
4342
import System.Directory
44-
import System.Environment
4543

4644
-- ---------------------------------------------------------------------
4745
-- plugins
@@ -125,13 +123,9 @@ run opts = do
125123
then setLogLevel LevelDebug
126124
else setLogLevel LevelError
127125

128-
-- We change the current working dirextory of HIE to user home
129-
-- directory so that plugins do not depend on cwd. All paths to
130-
-- all project files referenced in commands are expected to be
131-
-- absolute. Cwd is state and we do not want state in what is
132-
-- async system.
133-
134-
getUserHomeDirectory >>= mapM_ setCurrentDirectory
126+
case projectRoot opts of
127+
Nothing -> pure ()
128+
Just root -> setCurrentDirectory root
135129

136130
logm $ "run entered for HIE " ++ version
137131
cin <- atomically newTChan :: IO (TChan ChannelRequest)
@@ -158,15 +152,6 @@ run opts = do
158152
-- At least one needs to be launched, othewise a threadDelay with a large
159153
-- number should be given. Or some other waiting action.
160154

161-
getUserHomeDirectory :: IO (Maybe String)
162-
getUserHomeDirectory = do
163-
-- On POSIX-like $HOME points to user home directory.
164-
-- On Windows %USERPROFILE% points to user home directory.
165-
runMaybeT (msum [ MaybeT $ lookupEnv "HOME"
166-
, MaybeT $ lookupEnv "USERPROFILE"])
167-
168-
-- ---------------------------------------------------------------------
169-
170155
-- |Do whatever it takes to get a request from the IDE.
171156
-- pass the request through to the main event dispatcher, and listen on the
172157
-- reply channel for the response, which should go back to the IDE, using

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

+30-56
Original file line numberDiff line numberDiff line change
@@ -8,24 +8,17 @@
88
{-# LANGUAGE ScopedTypeVariables #-}
99
module Haskell.Ide.GhcModPlugin where
1010

11-
import Haskell.Ide.Engine.PluginUtils
12-
13-
import Control.Monad.IO.Class
1411
import Data.Aeson
1512
import Data.Either
16-
import qualified Data.Map as M
1713
import qualified Data.Text as T
1814
import qualified Data.Text.Read as T
1915
import Data.Vinyl
2016
import qualified Exception as G
2117
import Haskell.Ide.Engine.PluginDescriptor
18+
import Haskell.Ide.Engine.PluginUtils
2219
import Haskell.Ide.Engine.SemanticTypes
2320
import qualified Language.Haskell.GhcMod as GM
24-
import qualified Language.Haskell.GhcMod.Monad as GM
2521
import qualified Language.Haskell.GhcMod.Types as GM
26-
import qualified Language.Haskell.GhcMod.Utils as GM
27-
import System.Directory
28-
import System.FilePath
2922

3023
-- ---------------------------------------------------------------------
3124

@@ -43,10 +36,10 @@ ghcmodDescriptor = PluginDescriptor
4336
:& buildCommand lintCmd (Proxy :: Proxy "lint") "Check files using `hlint'"
4437
[".hs",".lhs"] (SCtxFile :& RNil) RNil
4538

46-
:& buildCommand findCmd (Proxy :: Proxy "find") "List all modules that define SYMBOL"
47-
[".hs",".lhs"] (SCtxProject :& RNil)
48-
( SParamDesc (Proxy :: Proxy "symbol") (Proxy :: Proxy "The SYMBOL to look up") SPtText SRequired
49-
:& RNil)
39+
-- :& buildCommand findCmd (Proxy :: Proxy "find") "List all modules that define SYMBOL"
40+
-- [".hs",".lhs"] (SCtxProject :& RNil)
41+
-- ( SParamDesc (Proxy :: Proxy "symbol") (Proxy :: Proxy "The SYMBOL to look up") SPtText SRequired
42+
-- :& RNil)
5043

5144
:& buildCommand infoCmd (Proxy :: Proxy "info") "Look up an identifier in the context of FILE (like ghci's `:info')"
5245
[".hs",".lhs"] (SCtxFile :& RNil)
@@ -87,34 +80,26 @@ checkCmd = CmdSync $ \_ctxs req -> do
8780
case getParams (IdFile "file" :& RNil) req of
8881
Left err -> return err
8982
Right (ParamFile fileName :& RNil) -> do
90-
fmap T.pack <$> runGhcModCommand fileName (\f->GM.checkSyntax [f])
83+
fmap T.pack <$> runGhcModCommand (GM.checkSyntax [(T.unpack fileName)])
9184
Right _ -> return $ IdeResponseError (IdeError InternalError
9285
"GhcModPlugin.checkCmd: ghc’s exhaustiveness checker is broken" Null)
9386

9487
-- ---------------------------------------------------------------------
9588

96-
-- | Runs the find command from the given directory, for the given symbol
97-
findCmd :: CommandFunc ModuleList
98-
findCmd = CmdSync $ \_ctxs req -> do
99-
case getParams (IdFile "dir" :& IdText "symbol" :& RNil) req of
100-
Left err -> return err
101-
Right (ParamFile dirName :& ParamText symbol :& RNil) -> do
102-
runGhcModCommand (T.pack (T.unpack dirName </> "dummy")) (\_->
103-
do
104-
-- adapted from ghc-mod find command, which launches the executable again
105-
tmpdir <- GM.cradleTempDir <$> GM.cradle
106-
sf <- takeWhile (`notElem` ['\r','\n']) <$> GM.dumpSymbol tmpdir
107-
db <- M.fromAscList . map conv . lines <$> liftIO (readFile sf)
108-
let f = M.findWithDefault ([]::[GM.ModuleString]) symbol db
109-
return $ ModuleList $ map (T.pack . GM.getModuleString) f
110-
)
111-
112-
-- return (IdeResponseOk "Placholder:Need to debug this in ghc-mod, returns 'does not exist (No such file or directory)'")
113-
Right _ -> return $ IdeResponseError (IdeError InternalError
114-
"GhcModPlugin.findCmd: ghc’s exhaustiveness checker is broken" Null)
115-
where
116-
conv :: String -> (T.Text, [GM.ModuleString])
117-
conv = read
89+
-- Disabled until ghc-mod no longer needs to launch a separate executable
90+
-- -- | Runs the find command from the given directory, for the given symbol
91+
-- findCmd :: CommandFunc ModuleList
92+
-- findCmd = CmdSync $ \_ctxs req -> do
93+
-- case getParams (IdText "symbol" :& RNil) req of
94+
-- Left err -> return err
95+
-- Right (ParamText symbol :& RNil) -> do
96+
-- runGhcModCommand $
97+
-- (ModuleList . map (T.pack . GM.getModuleString)) <$> GM.findSymbol' (T.unpack symbol)
98+
99+
100+
-- -- return (IdeResponseOk "Placholder:Need to debug this in ghc-mod, returns 'does not exist (No such file or directory)'")
101+
-- Right _ -> return $ IdeResponseError (IdeError InternalError
102+
-- "GhcModPlugin.findCmd: ghc’s exhaustiveness checker is broken" Null)
118103

119104
-- ---------------------------------------------------------------------
120105

@@ -123,7 +108,7 @@ lintCmd = CmdSync $ \_ctxs req -> do
123108
case getParams (IdFile "file" :& RNil) req of
124109
Left err -> return err
125110
Right (ParamFile fileName :& RNil) -> do
126-
fmap T.pack <$> runGhcModCommand fileName (GM.lint GM.defaultLintOpts)
111+
fmap T.pack <$> runGhcModCommand (GM.lint GM.defaultLintOpts (T.unpack fileName))
127112
Right _ -> return $ IdeResponseError (IdeError InternalError
128113
"GhcModPlugin.lintCmd: ghc’s exhaustiveness checker is broken" Null)
129114

@@ -134,7 +119,7 @@ infoCmd = CmdSync $ \_ctxs req -> do
134119
case getParams (IdFile "file" :& IdText "expr" :& RNil) req of
135120
Left err -> return err
136121
Right (ParamFile fileName :& ParamText expr :& RNil) -> do
137-
fmap T.pack <$> runGhcModCommand fileName (flip GM.info (GM.Expression (T.unpack expr)))
122+
fmap T.pack <$> runGhcModCommand (GM.info (T.unpack fileName) (GM.Expression (T.unpack expr)))
138123
Right _ -> return $ IdeResponseError (IdeError InternalError
139124
"GhcModPlugin.infoCmd: ghc’s exhaustiveness checker is broken" Null)
140125

@@ -145,7 +130,7 @@ typeCmd = CmdSync $ \_ctxs req ->
145130
case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
146131
Left err -> return err
147132
Right (ParamFile fileName :& ParamPos (r,c) :& RNil) -> do
148-
fmap (toTypeInfo . T.lines . T.pack) <$> runGhcModCommand fileName (\f->GM.types f r c)
133+
fmap (toTypeInfo . T.lines . T.pack) <$> runGhcModCommand (GM.types (T.unpack fileName) r c)
149134
Right _ -> return $ IdeResponseError (IdeError InternalError
150135
"GhcModPlugin.typesCmd: ghc’s exhaustiveness checker is broken" Null)
151136

@@ -167,22 +152,11 @@ readTypeResult t = do
167152
-- ---------------------------------------------------------------------
168153

169154

170-
runGhcModCommand :: T.Text -- ^ The file name we'll operate on
171-
-> (FilePath -> IdeM a)
155+
runGhcModCommand :: IdeM a
172156
-> IdeM (IdeResponse a)
173-
runGhcModCommand fp cmd = do
174-
let (dir,f) = fileInfo fp
175-
let opts = GM.defaultOptions
176-
old <- liftIO getCurrentDirectory
177-
G.gbracket (liftIO $ setCurrentDirectory dir)
178-
(\_ -> liftIO $ setCurrentDirectory old)
179-
(\_ -> do
180-
-- we need to get the root of our folder
181-
-- ghc-mod returns a new line at the end...
182-
root <- takeWhile (`notElem` ['\r','\n']) <$> GM.runGmOutT opts GM.rootInfo
183-
liftIO $ setCurrentDirectory root
184-
tmp <- liftIO $ GM.newTempDir root
185-
let setRoot e = e{GM.gmCradle = (GM.gmCradle e){GM.cradleRootDir=root,GM.cradleTempDir=tmp}}
186-
(IdeResponseOk <$> GM.gmeLocal setRoot (cmd f)) `G.gcatch` \(e :: GM.GhcModError) ->
187-
return $ IdeResponseFail $ IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null
188-
)
157+
runGhcModCommand cmd =
158+
do (IdeResponseOk <$> cmd) `G.gcatch`
159+
\(e :: GM.GhcModError) ->
160+
return $
161+
IdeResponseFail $
162+
IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null

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

+73-45
Original file line numberDiff line numberDiff line change
@@ -1,24 +1,28 @@
1+
{-# LANGUAGE ScopedTypeVariables #-}
12
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
2-
3-
{-# LANGUAGE PartialTypeSignatures #-}
43
{-# LANGUAGE DataKinds #-}
5-
{-# LANGUAGE OverloadedStrings #-}
64
{-# LANGUAGE GADTs #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE PartialTypeSignatures #-}
7+
{-# LANGUAGE RankNTypes #-}
8+
79
module Haskell.Ide.HaRePlugin where
810

9-
import Control.Monad.IO.Class
11+
import Control.Monad.State
12+
import Control.Monad.Trans.Control
1013
import Data.Aeson
14+
import Data.Monoid
1115
import qualified Data.Text as T
16+
import Exception
1217
import Haskell.Ide.Engine.PluginDescriptor
1318
import Haskell.Ide.Engine.PluginUtils
1419
import Haskell.Ide.Engine.SemanticTypes
15-
import Language.Haskell.Refact.HaRe
16-
17-
18-
import qualified Exception as G
19-
import qualified Language.Haskell.GhcMod as GM
2020
import qualified Language.Haskell.GhcMod.Monad as GM
21-
import System.Directory
21+
import qualified Language.Haskell.GhcMod.Error as GM
22+
import Language.Haskell.Refact.HaRe
23+
import Language.Haskell.Refact.Utils.Monad
24+
import Language.Haskell.Refact.Utils.Types
25+
import Language.Haskell.Refact.Utils.Utils
2226
import System.FilePath
2327

2428
-- ---------------------------------------------------------------------
@@ -66,11 +70,11 @@ demoteCmd = CmdSync $ \_ctxs req ->
6670
case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
6771
Left err -> return err
6872
Right (ParamFile fileName :& ParamPos pos :& RNil) ->
69-
runHareCommand fileName "demote" (\s o f -> demote s o f pos)
73+
runHareCommand "demote" (compDemote (T.unpack fileName) pos)
7074
Right _ -> return $ IdeResponseError (IdeError InternalError
7175
"HaRePlugin.demoteCmd: ghc’s exhaustiveness checker is broken" Null)
7276

73-
-- demote :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
77+
-- compDemote :: FilePath -> SimpPos -> IO [FilePath]
7478

7579
-- ---------------------------------------------------------------------
7680

@@ -79,11 +83,11 @@ dupdefCmd = CmdSync $ \_ctxs req ->
7983
case getParams (IdFile "file" :& IdPos "start_pos" :& IdText "name" :& RNil) req of
8084
Left err -> return err
8185
Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) ->
82-
runHareCommand fileName "duplicateDef" (\s o f -> duplicateDef s o f (T.unpack name) pos)
86+
runHareCommand "dupdef" (compDuplicateDef (T.unpack fileName) (T.unpack name) pos)
8387
Right _ -> return $ IdeResponseError (IdeError InternalError
8488
"HaRePlugin.dupdefCmd: ghc’s exhaustiveness checker is broken" Null)
8589

86-
-- duplicateDef :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath]
90+
-- compDuplicateDef :: FilePath -> String -> SimpPos -> IO [FilePath]
8791

8892
-- ---------------------------------------------------------------------
8993

@@ -92,11 +96,11 @@ iftocaseCmd = CmdSync $ \_ctxs req ->
9296
case getParams (IdFile "file" :& IdPos "start_pos" :& IdPos "end_pos" :& RNil) req of
9397
Left err -> return err
9498
Right (ParamFile fileName :& ParamPos start :& ParamPos end :& RNil) ->
95-
runHareCommand fileName "ifToCase" (\s o f -> ifToCase s o f start end)
99+
runHareCommand "iftocase" (compIfToCase (T.unpack fileName) start end)
96100
Right _ -> return $ IdeResponseError (IdeError InternalError
97101
"HaRePlugin.ifToCaseCmd: ghc’s exhaustiveness checker is broken" Null)
98102

99-
-- ifToCase :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]
103+
-- compIfToCase :: FilePath -> SimpPos -> SimpPos -> IO [FilePath]
100104

101105
-- ---------------------------------------------------------------------
102106

@@ -105,11 +109,11 @@ liftonelevelCmd = CmdSync $ \_ctxs req ->
105109
case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
106110
Left err -> return err
107111
Right (ParamFile fileName :& ParamPos pos :& RNil) ->
108-
runHareCommand fileName "liftOneLevel" (\s o f -> liftOneLevel s o f pos)
112+
runHareCommand "liftonelevel" (compLiftOneLevel (T.unpack fileName) pos)
109113
Right _ -> return $ IdeResponseError (IdeError InternalError
110114
"HaRePlugin.liftOneLevel: ghc’s exhaustiveness checker is broken" Null)
111115

112-
-- liftOneLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
116+
-- compLiftOneLevel :: FilePath -> SimpPos -> IO [FilePath]
113117

114118
-- ---------------------------------------------------------------------
115119

@@ -118,11 +122,11 @@ lifttotoplevelCmd = CmdSync $ \_ctxs req ->
118122
case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
119123
Left err -> return err
120124
Right (ParamFile fileName :& ParamPos pos :& RNil) ->
121-
runHareCommand fileName "liftToTopLevel" (\s o f -> liftToTopLevel s o f pos)
125+
runHareCommand "lifttotoplevel" (compLiftToTopLevel (T.unpack fileName) pos)
122126
Right _ -> return $ IdeResponseError (IdeError InternalError
123127
"HaRePlugin.liftToTopLevel: ghc’s exhaustiveness checker is broken" Null)
124128

125-
-- liftToTopLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
129+
-- compLiftToTopLevel :: FilePath -> SimpPos -> IO [FilePath]
126130

127131
-- ---------------------------------------------------------------------
128132

@@ -131,11 +135,11 @@ renameCmd = CmdSync $ \_ctxs req ->
131135
case getParams (IdFile "file" :& IdPos "start_pos" :& IdText "name" :& RNil) req of
132136
Left err -> return err
133137
Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) ->
134-
runHareCommand fileName "rename" (\s o f -> rename s o f (T.unpack name) pos)
138+
runHareCommand "rename" (compRename (T.unpack fileName) (T.unpack name) pos)
135139
Right _ -> return $ IdeResponseError (IdeError InternalError
136140
"HaRePlugin.renameCmd: ghc’s exhaustiveness checker is broken" Null)
137141

138-
-- rename :: RefactSettings -> Options -> FilePath -> String -> SimpPos -> IO [FilePath]
142+
-- compRename :: FilePath -> String -> SimpPos -> IO [FilePath]
139143

140144
-- ---------------------------------------------------------------------
141145

@@ -152,27 +156,51 @@ makeRefactorResult changedFiles = do
152156
-- ---------------------------------------------------------------------
153157

154158

155-
runHareCommand :: T.Text -- ^ The file name we'll operate on
156-
-> String -- ^ command name for log
157-
-> (RefactSettings -> GM.Options -> FilePath -> IO [FilePath])
159+
runHareCommand :: String -> RefactGhc [ApplyRefacResult]
158160
-> IdeM (IdeResponse RefactorResult)
159-
runHareCommand fp name cmd = do
160-
let (dir,_) = fileInfo fp
161-
let opts = GM.defaultOptions
162-
old <- liftIO getCurrentDirectory
163-
G.gbracket (liftIO $ setCurrentDirectory dir)
164-
(\_ -> liftIO $ setCurrentDirectory old)
165-
(\_ -> do
166-
-- we need to get the root of our folder
167-
-- ghc-mod returns a new line at the end...
168-
root <- takeWhile (`notElem` ['\r','\n']) <$> GM.runGmOutT opts GM.rootInfo
169-
liftIO $ setCurrentDirectory root
170-
res <- liftIO $ catchException $ cmd defaultSettings GM.defaultOptions (T.unpack fp)
171-
liftIO $ setCurrentDirectory old
172-
case res of
173-
Left err -> return $ IdeResponseFail (IdeError PluginError
174-
(T.pack $ name ++ ": " ++ show err) Null)
175-
Right fs -> do
176-
r <- liftIO $ makeRefactorResult fs
177-
return (IdeResponseOk r)
178-
)
161+
runHareCommand name cmd =
162+
do let initialState =
163+
RefSt {rsSettings = defaultSettings
164+
,rsUniqState = 1
165+
,rsSrcSpanCol = 1
166+
,rsFlags = RefFlags False
167+
,rsStorage = StorageNone
168+
,rsCurrentTarget = Nothing
169+
,rsModule = Nothing}
170+
let cmd' = unRefactGhc cmd
171+
embeddedCmd =
172+
GM.unGmlT $
173+
hoist (liftIO . flip evalStateT initialState)
174+
(GM.GmlT cmd')
175+
handlers
176+
:: Applicative m
177+
=> [GM.GHandler m (Either String a)]
178+
handlers =
179+
[GM.GHandler (\(ErrorCall e) -> pure (Left e))
180+
,GM.GHandler (\(err :: GM.GhcModError) -> pure (Left (show err)))]
181+
eitherRes <- fmap Right embeddedCmd `GM.gcatches` handlers
182+
case eitherRes of
183+
Left err ->
184+
pure (IdeResponseFail
185+
(IdeError PluginError
186+
(T.pack $ name <> ": \"" <> err <> "\"")
187+
Null))
188+
Right res ->
189+
do liftIO $
190+
writeRefactoredFiles (rsetVerboseLevel defaultSettings)
191+
res
192+
let files = modifiedFiles res
193+
refactRes <- liftIO $ makeRefactorResult files
194+
pure (IdeResponseOk refactRes)
195+
196+
-- | This is like hoist from the mmorph package, but build on
197+
-- `MonadTransControl` since we don’t have an `MFunctor` instance.
198+
hoist
199+
:: (MonadTransControl t,Monad (t m'),Applicative m',Monad m',Monad m)
200+
=> (forall b. m b -> m' b) -> t m a -> t m' a
201+
hoist f a =
202+
liftWith (\run ->
203+
let b = run a
204+
c = f b
205+
in pure c) >>=
206+
restoreT

0 commit comments

Comments
 (0)