haskell-tools-daemon 0.4.1.3 → 0.5.0.0

raw patch · 4 files changed

+61/−24 lines, 4 filesdep ~aesondep ~haskell-tools-astdep ~haskell-tools-daemonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, haskell-tools-ast, haskell-tools-daemon, haskell-tools-prettyprint, haskell-tools-refactor

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/Refactor/Daemon.hs +28/−7
• Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs +1/−1
• haskell-tools-daemon.cabal +9/−8
• test/Main.hs +23/−8

@@ -12,6 +12,8 @@ import Control.Exception
 import Control.Monad
 import Control.Monad.State
+import Control.Reference
+import qualified Data.Aeson as A ((.=))
 import Data.Aeson hiding ((.=))
 import Data.ByteString.Lazy.Char8 (ByteString)
 import Data.ByteString.Lazy.Char8 (unpack)
@@ -28,14 +30,16 @@ import System.Environment
 import System.IO
 
+import Bag
 import DynFlags
+import ErrUtils
+import FastString (unpackFS)
 import GHC hiding (loadModule)
 import GHC.Paths ( libdir )
 import GhcMonad (GhcMonad(..), Session(..), reflectGhc, modifySession)
 import HscTypes (hsc_mod_graph)
 import Packages
-
-import Control.Reference
+import SrcLoc
 
 import Language.Haskell.Tools.AST
 import Language.Haskell.Tools.PrettyPrint
@@ -47,6 +51,8 @@ import Language.Haskell.Tools.Refactor.RefactorBase
 import Language.Haskell.Tools.Refactor.Session
 
+import Debug.Trace
+
 -- TODO: handle boot files
 
 runDaemonCLI :: IO ()
@@ -56,6 +62,7 @@ runDaemon args = withSocketsDo $
     do let finalArgs = args ++ drop (length args) defaultArgs
            isSilent = read (finalArgs !! 1)
+       when (not isSilent) $ putStrLn $ "Starting Haskell Tools daemon"
        addrinfos <- getAddrInfo
                     (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
                     Nothing (Just (finalArgs !! 0))
@@ -71,7 +78,8 @@ 
 clientLoop :: Bool -> Socket -> IO ()
 clientLoop isSilent sock
-  = do (conn,_) <- accept sock
+  = do when (not isSilent) $ putStrLn $ "Starting client loop"
+       (conn,_) <- accept sock
        ghcSess <- initGhcSession
        state <- newMVar initSession
        serverLoop isSilent ghcSess state conn
@@ -130,7 +138,7 @@                          ++ concat (intersperse ", " ignoredMods)
                          ++ ". Multiple modules with the same qualified name are not supported."
               else LoadedModules modules
-      Left err -> liftIO $ resp $ CompilationProblem err 
+      Left err -> liftIO $ resp $ either ErrorMessage CompilationProblem (getProblems err) 
     return True
   where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes
         initializePackageDBIfNeeded = do
@@ -159,7 +167,7 @@      modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` removedMods) . ms_mod) (hsc_mod_graph s) })
      reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms]))
                                        (\ms -> getModSumOrig ms `elem` changed)
-     liftIO $ case reloadRes of Left errs -> resp (CompilationProblem errs)
+     liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage CompilationProblem (getProblems errs))
                                 Right _ -> return ()
      return True
 
@@ -208,7 +216,7 @@         reloadChanges changedMods 
           = do reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms])) 
                                                  (\ms -> modSumName ms `elem` changedMods)
-               liftIO $ case reloadRes of Left errs -> resp (ErrorMessage $ "The result of the refactoring contains errors: " ++ errs)
+               liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage (ErrorMessage . ("The result of the refactoring contains errors: " ++) . show) (getProblems errs))
                                           Right _ -> return ()
 
 initGhcSession :: IO Session
@@ -224,6 +232,10 @@                        }
        void $ setSessionDynFlags dfs'
 
+getProblems :: RefactorException -> Either String [(SrcSpan, String)]
+getProblems (SourceCodeProblem errs) = Right $ map (\err -> (errMsgSpan err, show err)) $ bagToList errs
+getProblems other = Left $ displayException other
+
 data ClientMessage
   = KeepAlive
   | SetPackageDB { pkgDB :: PackageDB }
@@ -246,10 +258,19 @@ data ResponseMsg
   = KeepAliveResponse
   | ErrorMessage { errorMsg :: String }
-  | CompilationProblem { errorMsg :: String }
+  | CompilationProblem { errorMarkers :: [(SrcSpan, String)] }
   | ModulesChanged { moduleChanges :: [FilePath] }
   | LoadedModules { loadedModules :: [FilePath] }
   | Disconnected
   deriving (Show, Generic)
 
 instance ToJSON ResponseMsg
+
+instance ToJSON SrcSpan where
+  toJSON (RealSrcSpan sp) = object [ "file" A..= unpackFS (srcSpanFile sp)
+                                   , "startRow" A..= srcLocLine (realSrcSpanStart sp) 
+                                   , "startCol" A..= srcLocCol (realSrcSpanStart sp) 
+                                   , "endRow" A..= srcLocLine (realSrcSpanEnd sp) 
+                                   , "endCol" A..= srcLocCol (realSrcSpanEnd sp)
+                                   ]
+  toJSON _ = Null

@@ -6,7 +6,7 @@ import Data.List
 import GHC.Generics (Generic(..))
 import System.Directory (withCurrentDirectory, doesFileExist, doesDirectoryExist)
-import System.FilePath (FilePath(..), (</>))
+import System.FilePath (FilePath, (</>))
 import System.Process (readProcessWithExitCode)
 
 data PackageDB = AutoDB

@@ -1,5 +1,5 @@ name:                haskell-tools-daemon
-version:             0.4.1.3
+version:             0.5.0.0
 synopsis:            Background process for Haskell-tools refactor that editors can connect to.
 description:         Background process for Haskell-tools refactor that editors can connect to.
 homepage:            https://github.com/haskell-tools/haskell-tools
@@ -54,7 +54,7 @@ library
   ghc-options:         -O2
   build-depends:       base                      >= 4.9   && < 5.0
-                     , aeson                     >= 1.0  && < 1.1
+                     , aeson                     >= 1.0  && < 1.2
                      , bytestring                >= 0.10  && < 1.0
                      , filepath                  >= 1.4   && < 2.0
                      , containers                >= 0.5   && < 0.6
@@ -66,9 +66,9 @@                      , ghc-paths                 >= 0.1   && < 0.2
                      , references                >= 0.3.2 && < 1.0
                      , network                   >= 2.6   && < 3.0
-                     , haskell-tools-ast         >= 0.4   && < 0.5
-                     , haskell-tools-prettyprint >= 0.4   && < 0.5
-                     , haskell-tools-refactor    >= 0.4   && < 0.5
+                     , haskell-tools-ast         >= 0.5   && < 0.6
+                     , haskell-tools-prettyprint >= 0.5   && < 0.6
+                     , haskell-tools-refactor    >= 0.5   && < 0.6
   exposed-modules:     Language.Haskell.Tools.Refactor.Daemon
                      , Language.Haskell.Tools.Refactor.Daemon.State
                      , Language.Haskell.Tools.Refactor.Daemon.PackageDB
@@ -78,7 +78,7 @@ executable ht-daemon
   ghc-options:         -O2
   build-depends:       base                      >= 4.9 && < 5.0
-                     , haskell-tools-daemon      >= 0.4 && < 0.5
+                     , haskell-tools-daemon      >= 0.5 && < 0.6
   hs-source-dirs:      exe
   main-is:             Main.hs
   default-language:    Haskell2010
@@ -90,6 +90,7 @@   main-is:             Main.hs  
   build-depends:       base                      >= 4.9  && < 4.10
                      , HUnit                     >= 1.5  && < 1.6
+                     , ghc                       >= 8.0   && < 8.1
                      , tasty                     >= 0.11 && < 0.12
                      , tasty-hunit               >= 0.9  && < 0.10
                      , directory                 >= 1.2  && < 1.4
@@ -97,6 +98,6 @@                      , filepath                  >= 1.4  && < 2.0
                      , bytestring                >= 0.10 && < 0.11
                      , network                   >= 2.6  && < 2.7
-                     , aeson                     >= 1.0 && < 1.1
-                     , haskell-tools-daemon      >= 0.4  && < 0.5
+                     , aeson                     >= 1.0 && < 1.2
+                     , haskell-tools-daemon      >= 0.5  && < 0.6
   default-language:    Haskell2010

@@ -1,4 +1,4 @@-{-# LANGUAGE StandaloneDeriving, LambdaCase, ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving, LambdaCase, ScopedTypeVariables, OverloadedStrings #-}
 module Main where
 
 import Test.Tasty
@@ -21,7 +21,8 @@ import Data.Maybe
 import System.IO
 
-import Debug.Trace
+import SrcLoc
+import FastString
 
 import Language.Haskell.Tools.Refactor.Daemon
 import Language.Haskell.Tools.Refactor.Daemon.PackageDB
@@ -239,11 +240,11 @@ 
 pkgDbTests :: [(String, IO (), [ClientMessage], [ResponseMsg])]
 pkgDbTests 
-  = [ ( "stack"
+  = [ {- ( "stack"
        , withCurrentDirectory (testRoot </> "stack") initStack
        , [SetPackageDB StackDB, AddPackages [testRoot </> "stack"]]
        , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] )
-    , ( "cabal-sandbox"
+    , -} ( "cabal-sandbox"
       , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox
       , [SetPackageDB CabalSandboxDB, AddPackages [testRoot </> "cabal-sandbox"]]
       , [LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]] )
@@ -251,10 +252,10 @@       , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox
       , [SetPackageDB AutoDB, AddPackages [testRoot </> "cabal-sandbox"]]
       , [LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]] )
-    , ( "stack-auto"
-      , withCurrentDirectory (testRoot </> "stack") initStack
-      , [SetPackageDB AutoDB, AddPackages [testRoot </> "stack"]]
-      , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] )
+    -- , ( "stack-auto"
+    --   , withCurrentDirectory (testRoot </> "stack") initStack
+    --   , [SetPackageDB AutoDB, AddPackages [testRoot </> "stack"]]
+    --   , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] )
     , ( "pkg-db-reload"
       , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox
       , [ SetPackageDB AutoDB
@@ -397,3 +398,17 @@ 
 longestCommonPrefix :: (Eq a) => [[a]] -> [a]
 longestCommonPrefix = foldl1 commonPrefix
+
+instance FromJSON SrcSpan where
+    parseJSON (Object v) = mkSrcSpanReal <$> v .: "file" 
+                                         <*> v .: "startRow" 
+                                         <*> v .: "startCol" 
+                                         <*> v .: "endRow"
+                                         <*> v .: "endCol"
+    parseJSON _          = fail "not an object"
+
+
+mkSrcSpanReal :: String -> Int -> Int -> Int -> Int -> SrcSpan
+mkSrcSpanReal file startRow startCol endRow endCol 
+  = mkSrcSpan (mkSrcLoc (mkFastString file) startRow startCol)
+              (mkSrcLoc (mkFastString file) endRow endCol)