Merge pull request #135 from JPMoresmau/ghc-mod-find

Ghc mod find

Author: alanz

docs/IdeIntegration.md

@@ -105,7 +105,7 @@ contextMapping CtxFile        = [fileParam]
 contextMapping CtxPoint       = [fileParam,startPosParam]
 contextMapping CtxRegion      = [fileParam,startPosParam,endPosParam]
 contextMapping CtxCabalTarget = [cabalParam]
-contextMapping CtxProject     = []
+contextMapping CtxProject     = [fileParam]
 
 fileParam :: ParamDescription
 fileParam = RP "file" "a file name" PtFile
@@ -119,5 +119,3 @@ endPosParam = RP "end_pos" "end line and col" PtPos
 cabalParam :: ParamDescription
 cabalParam = RP "cabal" "cabal target" PtText
 ```
-
-

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

@@ -8,6 +8,7 @@ import           Control.Exception
 import           Data.Either
 import           Data.Vinyl
 import           Control.Monad.IO.Class
+import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Text.Read as T
 import           Haskell.Ide.Engine.PluginDescriptor
@@ -16,6 +17,7 @@ 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.FilePath
 import           System.Directory
 import qualified Exception as G
@@ -83,20 +85,28 @@ checkCmd = CmdSync $ \_ctxs req -> do
 
 -- ---------------------------------------------------------------------
 
--- TODO: Must define a directory to base the search from, to be able to resolve
--- the project root.
-findCmd :: CommandFunc T.Text
+-- | 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
+  case getParams (IdFile "dir" :& IdText "symbol" :& RNil) req of
     Left err -> return err
-    Right (ParamText _symbol :& RNil) -> do
-      -- liftIO $ runGhcModCommand (GM.findSymbol (T.unpack symbol))
-      -- dir <- liftIO getCurrentDirectory
-      -- return (IdeResponseOk (String $ T.pack dir))
-      -- return (IdeResponseOk (String $ _symbol))
-      return (IdeResponseOk "Placholder:Need to debug this in ghc-mod, returns 'does not exist (No such file or directory)'")
+    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" Nothing)
+  where
+    conv :: String -> (T.Text, [GM.ModuleString])
+    conv = read
 
 -- ---------------------------------------------------------------------
 
@@ -164,7 +174,8 @@ runGhcModCommand fp cmd = do
             -- ghc-mod returns a new line at the end...
             root <- takeWhile (`notElem` ['\r','\n']) <$> GM.runGmOutT opts GM.rootInfo
             liftIO $ setCurrentDirectory root
-            let setRoot e = e{GM.gmCradle = (GM.gmCradle e){GM.cradleRootDir=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) Nothing
           )

hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs

@@ -226,19 +226,23 @@ type Plugins = Map.Map PluginId PluginDescriptor
 
 -- ---------------------------------------------------------------------
 
--- |For a given 'AcceptedContext', define the parameters that are required in
+-- | For a given 'AcceptedContext', define the parameters that are required in
 -- the corresponding 'IdeRequest'
 contextMapping :: AcceptedContext -> [ParamDescription]
 contextMapping CtxNone        = []
 contextMapping CtxFile        = [fileParam]
 contextMapping CtxPoint       = [fileParam,startPosParam]
 contextMapping CtxRegion      = [fileParam,startPosParam,endPosParam]
 contextMapping CtxCabalTarget = [cabalParam]
-contextMapping CtxProject     = []
+contextMapping CtxProject     = [dirParam] -- the root directory of the project
 
 fileParam :: ParamDescription
 fileParam = RP "file" "a file name" PtFile
 
+-- | A parameter for a directory
+dirParam :: ParamDescription
+dirParam = RP "dir" "a directory name" PtFile
+
 startPosParam :: ParamDescription
 startPosParam = RP "start_pos" "start line and col" PtPos
 

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

@@ -41,6 +41,13 @@ data HieDiff = HieDiff
   , dDiff   :: ![Diff (Int,T.Text)]
   } deriving (Show,Eq,Generic)
 
+-- ---------------------------------------------------------------------
+
+-- | A list of modules
+data ModuleList = ModuleList {
+    mModules :: [T.Text]
+  } deriving (Show,Read,Eq,Ord,Generic)
+
 -- ---------------------------------------------------------------------
 -- JSON instances
 
@@ -103,3 +110,9 @@ instance FromJSON (Diff (Int,T.Text)) where
       Just d -> return d
       _ -> empty
   parseJSON _ = empty
+
+-- ---------------------------------------------------------------------
+
+instance ValidResponse ModuleList where
+  jsWrite (ModuleList ms) = H.fromList ["modules" .= ms]
+  jsRead v = ModuleList <$> v .: "modules"

test/DispatcherSpec.hs

@@ -105,7 +105,7 @@ dispatcherSpec = do
     it "identifies CtxProject" $ do
       chan <- atomically newTChan
       chSync <- atomically newTChan
-      let req = IdeRequest "cmd6" (Map.fromList [])
+      let req = IdeRequest "cmd6" (Map.fromList [("dir", ParamFileP ".")])
           cr = CReq "test" 1 req chan
       r <- withStdoutLogging $ runIdeM (IdeState Map.empty) (doDispatch (testPlugins chSync) cr)
       r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("result:ctxs=[CtxProject]"::String)]))

test/GhcModPluginSpec.hs

@@ -69,10 +69,10 @@ ghcmodSpec = do
     -- ---------------------------------
 
     it "runs the find command" $ do
-      let req = IdeRequest "find" (Map.fromList [("symbol", ParamTextP "map")])
+      let req = IdeRequest "find" (Map.fromList [("dir", ParamFileP "."),("symbol", ParamTextP "Show")])
       r <- dispatchRequest req
-      r `shouldBe` Just (IdeResponseOk (H.fromList ["ok" .= ("Placholder:Need to debug this in ghc-mod, returns 'does not exist (No such file or directory)'"::String)]))
-      pendingWith "need to debug in ghc-mod"
+      r `shouldBe` Just (IdeResponseOk (H.fromList ["modules" .= ["GHC.Show"::String,"Prelude","Test.Hspec.Discover","Text.Show"]]))
+
 
     -- ---------------------------------