haskell-tools-daemon 1.0.0.1 → 1.0.0.2
raw patch · 10 files changed
+133/−72 lines, 10 filesdep ~tastydep ~tasty-hunit
Dependency ranges changed: tasty, tasty-hunit
Files
- Language/Haskell/Tools/Daemon.hs +19/−19
- Language/Haskell/Tools/Daemon/ErrorHandling.hs +5/−4
- Language/Haskell/Tools/Daemon/Protocol.hs +15/−1
- Language/Haskell/Tools/Daemon/Representation.hs +3/−3
- Language/Haskell/Tools/Daemon/Session.hs +3/−3
- Language/Haskell/Tools/Daemon/Update.hs +61/−32
- Language/Haskell/Tools/Daemon/Watch.hs +4/−4
- examples/Project/warning/Demo.hs +4/−0
- haskell-tools-daemon.cabal +4/−3
- test/Main.hs +15/−3
Language/Haskell/Tools/Daemon.hs view
@@ -18,24 +18,24 @@ import Language.Haskell.Tools.Daemon.ErrorHandling (userExceptionHandlers, exceptionHandlers) import Language.Haskell.Tools.Daemon.Mode (WorkingMode(..), socketMode) import Language.Haskell.Tools.Daemon.Options as Options (SharedDaemonOptions(..), DaemonOptions(..)) -import Language.Haskell.Tools.Daemon.Protocol (ResponseMsg(..), ClientMessage(..)) +import Language.Haskell.Tools.Daemon.Protocol 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 (IdDom, RefactoringChoice) +import Language.Haskell.Tools.Refactor (RefactoringChoice(..)) 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 IdDom] -> DaemonOptions -> IO () +runDaemon' :: [RefactoringChoice] -> DaemonOptions -> IO () runDaemon' refactorings args = do store <- newEmptyMVar runDaemon refactorings 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 IdDom] -> WorkingMode a -> MVar a -> DaemonOptions -> IO () +runDaemon :: [RefactoringChoice] -> WorkingMode a -> MVar a -> DaemonOptions -> IO () runDaemon _ _ _ DaemonOptions{..} | daemonVersion = putStrLn $ showVersion version runDaemon refactorings mode connStore config@DaemonOptions{..} = withSocketsDo $ @@ -45,23 +45,23 @@ conn <- daemonConnect mode portNumber putMVar connStore conn when (not silentMode) $ putStrLn $ "Connection established" - ghcSess <- initGhcSession (generateCode sharedOptions) + (ghcSess, warnMVar) <- initGhcSession (generateCode sharedOptions) 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) (SetGHCFlags flags) + Just flags -> void $ respondTo config refactorings 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) (SetPackageDB t) + Just t -> void $ respondTo config refactorings ghcSess state (daemonSend mode conn) warnMVar (SetPackageDB t) Nothing -> return () -- set up the file watch (wp,th) <- if noWatch sharedOptions then return (Nothing, []) else createWatchProcess' - (watchExe sharedOptions) ghcSess state (daemonSend mode conn) + (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 + serverLoop refactorings mode conn config ghcSess state warnMVar -- free allocated resources case wp of Just watchProcess -> stopWatch watchProcess th Nothing -> return () @@ -69,19 +69,19 @@ -- | Starts the server loop, receiving requests from the client and updated the server state -- according to these. -serverLoop :: [RefactoringChoice IdDom] -> WorkingMode a -> a -> DaemonOptions -> Session - -> MVar DaemonSessionState -> IO () -serverLoop refactorings mode conn options ghcSess state = +serverLoop :: [RefactoringChoice] -> WorkingMode a -> a -> DaemonOptions -> Session + -> MVar DaemonSessionState -> MVar [Marker] -> IO () +serverLoop refactorings 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 - `catches` exceptionHandlers (serverLoop refactorings mode conn options ghcSess state) + $ serverLoop refactorings mode conn options ghcSess state warnMVar + `catches` exceptionHandlers (serverLoop refactorings 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) req + respondTo options refactorings 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 +89,7 @@ return True -- | Responds to a client request by modifying the daemon and GHC state accordingly. -respondTo :: DaemonOptions -> [RefactoringChoice IdDom] -> Session -> MVar DaemonSessionState - -> (ResponseMsg -> IO ()) -> ClientMessage -> IO Bool -respondTo options refactorings ghcSess state next req - = modifyMVar state (\st -> swap <$> reflectGhc (runStateT (updateClient options refactorings next req) st) ghcSess) +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)
Language/Haskell/Tools/Daemon/ErrorHandling.hs view
@@ -13,11 +13,12 @@ import SrcLoc (SrcSpan(..), isGoodSrcSpan) import System.IO (IO, hPutStrLn, stderr) +import Language.Haskell.Tools.Daemon.Protocol import Language.Haskell.Tools.Daemon.GetModules (UnsupportedPackage(..)) import Language.Haskell.Tools.Refactor -- Handlers for exceptions specific to our application. -userExceptionHandlers :: (String -> IO a) -> ([(SrcSpan, String)] -> [String] -> IO a) -> [Handler a] +userExceptionHandlers :: (String -> IO a) -> ([Marker] -> [String] -> IO a) -> [Handler a] userExceptionHandlers sendError sendCompProblems = [ Handler (\(UnsupportedPackage e) -> sendError ("There are unsupported elements in your package: " ++ e ++ " please correct them before loading them into Haskell-tools.")) , Handler (\(UnsupportedExtension e) -> sendError ("The extension you use is not supported: " ++ e ++ ". Please check your source and cabal files for the use of that language extension.")) @@ -43,10 +44,10 @@ sendError $ "Internal error: " ++ show ex Just (msg, doContinue) -> sendError msg >> when doContinue cont -getProblems :: SourceError -> ([(SrcSpan, String)], [String]) -getProblems errs = let msgs = map (\err -> (errMsgSpan err, show err)) +getProblems :: SourceError -> ([Marker], [String]) +getProblems errs = let msgs = map (\err -> Marker (errMsgSpan err) Error (show err)) $ bagToList $ srcErrorMessages errs - hints = nub $ sort $ catMaybes $ map (handleSourceProblem . snd) msgs + hints = nub $ sort $ catMaybes $ map (handleSourceProblem . message) msgs in (msgs, hints) -- | Hint text and continuation suggestion for different kinds of errors based on pattern matching on error text.
Language/Haskell/Tools/Daemon/Protocol.hs view
@@ -11,6 +11,7 @@ import FastString (unpackFS) import SrcLoc +import Language.Haskell.Tools.Refactor import Language.Haskell.Tools.Daemon.PackageDB (PackageDB) -- | The messages expected from the client. @@ -71,7 +72,7 @@ | ErrorMessage { errorMsg :: String } -- ^ An error message marking internal problems or user mistakes. -- TODO: separate internal problems and user mistakes. - | CompilationProblem { errorMarkers :: [(SrcSpan, String)] + | CompilationProblem { markers :: [Marker] , errorHints :: [String] } -- ^ A response that tells there are errors in the source code given. @@ -90,7 +91,20 @@ -- ^ The engine has closed the connection. deriving (Show, Generic) +data Marker = Marker { location :: SrcSpan + , severity :: Severity + , message :: String + } deriving (Generic, Eq) + +instance Show Marker where + show marker = show (severity marker) ++ " at " ++ shortShowSpanWithFile (location marker) ++ ": " ++ message marker + +data Severity = Error | Warning | Info + deriving (Show, Generic, Eq) + instance ToJSON ResponseMsg +instance ToJSON Marker +instance ToJSON Severity instance ToJSON SrcSpan where toJSON (RealSrcSpan sp) = object [ "file" A..= unpackFS (srcSpanFile sp)
Language/Haskell/Tools/Daemon/Representation.hs view
@@ -33,13 +33,13 @@ = ModuleNotLoaded { _modRecCodeGen :: CodeGenPolicy , _recModuleExposed :: Bool } - | ModuleParsed { _parsedRecModule :: UnnamedModule (Dom RdrName) + | ModuleParsed { _parsedRecModule :: UnnamedModule , _modRecMS :: ModSummary } - | ModuleRenamed { _renamedRecModule :: UnnamedModule (Dom GHC.Name) + | ModuleRenamed { _renamedRecModule :: UnnamedModule , _modRecMS :: ModSummary } - | ModuleTypeChecked { _typedRecModule :: UnnamedModule IdDom + | ModuleTypeChecked { _typedRecModule :: UnnamedModule , _modRecMS :: ModSummary , _modRecCodeGen :: CodeGenPolicy }
Language/Haskell/Tools/Daemon/Session.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, MultiWayIf, TypeApplications #-} +{-# LANGUAGE FlexibleContexts, MultiWayIf, TypeApplications, TupleSections #-} -- | 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. @@ -133,8 +133,8 @@ }) -- save the package database -- | Get the module that is selected for refactoring and all the other modules. -getFileMods :: String -> DaemonSession ( Maybe (SourceFileKey, UnnamedModule IdDom) - , [(SourceFileKey, UnnamedModule IdDom)] ) +getFileMods :: String -> DaemonSession ( Maybe (SourceFileKey, UnnamedModule) + , [(SourceFileKey, UnnamedModule)] ) getFileMods fnameOrModule = do modMaps <- gets (^? refSessMCs & traversal & mcModules) let modules = mapMaybe (\(k,m) -> (\ms tc -> (ms, (k,tc))) <$> (m ^? modRecMS) <*> (m ^? typedRecModule)) -- not type checkable modules are ignored
Language/Haskell/Tools/Daemon/Update.hs view
@@ -11,6 +11,7 @@ import Data.Algorithm.DiffContext (prettyContextDiff, getContextDiff) import qualified Data.ByteString.Char8 as StrictBS (unpack, readFile) import Data.Either (Either(..), either, rights) +import Control.Concurrent.MVar import Data.IORef (readIORef, newIORef) import Data.List as List hiding (insert) import qualified Data.Map as Map (insert, keys, filter) @@ -24,15 +25,16 @@ import System.IO.Strict as StrictIO (hGetContents) import Text.PrettyPrint as PP (text, render) -import DynFlags (DynFlags(..), PkgConfRef(..), PackageDBFlag(..)) +import DynFlags import GHC hiding (loadModule) import GHC.Paths ( libdir ) import GhcMonad (GhcMonad(..), Session(..), modifySession) -import HscTypes (hsc_mod_graph) +import HscTypes +import Outputable import Language.Haskell.Tools.Daemon.ErrorHandling (getProblems) import Language.Haskell.Tools.Daemon.Options (SharedDaemonOptions(..), DaemonOptions(..)) import Language.Haskell.Tools.Daemon.PackageDB (decidePkgDB, packageDBLoc, detectAutogen) -import Language.Haskell.Tools.Daemon.Protocol +import Language.Haskell.Tools.Daemon.Protocol as HT import Language.Haskell.Tools.Daemon.Representation as HT import Language.Haskell.Tools.Daemon.Session import Language.Haskell.Tools.Daemon.State @@ -45,26 +47,27 @@ -- | Context for responding to a user request. data UpdateCtx = UpdateCtx { options :: DaemonOptions - , refactorings :: [RefactoringChoice IdDom] + , refactorings :: [RefactoringChoice] , 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 -> [RefactoringChoice IdDom] -> (ResponseMsg -> IO ()) -> ClientMessage +updateClient :: DaemonOptions -> MVar [Marker] -> [RefactoringChoice] -> (ResponseMsg -> IO ()) -> ClientMessage -> DaemonSession Bool -updateClient options refactors resp = updateClient' (UpdateCtx options refactors resp) +updateClient options warnMVar refactors resp = updateClient' (UpdateCtx options refactors resp warnMVar) updateClient' :: UpdateCtx -> ClientMessage -> DaemonSession Bool -- resets the internal state of Haskell-tools (but keeps options) updateClient' UpdateCtx{..} Reset = do roots <- gets (^? refSessMCs & traversal & mcRoot) modify' $ resetSession - Session sess <- liftIO $ initGhcSession (generateCode (sharedOptions options)) + Session sess <- liftIO $ reinitGhcSession warnMVar (generateCode (sharedOptions options)) env <- liftIO $ readIORef sess liftIO $ unload env [] -- clear (unload everything) the global state of the linker lift $ setSession env - addPackages response roots + addPackages response warnMVar roots return True updateClient' UpdateCtx{..} (Handshake _) @@ -87,7 +90,7 @@ return True updateClient' UpdateCtx{..} (AddPackages packagePathes) - = do addPackages response packagePathes + = do addPackages response warnMVar packagePathes return True updateClient' _ (SetWorkingDir fp) @@ -123,13 +126,13 @@ lastUndo:_ -> do modify (undoStack .- tail) liftIO $ mapM_ performUndo lastUndo - reloadModules response (getUndoAdded lastUndo) - (getUndoChanged lastUndo) - (getUndoRemoved lastUndo) -- reload the reverted files + reloadModules response warnMVar (getUndoAdded lastUndo) + (getUndoChanged lastUndo) + (getUndoRemoved lastUndo) -- reload the reverted files return True updateClient' UpdateCtx{..} (ReLoad added changed removed) - = do updateForFileChanges response added changed removed + = do updateForFileChanges response warnMVar added changed removed return True updateClient' _ Stop @@ -155,7 +158,8 @@ if not isWatching && not shutdown && not diffMode -- if watch is on, then it will automatically -- reload changed files, otherwise we do it manually - then void $ reloadChanges (map ((^. sfkFileName) . (^. _1)) (rights changedMods)) + then do reloadChanges (map ((^. sfkFileName) . (^. _1)) (rights changedMods)) + reportWarnings response warnMVar else modify (touchedFiles .= Set.fromList (map ((^. sfkFileName) . (^. _1)) (rights changedMods))) applyChanges changes = do @@ -215,9 +219,9 @@ liftIO $ evaluate $ force us return () -addPackages :: (ResponseMsg -> IO ()) -> [FilePath] -> DaemonSession () -addPackages _ [] = return () -addPackages resp packagePathes = do +addPackages :: (ResponseMsg -> IO ()) -> MVar [Marker] -> [FilePath] -> DaemonSession () +addPackages _ _ [] = return () +addPackages resp warnMVar packagePathes = do roots <- liftIO $ mapM canonicalizePath packagePathes nonExisting <- filterM ((return . not) <=< liftIO . doesDirectoryExist) roots DaemonSessionState {..} <- get @@ -241,10 +245,12 @@ (\ms -> resp (LoadedModule (getModSumOrig ms) (getModSumName ms))) (resp . LoadingModules . map getModSumOrig) (\st fp -> maybe (return []) (fmap maybeToList . detectAutogen fp . fst) (st ^. packageDB)) roots - mapM_ (liftIO . resp . uncurry CompilationProblem . getProblems) errs -- handle source errors here to prevent rollback on the tool state - when (null errs) - $ mapM_ (reloadModule (\_ -> return ())) needToReload -- don't report consequent reloads (not expected) - + -- handle source errors here to prevent rollback on the tool state + let errors = foldl mappend ([],[]) (map getProblems errs) + if null (fst errors) + then do mapM_ (reloadModule (\_ -> return ())) needToReload -- don't report consequent reloads (not expected) + reportWarnings resp warnMVar + else liftIO $ resp $ uncurry CompilationProblem errors else liftIO $ resp $ ErrorMessage $ "Attempted to load two packages with different package DB. " ++ "Stack, cabal-sandbox and normal packages cannot be combined" where isTheAdded roots mc = (mc ^. mcRoot) `elem` roots @@ -268,8 +274,8 @@ else return Nothing -- | Updates the state of the tool after some files have been changed (possibly by another application) -updateForFileChanges :: (ResponseMsg -> IO ()) -> [FilePath] -> [FilePath] -> [FilePath] -> DaemonSession () -updateForFileChanges resp added changed removed = do +updateForFileChanges :: (ResponseMsg -> IO ()) -> MVar [Marker] -> [FilePath] -> [FilePath] -> [FilePath] -> DaemonSession () +updateForFileChanges resp warnMVar added changed removed = do -- clear undo stack if the changes are from another application refactoredFiles <- gets (^. touchedFiles) let changeSet = Set.fromList (added ++ changed ++ removed) @@ -286,15 +292,15 @@ $ added ++ changed ++ removed reloadedPackages = tryLoadAgain ++ changedPackages packageNotReloaded fp = not $ any (`isPrefixOf` fp) reloadedPackages - addPackages resp reloadedPackages -- reload packages if needed + addPackages resp warnMVar reloadedPackages -- reload packages if needed -- reload the rest of the modules - reloadModules resp (filter packageNotReloaded added) (filter packageNotReloaded changed) - (filter packageNotReloaded removed) + reloadModules resp warnMVar (filter packageNotReloaded added) (filter packageNotReloaded changed) + (filter packageNotReloaded removed) -- | Reloads changed modules to have an up-to-date version loaded -reloadModules :: (ResponseMsg -> IO ()) -> [FilePath] -> [FilePath] -> [FilePath] -> DaemonSession () -reloadModules _ [] [] [] = return () -reloadModules resp added changed removed = do +reloadModules :: (ResponseMsg -> IO ()) -> MVar [Marker] -> [FilePath] -> [FilePath] -> [FilePath] -> DaemonSession () +reloadModules _ _ [] [] [] = return () +reloadModules resp warnMVar added changed removed = do lift $ forM_ removed (\src -> removeTarget (TargetFile src Nothing)) -- remove targets deleted modify' $ refSessMCs & traversal & mcModules @@ -305,10 +311,16 @@ reloadChangedModules (\ms -> resp (LoadedModule (getModSumOrig ms) (getModSumName ms))) (\mss -> resp (LoadingModules (map getModSumOrig mss))) (\ms -> getModSumOrig ms `elem` changed) + reportWarnings resp warnMVar mcs <- gets (^. refSessMCs) let mcsToReload = filter (\mc -> any ((mc ^. mcRoot) `isPrefixOf`) added && isNothing (moduleCollectionPkgId (mc ^. mcId))) mcs - addPackages resp (map (^. mcRoot) mcsToReload) -- reload packages containing added modules + addPackages resp warnMVar (map (^. mcRoot) mcsToReload) -- reload packages containing added modules +reportWarnings :: (ResponseMsg -> IO ()) -> MVar [Marker] -> DaemonSession () +reportWarnings resp warnMVar = liftIO $ do + warns <- modifyMVar warnMVar (return . ([],)) + when (not (null warns)) $ (resp $ CompilationProblem warns []) + -- | Creates a compressed set of changes in one file createUndo :: Eq a => Int -> [Diff [a]] -> [(Int, Int, [a])] createUndo i (Both str _ : rest) = createUndo (i + length str) rest @@ -361,8 +373,25 @@ getUndoRemoved = catMaybes . map (\case RemoveAdded fp -> Just fp _ -> Nothing) -initGhcSession :: Bool -> IO Session -initGhcSession genCode = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags' genCode >> getSession)) +initGhcSession :: Bool -> IO (Session, MVar [Marker]) +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 + +setupLogging :: MVar [Marker] -> Ghc () +setupLogging mv = modifySession $ \s -> s { hsc_dflags = (hsc_dflags s) { log_action = logger } } + where logger dfs reason sev sp _ msg = modifyMVar_ mv (return . (Marker sp (severity sev reason) (showSDoc dfs msg) :)) + severity SevError _ = Error + severity SevWarning (Reason Opt_WarnDeferredTypeErrors) = Error + severity SevWarning (Reason Opt_WarnDeferredOutOfScopeVariables) = Error + severity SevWarning _ = HT.Warning + severity _ _ = Info usePackageDB :: GhcMonad m => [FilePath] -> m () usePackageDB [] = return ()
Language/Haskell/Tools/Daemon/Watch.hs view
@@ -18,15 +18,15 @@ import System.IO (IO, FilePath) import Language.Haskell.Tools.Daemon.ErrorHandling (userExceptionHandlers, exceptionHandlers) -import Language.Haskell.Tools.Daemon.Protocol (ResponseMsg(..)) +import Language.Haskell.Tools.Daemon.Protocol import Language.Haskell.Tools.Daemon.State (DaemonSessionState) import Language.Haskell.Tools.Daemon.Update (updateForFileChanges) -- | Starts the watch process and a thread that receives notifications from it. The notification -- thread will invoke updates on the daemon state to re-load files. -createWatchProcess' :: Maybe FilePath -> Session -> MVar DaemonSessionState -> (ResponseMsg -> IO ()) +createWatchProcess' :: Maybe FilePath -> Session -> MVar DaemonSessionState -> MVar [Marker] -> (ResponseMsg -> IO ()) -> IO (Maybe WatchProcess, [ThreadId]) -createWatchProcess' watchExePath ghcSess daemonSess upClient = do +createWatchProcess' watchExePath ghcSess daemonSess warnMVars upClient = do exePath <- case watchExePath of Just exe -> return exe Nothing -> guessExePath process <- createWatchProcess exePath 500 @@ -39,7 +39,7 @@ let changedFiles = catMaybes $ map getModifiedFile changes addedFiles = catMaybes $ map getAddedFile changes removedFiles = catMaybes $ map getRemovedFile changes - reloadAction = updateForFileChanges upClient addedFiles changedFiles removedFiles + reloadAction = updateForFileChanges upClient warnMVars addedFiles changedFiles removedFiles handlers = userExceptionHandlers (upClient . ErrorMessage) (\err hint -> upClient (CompilationProblem err hint))
+ examples/Project/warning/Demo.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_GHC -fwarn-unused-matches #-} +module A where + +f a = ()
haskell-tools-daemon.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-daemon -version: 1.0.0.1 +version: 1.0.0.2 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 @@ -83,6 +83,7 @@ , examples/Project/th-typecheck/*.hs , examples/Project/code-gen/*.hs , examples/Project/code-gen/*.cabal + , examples/Project/warning/*.hs library build-depends: base >= 4.9 && < 5.0 @@ -148,8 +149,8 @@ build-depends: base >= 4.10 && < 4.11 , HUnit >= 1.5 && < 1.7 , ghc >= 8.2 && < 8.3 - , tasty >= 0.11 && < 0.12 - , tasty-hunit >= 0.9 && < 0.10 + , tasty >= 0.11 && < 0.13 + , tasty-hunit >= 0.9 && < 0.11 , directory >= 1.2 && < 1.4 , process >= 1.6 && < 1.7 , filepath >= 1.4 && < 2.0
test/Main.hs view
@@ -27,7 +27,7 @@ import Language.Haskell.Tools.Daemon (runDaemon') import Language.Haskell.Tools.Daemon.Options as Options (SharedDaemonOptions(..), DaemonOptions(..)) import Language.Haskell.Tools.Daemon.PackageDB (PackageDB(..)) -import Language.Haskell.Tools.Daemon.Protocol (UndoRefactor(..), ResponseMsg(..), ClientMessage(..)) +import Language.Haskell.Tools.Daemon.Protocol import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) pORT_NUM_START = 4100 @@ -184,7 +184,7 @@ , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) , ( "source-error" , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "source-error"] ] - , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules{}, LoadedModule{}, CompilationProblem {}] -> True; _ -> False) , ( "reload-error" , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "empty"] , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\nimport No.Such.Module" @@ -196,7 +196,10 @@ , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\naa = 3 + ()" , Right $ ReLoad [] [testRoot </> "empty" </> "A.hs"] [] , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"] - , \case [LoadingModules {}, LoadedModule {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules {}, LoadedModule {}, LoadingModules {}, LoadedModule{}, CompilationProblem {}] -> True; _ -> False) + , ( "warning" + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "warning"] ] + , \case [LoadingModules{}, LoadedModule {}, CompilationProblem [Marker _ Warning _] []] -> True; _ -> False) , ( "no-such-file" , [ Right $ SetPackageDB DefaultDB , Right $ PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] False False] @@ -278,6 +281,13 @@ -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" && aaPath == testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" _ -> False ) + , ( "refactor-type-error", testRoot </> "source-error" + , [ AddPackages [testRoot </> "source-error"] + , PerformRefactoring "RenameDefinition" (testRoot </> "source-error" ++ testSuffix </> "A.hs") "3:1-3:2" ["aa"] False False + ] + , \case [ LoadingModules{}, LoadedModule{}, CompilationProblem {} + , LoadingModules{}, LoadedModule{}, CompilationProblem {} + ] -> True; _ -> False) ] reloadingTests :: FilePath -> [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool)] @@ -701,6 +711,8 @@ deriving instance Eq ResponseMsg instance FromJSON UndoRefactor instance FromJSON ResponseMsg +instance FromJSON Marker +instance FromJSON Severity instance ToJSON ClientMessage instance ToJSON PackageDB