Merge pull request #130 from alanz/ghc-mod-session

Ghc mod session

Author: alanz

.travis.yml

@@ -27,17 +27,15 @@ install:
   # Bring in GHC if not already present
   - ./travis_long stack +RTS -N2 -RTS setup
   # Build the dependencies only.
-  # - ./travis_long stack +RTS -N2 -RTS build --only-snapshot --pedantic
-  - ./travis_long stack build --only-snapshot --pedantic
+  # - ./travis_long stack build --only-snapshot --pedantic
+  - ./travis_long stack build --only-snapshot
 
 script:
-  # - ./travis_long stack build --pedantic
-  # - ./travis_long stack +RTS -N2 -RTS build
-  - ./travis_long stack +RTS -N1 -RTS build --pedantic
-  # - ./travis_long stack +RTS -N2 -RTS build --test --pedantic
-  - ./travis_long stack +RTS -N1 -RTS build --test --pedantic
-  # - ./travis_long stack build --test --pedantic
-  # - ./travis_long stack +RTS -N2 -RTS build --test
+  # Disabling pedantic due to warnings in current ghc-mod, which stack (erroneously) complains about
+  # - ./travis_long stack +RTS -N1 -RTS build --pedantic
+  - ./travis_long stack +RTS -N1 -RTS build 
+  # - ./travis_long stack +RTS -N1 -RTS build --test --pedantic
+  - ./travis_long stack +RTS -N1 -RTS build --test
   - ./travis_long stack exec emacs24 -- -q --batch -L elisp -l elisp/tests/hie-tests.el -f ert-run-tests-batch-and-exit
   # Re-enable the haddock tests when the warning in HaRe does not trigger a problem
   # - ./travis_long stack +RTS -N2 -RTS build --test --haddock

Makefile

@@ -13,7 +13,9 @@ test-emacs:
 
 .PHONY: test-haskell
 test-haskell:
-	stack build --test --pedantic
+	# stack build --test --pedantic
+	# stack complains about deprecations in ghc-mod as an extra dep
+	stack build --test
 
 .PHONY: ghci-test
 ghci-test:

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Haskell.Ide.GhcModPlugin where
 
 import           Control.Exception
@@ -14,8 +15,10 @@ 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           System.FilePath
 import           System.Directory
+import qualified Exception as G
 
 -- ---------------------------------------------------------------------
 
@@ -74,7 +77,7 @@ checkCmd = CmdSync $ \_ctxs req -> do
   case getParams (IdFile "file" :& RNil) req of
     Left err -> return err
     Right (ParamFile fileName :& RNil) -> do
-      fmap T.pack <$> liftIO (runGhcModCommand fileName (\f->GM.checkSyntax [f]))
+      fmap T.pack <$> runGhcModCommand fileName (\f->GM.checkSyntax [f])
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.checkCmd: ghc’s exhaustiveness checker is broken" Nothing)
 
@@ -102,7 +105,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 <$> liftIO (runGhcModCommand fileName GM.lint)
+      fmap T.pack <$> runGhcModCommand fileName (GM.lint GM.defaultLintOpts)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.lintCmd: ghc’s exhaustiveness checker is broken" Nothing)
 
@@ -113,7 +116,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 <$> liftIO (runGhcModCommand fileName (flip GM.info (GM.Expression (T.unpack expr))))
+      fmap T.pack <$> runGhcModCommand fileName (flip GM.info (GM.Expression (T.unpack expr)))
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.infoCmd: ghc’s exhaustiveness checker is broken" Nothing)
 
@@ -124,7 +127,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) <$> liftIO (runGhcModCommand fileName (\f->GM.types f r c))
+      fmap (toTypeInfo . T.lines . T.pack) <$> runGhcModCommand fileName (\f->GM.types f r c)
     Right _ -> return $ IdeResponseError (IdeError InternalError
       "GhcModPlugin.typesCmd: ghc’s exhaustiveness checker is broken" Nothing)
 
@@ -148,49 +151,24 @@ readTypeResult t = do
 
 -- TODO: Need to thread the session through as in the commented out code below.
 runGhcModCommand :: T.Text -- ^ The file name we'll operate on
-  -> (FilePath -> GM.GmT (GM.GmOutT (GM.GmOutT IO)) a) -> IO (IdeResponse a)
+                 -> (FilePath -> IdeM a)
+                 -> IdeM (IdeResponse a)
 runGhcModCommand fp cmd = do
   let (dir,f) = fileInfo fp
   let opts = GM.defaultOptions
-  old <- getCurrentDirectory
-  bracket (setCurrentDirectory dir)
-          (\_ -> setCurrentDirectory old)
+  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
-            setCurrentDirectory root
-        -- s <- GHC.getSession
-            (r,_l) <- GM.runGmOutT opts $ GM.runGhcModT opts $ do
-            -- (r,_l) <- GM.runGhcModT opts $ do
-                -- GHC.setSession s
-                -- s <- GM.getSession
-                -- GM.setSession s
-                -- setTargets [fileName]
-                cr <- cmd f
-                -- s' <- GHC.getSession
-                let s' = undefined
-                return (cr,s')
-            -- (Either GM.GhcModError String, GM.GhcModLog)
-            case r of
-              Left e -> return $ IdeResponseError (IdeError PluginError (T.pack $ "doCheck:got " ++ show e) Nothing)
-              Right (checkResult,_s3) -> do
-                -- GHC.setSession s3
-                return $ (IdeResponseOk checkResult)
+            liftIO $ setCurrentDirectory root
+            let setRoot e = e{GM.gmCradle = (GM.gmCradle e){GM.cradleRootDir=root}}
+            (IdeResponseOk <$> GM.gmeLocal setRoot (cmd f)) `G.gcatch` \(e :: GM.GhcModError) ->
+               return $ IdeResponseFail $ IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Nothing
           )
 
-{-
-dispatcher = runGmlT $ forever $ do
-    s <- getSession
-    (r, s') <- runGhcModT $ do
-      setSession s
-      r <- checkSyntax
-      s <- getSession
-      return (r,s)
-    setSession s'
-
--}
-
 -- ---------------------------------------------------------------------
 
 -- | Returns the directory and file name

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

@@ -1,50 +1,46 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Haskell.Ide.Engine.Monad where
 
+import           Control.Concurrent
+import           Control.Concurrent.MVar
 import           Control.Exception
 import           Control.Monad.IO.Class
-import           Control.Monad.State
-import           Data.IORef
+import           Control.Monad.State.Strict
+import           Data.Char
 import           Haskell.Ide.Engine.PluginDescriptor
 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 qualified Language.Haskell.GhcMod.Debug as GM
 import           System.Directory
-
+import           System.IO.Unsafe
 -- ---------------------------------------------------------------------
 
+runLock :: MVar ThreadId
+runLock = unsafePerformIO $ newEmptyMVar
+{-# NOINLINE runLock #-}
+
 runIdeM :: IdeState -> IdeM a -> IO a
-runIdeM initState f = do
-    initializedRef <- newIORef False
-    let inner' = GM.runGmOutT opts $ GM.runGhcModT opts $ do
-            liftIO $ writeIORef initializedRef True
-            (unIdeM f)
-        inner = runStateT inner' initState
-        opts = GM.defaultOptions
-    ((eres, _),_s) <- inner `catch` \ex -> case ex of
-        GM.GMEWrongWorkingDirectory projDir _ -> do
-            -- Only switch dirs if the exception occurs during
-            -- initialization. This way we don't mysteriously restart
-            -- execution if the exception happens later.
-            initialized <- readIORef initializedRef
-            if initialized
-                then throwIO ex
-                else do
-                    old <- getCurrentDirectory
-                    bracket (setCurrentDirectory projDir)
-                            (\_ -> setCurrentDirectory old)
-                            (\_ -> inner)
-        _ -> throwIO ex
-    case eres of
-        Left err -> throwIO err
-        Right res -> return res
+runIdeM s0 f = do
+    let errorIO e = liftIO $ throwIO $ ErrorCall e
 
--- ---------------------------------------------------------------------
+    -- FIXME: this is very racy do some fancy stuff with masking
+    -- _ <- liftIO $ (\case Just tid -> errorIO $ "locked by " ++ show tid)
+    --     =<< tryReadMVar runLock
+    -- liftIO $ putMVar runLock =<< myThreadId
 
-setTargets :: [Either FilePath GM.ModuleName] -> IdeM ()
-setTargets targets = IdeM $ GM.runGmlT targets (return ())
+    -- root <- either (error "could not get project root") (GM.dropWhileEnd isSpace) . fst
+    --           <$> GM.runGhcModT GM.defaultOptions GM.rootInfo
 
+    -- liftIO $ setCurrentDirectory root
 
+    ((eres, _),_s) <- flip runStateT s0 (GM.runGhcModT GM.defaultOptions f)
+    case eres of
+        Left err -> liftIO $ throwIO err
+        Right res -> return res
 
 -- EOF

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

@@ -83,15 +83,11 @@ module Haskell.Ide.Engine.PluginDescriptor
   , IdePlugins(..)
 
   -- * The IDE monad
-  , IdeM(..)
+  , IdeM
   , IdeState(..)
-  , HasIdeState(..)
+  , getPlugins
   ) where
 
-import qualified DynFlags      as GHC
-import qualified GHC           as GHC
-import qualified HscTypes      as GHC
-
 import           Control.Applicative
 import           Data.Aeson
 import           Data.Aeson.Types
@@ -100,10 +96,7 @@ import           Data.Maybe
 import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import           Data.Typeable
-import           Control.Monad.IO.Class
-import           Control.Monad.State
-import           Control.Monad.Trans.Control ( control, liftBaseOp, liftBaseOp_)
-import           Exception
+import           Control.Monad.State.Strict
 import           GHC.Generics
 import qualified Language.Haskell.GhcMod.Monad as GM
 
@@ -131,7 +124,7 @@ instance Show PluginDescriptor where
 -- | Ideally a Command is defined in such a way that its CommandDescriptor
 -- can be exposed via the native CLI for the tool being exposed as well.
 -- Perhaps use Options.Applicative for this in some way.
-data Command = forall a .(ValidResponse a) => Command
+data Command = forall a. (ValidResponse a) => Command
   { cmdDesc :: !CommandDescriptor
   , cmdFunc :: !(CommandFunc a)
   }
@@ -140,7 +133,7 @@ instance Show Command where
   show (Command desc _func) = "(Command " ++ show desc ++ ")"
 
 -- | Build a command, ensuring the command response type name and the command function match
-buildCommand :: forall a .(ValidResponse a)
+buildCommand :: forall a. (ValidResponse a)
   => CommandFunc a
   -> CommandName
   -> T.Text
@@ -597,56 +590,15 @@ instance (ValidResponse a) => FromJSON (IdeResponse a) where
 
 -- ---------------------------------------------------------------------
 
-newtype IdeM a = IdeM { unIdeM :: GM.GhcModT (GM.GmOutT (StateT IdeState IO)) a}
-      deriving ( Functor
-               , Applicative
-               , Alternative
-               , Monad
-               , MonadPlus
-               , MonadIO
-               , GM.GmEnv
-               , GM.GmOut
-               , GM.MonadIO
-               , ExceptionMonad
-               )
+type IdeM = IdeT IO
+type IdeT m = GM.GhcModT (StateT IdeState m)
 
 data IdeState = IdeState
   {
     idePlugins :: Plugins
   } deriving (Show)
 
-class (Monad m) => HasIdeState m where
-  getPlugins :: m Plugins
-  -- | Set up an underlying GHC session for the specific targets. Should map
-  -- down to ghc-mod setTargets.
-  setTargets :: [FilePath] -> m ()
-
--- ---------------------------------------------------------------------
-
-instance GM.MonadIO (StateT IdeState IO) where
-  liftIO = liftIO
-
-instance MonadState IdeState IdeM where
-  get   = IdeM (lift $ lift $ lift get)
-  put s = IdeM (lift $ lift $ lift (put s))
-
-instance GHC.GhcMonad IdeM where
-  getSession     = IdeM $ GM.unGmlT GM.gmlGetSession
-  setSession env = IdeM $ GM.unGmlT (GM.gmlSetSession env)
-
-instance GHC.HasDynFlags IdeM where
-  getDynFlags = GHC.hsc_dflags <$> GHC.getSession
-
-instance ExceptionMonad (StateT IdeState IO) where
-  gcatch act handler = control $ \run ->
-    run act `gcatch` (run . handler)
-
-  gmask = liftBaseOp gmask . liftRestore
-    where liftRestore f r = f $ liftBaseOp_ r
-
--- AZ:TODO: These can become just MonadFunctions
-instance HasIdeState IdeM where
-  getPlugins = gets idePlugins
-  setTargets targets = IdeM $ GM.runGmlT (map Left targets) (return ())
+getPlugins :: IdeM Plugins
+getPlugins = lift $ lift $ idePlugins <$> get
 
 -- EOF

hie-plugin-api/hie-plugin-api.cabal

@@ -24,7 +24,8 @@ library
                      , directory
                      , fast-logger
                      , ghc
-                     , ghc-mod >= 5.4
+-- ghc-mod > 5.4.0.0 -- TODO before release
+                     , ghc-mod >= 5.4.0.0
                      , lifted-base
                      , monad-control
                      , monad-logger

stack.yaml

@@ -7,6 +7,12 @@ packages:
 - hie-plugin-api
 - hie-ghc-mod
 - hie-hare
+# - ../ghci-ng
+- location:
+    git: https://github.com/kazu-yamamoto/ghc-mod.git
+    commit: b9bd4ebf77b22d2d9061d647d7799ddcc7c51228
+    # commit: bff86be69f556f80a8dcd9dd42774ab77cb00eba
+  extra-dep: true
 extra-deps:
  - HaRe-0.8.2.1
  - rosezipper-0.2