haskell-tools-daemon 1.0.0.4 → 1.0.1.1

raw patch · 15 files changed

+92/−53 lines, 15 filesdep ~Cabaldep ~aesonPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: Cabal, aeson

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/Daemon.hs +25/−20
• Language/Haskell/Tools/Daemon/ErrorHandling.hs +1/−1
• Language/Haskell/Tools/Daemon/GetModules.hs +2/−1
• Language/Haskell/Tools/Daemon/PackageDB.hs +1/−0
• Language/Haskell/Tools/Daemon/Protocol.hs +12/−1
• Language/Haskell/Tools/Daemon/Representation.hs +1/−0
• Language/Haskell/Tools/Daemon/Session.hs +5/−2
• Language/Haskell/Tools/Daemon/State.hs +2/−1
• Language/Haskell/Tools/Daemon/Update.hs +22/−9
• Language/Haskell/Tools/Daemon/Utils.hs +1/−0
• Language/Haskell/Tools/Daemon/Watch.hs +1/−0
• examples/Project/source-error/A.hs +1/−1
• exe/Main.hs +2/−2
• haskell-tools-daemon.cabal +11/−11
• test/Main.hs +5/−4

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, MultiWayIf, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts, MonoLocalBinds, MultiWayIf, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications #-}
+
 -- | The central module for the background process of Haskell-tools. Starts the daemon process and
 -- updates it for each client request in a loop. After this releases the resources and terminates.
 module Language.Haskell.Tools.Daemon where
@@ -22,23 +23,24 @@ import Language.Haskell.Tools.Daemon.State (DaemonSessionState(..), initSession, exiting)
 import Language.Haskell.Tools.Daemon.Update (updateClient, initGhcSession)
 import Language.Haskell.Tools.Daemon.Watch (createWatchProcess', stopWatch)
-import Language.Haskell.Tools.Refactor (RefactoringChoice(..))
+import Language.Haskell.Tools.Refactor (RefactoringChoice(..), QueryChoice(..))
 import Paths_haskell_tools_daemon (version)
 
 -- | Starts the daemon process. This will not return until the daemon stops. You can use this entry
 -- point when the other endpoint of the client connection is not needed, for example, when you use
 -- socket connection to connect to the daemon process.
-runDaemon' :: [RefactoringChoice] -> DaemonOptions -> IO ()
-runDaemon' refactorings args = do store <- newEmptyMVar
-                                  runDaemon refactorings socketMode store args
+runDaemon' :: [RefactoringChoice] -> [QueryChoice] -> DaemonOptions -> IO ()
+runDaemon' refactorings queries args
+  = do store <- newEmptyMVar
+       runDaemon refactorings queries socketMode store args
 
 -- | Starts the daemon process. This will not return until the daemon stops.
 -- The daemon process is parameterized by the refactorings you can use in it. This entry point gives
 -- back the other endpoint of the connection so it can be used to run the daemon in the same process.
-runDaemon :: [RefactoringChoice] -> WorkingMode a -> MVar a -> DaemonOptions -> IO ()
-runDaemon _ _ _ DaemonOptions{..} | daemonVersion
+runDaemon :: [RefactoringChoice] -> [QueryChoice] -> WorkingMode a -> MVar a -> DaemonOptions -> IO ()
+runDaemon _ _ _ _ DaemonOptions{..} | daemonVersion
   = putStrLn $ showVersion version
-runDaemon refactorings mode connStore config@DaemonOptions{..} = withSocketsDo $
+runDaemon refactorings queries mode connStore config@DaemonOptions{..} = withSocketsDo $
     do when (not silentMode) $ putStrLn $ "Starting Haskell Tools daemon"
        hSetBuffering stdout LineBuffering
        hSetBuffering stderr LineBuffering
@@ -49,10 +51,10 @@        state <- newMVar initSession
        -- set the ghc flags given by command line
        case Options.ghcFlags sharedOptions of
-         Just flags -> void $ respondTo config refactorings ghcSess state (daemonSend mode conn) warnMVar (SetGHCFlags flags)
+         Just flags -> void $ respondTo config refactorings queries ghcSess state (daemonSend mode conn) warnMVar (SetGHCFlags flags)
          Nothing -> return ()
        case projectType sharedOptions of
-         Just t -> void $ respondTo config refactorings ghcSess state (daemonSend mode conn) warnMVar (SetPackageDB t)
+         Just t -> void $ respondTo config refactorings queries ghcSess state (daemonSend mode conn) warnMVar (SetPackageDB t)
          Nothing -> return ()
        -- set up the file watch
        (wp,th) <- if noWatch sharedOptions
@@ -61,7 +63,7 @@                            (watchExe sharedOptions) ghcSess state warnMVar (daemonSend mode conn)
        modifyMVarMasked_ state ( \s -> return s { _watchProc = wp, _watchThreads = th })
        -- start the server loop
-       serverLoop refactorings mode conn config ghcSess state warnMVar
+       serverLoop refactorings queries mode conn config ghcSess state warnMVar
        -- free allocated resources
        case wp of Just watchProcess -> stopWatch watchProcess th
                   Nothing -> return ()
@@ -69,19 +71,19 @@ 
 -- | Starts the server loop, receiving requests from the client and updated the server state
 -- according to these.
-serverLoop :: [RefactoringChoice] -> WorkingMode a -> a -> DaemonOptions -> Session
+serverLoop :: [RefactoringChoice] -> [QueryChoice] -> WorkingMode a -> a -> DaemonOptions -> Session
                 -> MVar DaemonSessionState -> MVar [Marker] -> IO ()
-serverLoop refactorings mode conn options ghcSess state warnMVar =
+serverLoop refactorings queries mode conn options ghcSess state warnMVar =
   do msgs <- daemonReceive mode conn
      continue <- mapM respondToMsg msgs
      sessionData <- readMVar state
      when (not (sessionData ^. exiting) && all (== True) continue)
-       $ serverLoop refactorings mode conn options ghcSess state warnMVar
-   `catches` exceptionHandlers (serverLoop refactorings mode conn options ghcSess state warnMVar)
+       $ serverLoop refactorings queries mode conn options ghcSess state warnMVar
+   `catches` exceptionHandlers (serverLoop refactorings queries mode conn options ghcSess state warnMVar)
                                (daemonSend mode conn . ErrorMessage)
   where respondToMsg (Right req)
           = do when (not (silentMode options)) $ putStrLn $ "Message received: " ++ show req
-               respondTo options refactorings ghcSess state (daemonSend mode conn) warnMVar req
+               respondTo options refactorings queries ghcSess state (daemonSend mode conn) warnMVar req
            `catches` userExceptionHandlers
                         (\s -> daemonSend mode conn (ErrorMessage s) >> return True)
                         (\err hint -> daemonSend mode conn (CompilationProblem err hint) >> return True)
@@ -89,7 +91,10 @@                                      return True
 
 -- | Responds to a client request by modifying the daemon and GHC state accordingly.
-respondTo :: DaemonOptions -> [RefactoringChoice] -> Session -> MVar DaemonSessionState
-               -> (ResponseMsg -> IO ()) -> MVar [Marker] -> ClientMessage -> IO Bool
-respondTo options refactorings ghcSess state next warnMVar req
-  = modifyMVar state (\st -> swap <$> reflectGhc (runStateT (updateClient options warnMVar refactorings next req) st) ghcSess)
+respondTo :: DaemonOptions -> [RefactoringChoice] -> [QueryChoice] -> Session
+               -> MVar DaemonSessionState -> (ResponseMsg -> IO ()) -> MVar [Marker]
+               -> ClientMessage -> IO Bool
+respondTo options refactorings queries ghcSess state next warnMVar req
+  = modifyMVar state (\st -> swap <$> reflectGhc (runStateT upClient st) ghcSess)
+  where upClient = updateClient options warnMVar refactorings queries next req
+

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase, ScopedTypeVariables #-}
+
 -- | Handlers for common errors in Haskell-tools daemon.
 module Language.Haskell.Tools.Daemon.ErrorHandling where
 
@@ -7,7 +8,6 @@ import Control.Monad (Monad(..), when)
 import Data.List
 import Data.Maybe (Maybe(..), catMaybes)
-import Data.Tuple (snd)
 import ErrUtils (ErrMsg(..))
 import HscTypes (SourceError, srcErrorMessages)
 import SrcLoc (SrcSpan(..), isGoodSrcSpan)

@@ -1,4 +1,5 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, LambdaCase, RankNTypes, NamedFieldPuns, TupleSections, TypeApplications #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts, LambdaCase, RankNTypes, RecordPuns, TupleSections, TypeApplications #-}
+
 -- | Collecting modules contained in a module collection (library, executable, testsuite or
 -- benchmark). Gets names, source file locations, compilation and load flags for these modules.
 module Language.Haskell.Tools.Daemon.GetModules where

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric, MultiWayIf, ScopedTypeVariables #-}
+
 -- | Setting the package database to use when compiling modules. The daemon must have one single
 -- package database that cannot be changed after a package is loaded using that package database.
 -- Available package databases are the cabal global, the cabal sandbox, the stack or one that had

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
+
 -- | This module declares the messages that can be sent from the client to the
 -- daemon engine and from the engine to the client.
 module Language.Haskell.Tools.Daemon.Protocol where
@@ -48,6 +49,14 @@     -- with the selection and details. Successful refactorings will cause re-loading of modules.
     -- If 'shutdownAfter' or 'diffMode' is not set, after the refactoring,
     -- modules are re-loaded, LoadingModules, LoadedModule responses are sent.
+  | PerformQuery { query :: String
+                 , modulePath :: FilePath
+                 , editorSelection :: String
+                 , details :: [String] -- ^ Additional details for the refactoring like the
+                                       -- names of generated definitions.
+                 , shutdownAfter :: Bool -- ^ Stop the daemon after performing the query.
+                 }
+    -- ^ Orders the engine to perform a query on the module given with the selection and details.
   | UndoLast
     -- ^ Asks the daemon to undo the last refactoring.
   | Disconnect
@@ -85,6 +94,8 @@                  , loadedModuleName :: String
                  }
     -- ^ The engine has loaded the given module.
+  | QueryResult { queryResult :: Value }
+    -- ^ The result of querying the program representation.
   | UnusedFlags { unusedFlags :: [String] }
     -- ^ Returns the flags that are not used by the engine.
   | Disconnected
@@ -99,7 +110,7 @@ instance Show Marker where
   show marker = show (severity marker) ++ " at " ++ shortShowSpanWithFile (location marker) ++ ": " ++ message marker
 
-data Severity = Error | Warning | Info 
+data Severity = Error | Warning | Info
   deriving (Show, Generic, Eq)
 
 instance ToJSON ResponseMsg

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, RecordWildCards, TemplateHaskell #-}
+
 -- | Representation of the modules and packages in the daemon session.
 module Language.Haskell.Tools.Daemon.Representation where
 

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, MultiWayIf, TypeApplications, TupleSections #-}
+{-# LANGUAGE FlexibleContexts, TypeApplications #-}
+
 -- | Common operations for managing Daemon-tools sessions, for example loading whole packages or
 -- re-loading modules when they are changed. Maintains the state of the compilation with loaded
 -- modules. Contains checks for compiling the modules to code when Template Haskell is used.
@@ -179,7 +180,9 @@   -- clear the symbol cache for iserv
   liftIO $ purgeLookupSymbolCache env
   -- clear the global linker state
-  liftIO $ unload env (mapMaybe hm_linkable (eltsHpt hptStay))
+  dfs <- getSessionDynFlags
+  when (not $ gopt Opt_ExternalInterpreter dfs) $
+    liftIO $ unload env (mapMaybe hm_linkable (eltsHpt hptStay))
   -- clear name cache
   nameCache <- liftIO $ readIORef $ hsc_NC env
   let nameCache' = nameCache { nsNames = delModuleEnvList (nsNames nameCache) (map ms_mod mods) }

@@ -1,4 +1,5 @@-{-# LANGUAGE NamedFieldPuns, RecordWildCards, TemplateHaskell #-}
+{-# LANGUAGE RecordPuns, RecordWildCards, TemplateHaskell #-}
+
 module Language.Haskell.Tools.Daemon.State where
 
 import Control.Concurrent

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, LambdaCase, MultiWayIf, RecordWildCards, TupleSections, TypeApplications, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, RecordWildCards, TupleSections, TypeApplications #-}
+
 -- | Resolves how the daemon should react to individual requests from the client.
 module Language.Haskell.Tools.Daemon.Update (updateClient, updateForFileChanges, initGhcSession) where
 
@@ -48,15 +49,18 @@ -- | Context for responding to a user request.
 data UpdateCtx = UpdateCtx { options :: DaemonOptions
                            , refactorings :: [RefactoringChoice]
+                           , queries :: [QueryChoice]
                            , response :: ResponseMsg -> IO ()
                            , warnMVar :: MVar [Marker]
                            }
 
 -- | This function does the real job of acting upon client messages in a stateful environment of a
 -- client.
-updateClient :: DaemonOptions -> MVar [Marker] -> [RefactoringChoice] -> (ResponseMsg -> IO ()) -> ClientMessage
+updateClient :: DaemonOptions -> MVar [Marker] -> [RefactoringChoice] -> [QueryChoice]
+                  -> (ResponseMsg -> IO ()) -> ClientMessage
                   -> DaemonSession Bool
-updateClient options warnMVar refactors resp = updateClient' (UpdateCtx options refactors resp warnMVar)
+updateClient options warnMVar refactors queries resp
+  = updateClient' (UpdateCtx options refactors queries resp warnMVar)
 
 updateClient' :: UpdateCtx -> ClientMessage -> DaemonSession Bool
 -- resets the internal state of Haskell-tools (but keeps options)
@@ -65,7 +69,9 @@        modify' $ resetSession
        Session sess <- liftIO $ reinitGhcSession warnMVar (generateCode (sharedOptions options))
        env <- liftIO $ readIORef sess
-       liftIO $ unload env [] -- clear (unload everything) the global state of the linker
+       dfs <- getSessionDynFlags
+       when (not $ gopt Opt_ExternalInterpreter dfs) $
+         liftIO $ unload env [] -- clear (unload everything) the global state of the linker
        lift $ setSession env
        addPackages response warnMVar roots
        return True
@@ -139,7 +145,15 @@   = do modify (exiting .= True)
        return False
 
--- TODO: perform refactorings without selected modules
+updateClient' UpdateCtx{..} (PerformQuery query modPath selection args shutdown)
+  = do (selectedMod, otherMods) <- getFileMods modPath
+       res <- lift $ performQuery queries (query:selection:args) (maybe (Left modPath) Right selectedMod) otherMods
+       case res of
+         Left err -> liftIO $ response $ ErrorMessage err
+         Right res -> liftIO $ response $ QueryResult res
+       when shutdown $ liftIO $ response Disconnected
+       return (not shutdown)
+
 updateClient' UpdateCtx{..} (PerformRefactoring refact modPath selection args shutdown diffMode)
   = do (selectedMod, otherMods) <- getFileMods modPath
        performRefactoring (refact:selection:args)
@@ -374,15 +388,14 @@                                         _              -> Nothing)
 
 initGhcSession :: Bool -> IO (Session, MVar [Marker])
-initGhcSession genCode = do 
+initGhcSession genCode = do
   mv <- newMVar []
   sess <- Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags' genCode True >> setupLogging mv >> getSession))
   return (sess, mv)
 
 reinitGhcSession :: MVar [Marker] -> Bool -> IO Session
-reinitGhcSession mv genCode = do 
-  sess <- Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags' genCode True >> setupLogging mv >> getSession))
-  return sess
+reinitGhcSession mv genCode = do
+  Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags' genCode True >> setupLogging mv >> getSession))
 
 setupLogging :: MVar [Marker] -> Ghc ()
 setupLogging mv = modifySession $ \s -> s { hsc_dflags = (hsc_dflags s) { log_action = logger } }

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, RankNTypes #-}
+
 -- | Utility operations for the reprsentation of module collections.
 module Language.Haskell.Tools.Daemon.Utils where
 

@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
+
 -- | Controls the file system watching in the daemon. The file system watching must run in a
 -- separate process to prevent blocking because of file operations interfering with watch.
 module Language.Haskell.Tools.Daemon.Watch where

@@ -1,4 +1,4 @@ module A where
 
 a :: ()
-a = 4+a = 4

@@ -4,8 +4,8 @@ import Language.Haskell.Tools.Daemon (runDaemon)
 import Language.Haskell.Tools.Daemon.Mode (socketMode)
 import Language.Haskell.Tools.Daemon.Options (parseDaemonCLI)
-import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings)
+import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings, builtinQueries)
 
 main :: IO ()
 main = do store <- newEmptyMVar
-          runDaemon builtinRefactorings socketMode store =<< parseDaemonCLI
+          runDaemon builtinRefactorings builtinQueries socketMode store =<< parseDaemonCLI

@@ -1,5 +1,5 @@ name:                haskell-tools-daemon
-version:             1.0.0.4
+version:             1.0.1.1
 synopsis:            Background process for Haskell-tools that editors can connect to.
 description:         Background process for Haskell-tools that provides a way to use the tools on a
                      whole project. It also makes it possible to use the tools on the project in a
@@ -87,11 +87,11 @@ 
 library
   build-depends:       base                      >= 4.9   && < 5.0
-                     , aeson                     >= 1.0  && < 1.3
+                     , aeson                     >= 1.0   && < 1.4
                      , bytestring                >= 0.10  && < 1.0
                      , deepseq                   >= 1.4   && < 2.0
                      , filepath                  >= 1.4   && < 2.0
-                     , strict                    >= 0.3 && < 0.4
+                     , strict                    >= 0.3   && < 0.4
                      , containers                >= 0.5   && < 0.6
                      , mtl                       >= 2.2   && < 2.3
                      , split                     >= 0.2   && < 1.0
@@ -102,9 +102,9 @@                      , references                >= 0.3.2 && < 1.0
                      , network                   >= 2.6   && < 3.0
                      , Diff                      >= 0.3   && < 0.4
-                     , Cabal                     >= 2.0  && < 2.1
+                     , Cabal                     >= 2.0   && < 2.3
                      , pretty                    >= 1.1   && < 1.2
-                     , optparse-applicative      >= 0.14 && < 0.15
+                     , optparse-applicative      >= 0.14  && < 0.15
                      , template-haskell          >= 2.12  && < 2.13
                      , haskell-tools-prettyprint >= 1.0   && < 1.1
                      , haskell-tools-refactor    >= 1.0   && < 1.1
@@ -134,8 +134,8 @@   ghc-options:         -rtsopts
   build-depends:       base                      >= 4.9 && < 5.0
                      , haskell-tools-daemon
-                     , directory                 >= 1.2  && < 1.4
-                     , filepath                  >= 1.4  && < 2.0
+                     , directory                 >= 1.2 && < 1.4
+                     , filepath                  >= 1.4 && < 2.0
                      , haskell-tools-builtin-refactorings >= 1.0 && < 1.1
   hs-source-dirs:      exe
   main-is:             Main.hs
@@ -146,18 +146,18 @@   ghc-options:         -with-rtsopts=-M2.5g
   hs-source-dirs:      test
   main-is:             Main.hs
-  build-depends:       base                      >= 4.10  && < 4.11
+  build-depends:       base                      >= 4.10 && < 4.11
                      , HUnit                     >= 1.5  && < 1.7
                      , ghc                       >= 8.2  && < 8.3
                      , tasty                     >= 0.11 && < 1.1
-                     , tasty-hunit               >= 0.9 && < 0.11
+                     , tasty-hunit               >= 0.9  && < 0.11
                      , directory                 >= 1.2  && < 1.4
                      , process                   >= 1.6  && < 1.7
                      , filepath                  >= 1.4  && < 2.0
                      , bytestring                >= 0.10 && < 0.11
                      , network                   >= 2.6  && < 2.7
-                     , aeson                     >= 1.0  && < 1.3
+                     , aeson                     >= 1.0  && < 1.4
                      , Glob                      >= 0.9  && < 0.10
                      , haskell-tools-daemon
-                     , haskell-tools-builtin-refactorings >= 1.0  && < 1.1
+                     , haskell-tools-builtin-refactorings >= 1.0 && < 1.1
   default-language:    Haskell2010

@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving #-}
+{-# LANGUAGE LambdaCase, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving #-}+
 module Main where
 
 import Control.Concurrent
@@ -28,7 +29,7 @@ import Language.Haskell.Tools.Daemon.Options as Options (SharedDaemonOptions(..), DaemonOptions(..))
 import Language.Haskell.Tools.Daemon.PackageDB (PackageDB(..))
 import Language.Haskell.Tools.Daemon.Protocol
-import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings)
+import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings, builtinQueries)
 
 pORT_NUM_START = 4100
 pORT_NUM_END = 4200
@@ -655,8 +656,8 @@                                watchDir <- (++) <$> glob watchPath <*> glob linuxWatchPath
                                case (watch, watchDir) of
                                  (True, []) -> error "The watch executable is not found."
-                                 (True, w:_) -> forkIO $ runDaemon' builtinRefactorings (opts portNum (Just w))
-                                 (False, _) -> forkIO $ runDaemon' builtinRefactorings (opts portNum Nothing)
+                                 (True, w:_) -> forkIO $ runDaemon' builtinRefactorings builtinQueries (opts portNum (Just w))
+                                 (False, _) -> forkIO $ runDaemon' builtinRefactorings builtinQueries (opts portNum Nothing)
                                return portNum
           `catch` \(e :: SomeException) -> do putStrLn ("exception caught: `" ++ show e ++ "` trying with a new port")
                                               modifyMVar_ port (\i -> if i < pORT_NUM_END