ghc-mod 5.5

app/MainHie.hs

@@ -18,7 +18,6 @@ import           Control.Exception
 import           Control.Monad
 import           Control.Monad.Logger
 import           Control.Monad.STM
-import           Control.Monad.Trans.Maybe
 import qualified Data.Map as Map
 import           Data.Proxy
 import qualified Data.Text as T
@@ -41,7 +40,6 @@ import           Haskell.Ide.Engine.Utils
 import           Options.Applicative.Simple
 import qualified Paths_haskell_ide_engine as Meta
 import           System.Directory
-import           System.Environment
 
 -- ---------------------------------------------------------------------
 -- plugins
@@ -125,13 +123,9 @@ run opts = do
       then setLogLevel LevelDebug
       else setLogLevel LevelError
 
-    -- We change the current working dirextory of HIE to user home
-    -- directory so that plugins do not depend on cwd. All paths to
-    -- all project files referenced in commands are expected to be
-    -- absolute. Cwd is state and we do not want state in what is
-    -- async system.
-
-    getUserHomeDirectory >>= mapM_ setCurrentDirectory
+    case projectRoot opts of
+      Nothing -> pure ()
+      Just root -> setCurrentDirectory root
 
     logm $  "run entered for HIE " ++ version
     cin <- atomically newTChan :: IO (TChan ChannelRequest)
@@ -158,15 +152,6 @@ run opts = do
     -- At least one needs to be launched, othewise a threadDelay with a large
     -- number should be given. Or some other waiting action.
 
-getUserHomeDirectory :: IO (Maybe String)
-getUserHomeDirectory = do
-    -- On POSIX-like $HOME points to user home directory.
-    -- On Windows %USERPROFILE% points to user home directory.
-    runMaybeT (msum [ MaybeT $ lookupEnv "HOME"
-                    , MaybeT $ lookupEnv "USERPROFILE"])
-
--- ---------------------------------------------------------------------
-
 -- |Do whatever it takes to get a request from the IDE.
 -- pass the request through to the main event dispatcher, and listen on the
 -- reply channel for the response, which should go back to the IDE, using

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

@@ -8,24 +8,17 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Haskell.Ide.GhcModPlugin where
 
-import           Haskell.Ide.Engine.PluginUtils
-
-import           Control.Monad.IO.Class
 import           Data.Aeson
 import           Data.Either
-import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Text.Read as T
 import           Data.Vinyl
 import qualified Exception as G
 import           Haskell.Ide.Engine.PluginDescriptor
+import           Haskell.Ide.Engine.PluginUtils
 import           Haskell.Ide.Engine.SemanticTypes
 import qualified Language.Haskell.GhcMod as GM
-import qualified Language.Haskell.GhcMod.Monad as GM
 import qualified Language.Haskell.GhcMod.Types as GM
-import qualified Language.Haskell.GhcMod.Utils as GM
-import           System.Directory
-import           System.FilePath
 
 -- ---------------------------------------------------------------------
 
@@ -43,10 +36,10 @@ ghcmodDescriptor = PluginDescriptor
       :& buildCommand lintCmd (Proxy :: Proxy "lint")  "Check files using `hlint'"
                      [".hs",".lhs"] (SCtxFile :& RNil) RNil
 
-      :& buildCommand findCmd (Proxy :: Proxy "find")  "List all modules that define SYMBOL"
-                     [".hs",".lhs"] (SCtxProject :& RNil)
-                     (  SParamDesc (Proxy :: Proxy "symbol") (Proxy :: Proxy "The SYMBOL to look up") SPtText SRequired
-                     :& RNil)
+      -- :& buildCommand findCmd (Proxy :: Proxy "find")  "List all modules that define SYMBOL"
+      --                [".hs",".lhs"] (SCtxProject :& RNil)
+      --                (  SParamDesc (Proxy :: Proxy "symbol") (Proxy :: Proxy "The SYMBOL to look up") SPtText SRequired
+      --                :& RNil)
 
       :& buildCommand infoCmd (Proxy :: Proxy "info") "Look up an identifier in the context of FILE (like ghci's `:info')"
                      [".hs",".lhs"] (SCtxFile :& RNil)
@@ -87,34 +80,26 @@ checkCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& RNil) -> do
-      fmap T.pack <$> runGhcModCommand fileName (\f->GM.checkSyntax [f])
+      fmap T.pack <$> runGhcModCommand (GM.checkSyntax [(T.unpack fileName)])
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.checkCmd: ghc’s exhaustiveness checker is broken" Null)
 
 -- ---------------------------------------------------------------------
 
--- | Runs the find command from the given directory, for the given symbol
-findCmd :: CommandFunc ModuleList
-findCmd = CmdSync $ \_ctxs req -> do
-  case getParams (IdFile "dir" :& IdText "symbol" :& RNil) req of
-    Left err -> return err
-    Right (ParamFile dirName :& ParamText symbol :& RNil) -> do
-      runGhcModCommand (T.pack (T.unpack dirName </> "dummy")) (\_->
-          do
-            -- adapted from ghc-mod find command, which launches the executable again
-            tmpdir <- GM.cradleTempDir <$> GM.cradle
-            sf <- takeWhile (`notElem` ['\r','\n']) <$> GM.dumpSymbol tmpdir
-            db <- M.fromAscList . map conv . lines <$> liftIO (readFile sf)
-            let f = M.findWithDefault ([]::[GM.ModuleString]) symbol db
-            return $ ModuleList $ map (T.pack . GM.getModuleString) f
-          )
-
-      -- return (IdeResponseOk "Placholder:Need to debug this in ghc-mod, returns 'does not exist (No such file or directory)'")
-    Right _ -> return $ IdeResponseError (IdeError InternalError
-      "GhcModPlugin.findCmd: ghc’s exhaustiveness checker is broken" Null)
-  where
-    conv :: String -> (T.Text, [GM.ModuleString])
-    conv = read
+-- Disabled until ghc-mod no longer needs to launch a separate executable
+-- -- | Runs the find command from the given directory, for the given symbol
+-- findCmd :: CommandFunc ModuleList
+-- findCmd = CmdSync $ \_ctxs req -> do
+--   case getParams (IdText "symbol" :& RNil) req of
+--     Left err -> return err
+--     Right (ParamText symbol :& RNil) -> do
+--       runGhcModCommand $
+--         (ModuleList . map (T.pack . GM.getModuleString)) <$> GM.findSymbol' (T.unpack symbol)
+
+
+--       -- return (IdeResponseOk "Placholder:Need to debug this in ghc-mod, returns 'does not exist (No such file or directory)'")
+--     Right _ -> return $ IdeResponseError (IdeError InternalError
+--       "GhcModPlugin.findCmd: ghc’s exhaustiveness checker is broken" Null)
 
 -- ---------------------------------------------------------------------
 
@@ -123,7 +108,7 @@ lintCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& RNil) -> do
-      fmap T.pack <$> runGhcModCommand fileName (GM.lint GM.defaultLintOpts)
+      fmap T.pack <$> runGhcModCommand (GM.lint GM.defaultLintOpts (T.unpack fileName))
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.lintCmd: ghc’s exhaustiveness checker is broken" Null)
 
@@ -134,7 +119,7 @@ infoCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& IdText "expr" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamText expr :& RNil) -> do
-      fmap T.pack <$> runGhcModCommand fileName (flip GM.info (GM.Expression (T.unpack expr)))
+      fmap T.pack <$> runGhcModCommand (GM.info (T.unpack fileName) (GM.Expression (T.unpack expr)))
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.infoCmd: ghc’s exhaustiveness checker is broken" Null)
 
@@ -145,7 +130,7 @@ typeCmd = CmdSync $ \_ctxs req ->
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos (r,c) :& RNil) -> do
-      fmap (toTypeInfo . T.lines . T.pack) <$> runGhcModCommand fileName (\f->GM.types f r c)
+      fmap (toTypeInfo . T.lines . T.pack) <$> runGhcModCommand (GM.types (T.unpack fileName) r c)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.typesCmd: ghc’s exhaustiveness checker is broken" Null)
 
@@ -167,22 +152,11 @@ readTypeResult t = do
 -- ---------------------------------------------------------------------
 
 
-runGhcModCommand :: T.Text -- ^ The file name we'll operate on
-                 -> (FilePath -> IdeM a)
+runGhcModCommand :: IdeM a
                  -> IdeM (IdeResponse a)
-runGhcModCommand fp cmd = do
-  let (dir,f) = fileInfo fp
-  let opts = GM.defaultOptions
-  old <- liftIO getCurrentDirectory
-  G.gbracket (liftIO $ setCurrentDirectory dir)
-          (\_ -> liftIO $ setCurrentDirectory old)
-          (\_ -> do
-            -- we need to get the root of our folder
-            -- ghc-mod returns a new line at the end...
-            root <- takeWhile (`notElem` ['\r','\n']) <$> GM.runGmOutT opts GM.rootInfo
-            liftIO $ setCurrentDirectory root
-            tmp <- liftIO $ GM.newTempDir root
-            let setRoot e = e{GM.gmCradle = (GM.gmCradle e){GM.cradleRootDir=root,GM.cradleTempDir=tmp}}
-            (IdeResponseOk <$> GM.gmeLocal setRoot (cmd f)) `G.gcatch` \(e :: GM.GhcModError) ->
-               return $ IdeResponseFail $ IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null
-          )
+runGhcModCommand cmd =
+  do (IdeResponseOk <$> cmd) `G.gcatch`
+       \(e :: GM.GhcModError) ->
+         return $
+         IdeResponseFail $
+         IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null

hie-hare/Haskell/Ide/HaRePlugin.hs

@@ -1,24 +1,28 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
-
-{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+
 module Haskell.Ide.HaRePlugin where
 
-import           Control.Monad.IO.Class
+import           Control.Monad.State
+import           Control.Monad.Trans.Control
 import           Data.Aeson
+import           Data.Monoid
 import qualified Data.Text as T
+import           Exception
 import           Haskell.Ide.Engine.PluginDescriptor
 import           Haskell.Ide.Engine.PluginUtils
 import           Haskell.Ide.Engine.SemanticTypes
-import           Language.Haskell.Refact.HaRe
-
-
-import qualified Exception as G
-import qualified Language.Haskell.GhcMod as GM
 import qualified Language.Haskell.GhcMod.Monad as GM
-import           System.Directory
+import qualified Language.Haskell.GhcMod.Error as GM
+import           Language.Haskell.Refact.HaRe
+import           Language.Haskell.Refact.Utils.Monad
+import           Language.Haskell.Refact.Utils.Types
+import           Language.Haskell.Refact.Utils.Utils
 import           System.FilePath
 
 -- ---------------------------------------------------------------------
@@ -66,11 +70,11 @@ demoteCmd  = CmdSync $ \_ctxs req ->
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& RNil) ->
-      runHareCommand fileName "demote" (\s o f -> demote s o f pos)
+      runHareCommand "demote" (compDemote (T.unpack fileName) pos)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "HaRePlugin.demoteCmd: ghc’s exhaustiveness checker is broken" Null)
 
--- demote :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
+-- compDemote :: FilePath -> SimpPos -> IO [FilePath]
 
 -- ---------------------------------------------------------------------
 
@@ -79,11 +83,11 @@ dupdefCmd = CmdSync $ \_ctxs req ->
   case getParams (IdFile "file" :& IdPos "start_pos" :& IdText "name" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) ->
-      runHareCommand fileName "duplicateDef" (\s o f -> duplicateDef s o f (T.unpack name) pos)
+      runHareCommand "dupdef" (compDuplicateDef (T.unpack fileName) (T.unpack name) pos)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "HaRePlugin.dupdefCmd: ghc’s exhaustiveness checker is broken" Null)
 
--- duplicateDef :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath]
+-- compDuplicateDef :: FilePath -> String -> SimpPos -> IO [FilePath]
 
 -- ---------------------------------------------------------------------
 
@@ -92,11 +96,11 @@ iftocaseCmd = CmdSync $ \_ctxs req ->
   case getParams (IdFile "file" :& IdPos "start_pos" :& IdPos "end_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos start :& ParamPos end :& RNil) ->
-      runHareCommand fileName "ifToCase" (\s o f -> ifToCase s o f start end)
+      runHareCommand "iftocase" (compIfToCase (T.unpack fileName) start end)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "HaRePlugin.ifToCaseCmd: ghc’s exhaustiveness checker is broken" Null)
 
--- ifToCase :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]
+-- compIfToCase :: FilePath -> SimpPos -> SimpPos -> IO [FilePath]
 
 -- ---------------------------------------------------------------------
 
@@ -105,11 +109,11 @@ liftonelevelCmd = CmdSync $ \_ctxs req ->
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& RNil) ->
-      runHareCommand fileName "liftOneLevel" (\s o f -> liftOneLevel s o f pos)
+      runHareCommand "liftonelevel" (compLiftOneLevel (T.unpack fileName) pos)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "HaRePlugin.liftOneLevel: ghc’s exhaustiveness checker is broken" Null)
 
--- liftOneLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
+-- compLiftOneLevel :: FilePath -> SimpPos -> IO [FilePath]
 
 -- ---------------------------------------------------------------------
 
@@ -118,11 +122,11 @@ lifttotoplevelCmd = CmdSync $ \_ctxs req ->
   case getParams (IdFile "file" :& IdPos "start_pos" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& RNil) ->
-      runHareCommand fileName "liftToTopLevel" (\s o f -> liftToTopLevel s o f pos)
+      runHareCommand "lifttotoplevel" (compLiftToTopLevel (T.unpack fileName) pos)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "HaRePlugin.liftToTopLevel: ghc’s exhaustiveness checker is broken" Null)
 
--- liftToTopLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]
+-- compLiftToTopLevel :: FilePath -> SimpPos -> IO [FilePath]
 
 -- ---------------------------------------------------------------------
 
@@ -131,11 +135,11 @@ renameCmd = CmdSync $ \_ctxs req ->
   case getParams (IdFile "file" :& IdPos "start_pos" :& IdText "name" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& ParamPos pos :& ParamText name :& RNil) ->
-      runHareCommand fileName "rename" (\s o f -> rename s o f (T.unpack name) pos)
+      runHareCommand "rename" (compRename (T.unpack fileName) (T.unpack name) pos)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "HaRePlugin.renameCmd: ghc’s exhaustiveness checker is broken" Null)
 
--- rename :: RefactSettings -> Options -> FilePath -> String -> SimpPos -> IO [FilePath]
+-- compRename :: FilePath -> String -> SimpPos -> IO [FilePath]
 
 -- ---------------------------------------------------------------------
 
@@ -152,27 +156,51 @@ makeRefactorResult changedFiles = do
 -- ---------------------------------------------------------------------
 
 
-runHareCommand :: T.Text -- ^ The file name we'll operate on
-                 -> String -- ^ command name for log
-                 -> (RefactSettings -> GM.Options -> FilePath -> IO [FilePath])
+runHareCommand :: String -> RefactGhc [ApplyRefacResult]
                  -> IdeM (IdeResponse RefactorResult)
-runHareCommand fp name cmd = do
-  let (dir,_) = fileInfo fp
-  let opts = GM.defaultOptions
-  old <- liftIO getCurrentDirectory
-  G.gbracket (liftIO $ setCurrentDirectory dir)
-             (\_ -> liftIO $ setCurrentDirectory old)
-             (\_ -> do
-                -- we need to get the root of our folder
-                -- ghc-mod returns a new line at the end...
-                root <- takeWhile (`notElem` ['\r','\n']) <$> GM.runGmOutT opts GM.rootInfo
-                liftIO $ setCurrentDirectory root
-                res <- liftIO $ catchException $ cmd defaultSettings GM.defaultOptions (T.unpack fp)
-                liftIO $ setCurrentDirectory old
-                case res of
-                  Left err -> return $ IdeResponseFail (IdeError PluginError
-                                (T.pack $ name ++ ": " ++ show err) Null)
-                  Right fs -> do
-                    r <- liftIO $ makeRefactorResult fs
-                    return (IdeResponseOk r)
-              )
+runHareCommand name cmd =
+  do let initialState =
+           RefSt {rsSettings = defaultSettings
+                 ,rsUniqState = 1
+                 ,rsSrcSpanCol = 1
+                 ,rsFlags = RefFlags False
+                 ,rsStorage = StorageNone
+                 ,rsCurrentTarget = Nothing
+                 ,rsModule = Nothing}
+     let cmd' = unRefactGhc cmd
+         embeddedCmd =
+           GM.unGmlT $
+           hoist (liftIO . flip evalStateT initialState)
+                 (GM.GmlT cmd')
+         handlers
+           :: Applicative m
+           => [GM.GHandler m (Either String a)]
+         handlers =
+           [GM.GHandler (\(ErrorCall e) -> pure (Left e))
+           ,GM.GHandler (\(err :: GM.GhcModError) -> pure (Left (show err)))]
+     eitherRes <- fmap Right embeddedCmd `GM.gcatches` handlers
+     case eitherRes of
+       Left err ->
+         pure (IdeResponseFail
+                 (IdeError PluginError
+                           (T.pack $ name <> ": \"" <> err <> "\"")
+                           Null))
+       Right res ->
+         do liftIO $
+              writeRefactoredFiles (rsetVerboseLevel defaultSettings)
+                                   res
+            let files = modifiedFiles res
+            refactRes <- liftIO $ makeRefactorResult files
+            pure (IdeResponseOk refactRes)
+
+-- | This is like hoist from the mmorph package, but build on
+-- `MonadTransControl` since we don’t have an `MFunctor` instance.
+hoist
+  :: (MonadTransControl t,Monad (t m'),Applicative m',Monad m',Monad m)
+  => (forall b. m b -> m' b) -> t m a -> t m' a
+hoist f a =
+  liftWith (\run ->
+              let b = run a
+                  c = f b
+              in pure c) >>=
+  restoreT