Hello community, here is the log from the commit of package ghc-haskell-tools-daemon for openSUSE:Factory checked in at 2017-08-31 20:55:58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-daemon (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-daemon.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-daemon" Thu Aug 31 20:55:58 2017 rev:2 rq:513371 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-daemon/ghc-haskell-tools-daemon.changes 2017-04-12 18:06:44.546333345 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-daemon.new/ghc-haskell-tools-daemon.changes 2017-08-31 20:55:58.975467845 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:15 UTC 2017 - psimons@suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-daemon-0.5.0.0.tar.gz New: ---- haskell-tools-daemon-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-daemon.spec ++++++ --- /var/tmp/diff_new_pack.hgiBmJ/_old 2017-08-31 20:56:00.067314437 +0200 +++ /var/tmp/diff_new_pack.hgiBmJ/_new 2017-08-31 20:56:00.083312189 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-daemon %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Background process for Haskell-tools refactor that editors can connect to License: BSD-3-Clause @@ -28,6 +28,7 @@ Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: chrpath BuildRequires: ghc-Cabal-devel +BuildRequires: ghc-Diff-devel BuildRequires: ghc-aeson-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-containers-devel @@ -44,6 +45,7 @@ BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-split-devel +BuildRequires: ghc-strict-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %if %{with tests} BuildRequires: ghc-HUnit-devel ++++++ haskell-tools-daemon-0.5.0.0.tar.gz -> haskell-tools-daemon-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs --- old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/PackageDB.hs 2017-05-03 22:13:55.000000000 +0200 @@ -1,11 +1,13 @@ {-# LANGUAGE DeriveGeneric #-} module Language.Haskell.Tools.Refactor.Daemon.PackageDB where +import Control.Applicative (Applicative(..), (<$>), Alternative(..)) +import Control.Monad import Data.Aeson (FromJSON(..)) import Data.Char (isSpace) import Data.List import GHC.Generics (Generic(..)) -import System.Directory (withCurrentDirectory, doesFileExist, doesDirectoryExist) +import System.Directory import System.FilePath (FilePath, (</>)) import System.Process (readProcessWithExitCode) @@ -18,9 +20,6 @@ instance FromJSON PackageDB -packageDBLocs :: PackageDB -> [FilePath] -> IO [FilePath] -packageDBLocs pack = fmap concat . mapM (packageDBLoc pack) - packageDBLoc :: PackageDB -> FilePath -> IO [FilePath] packageDBLoc AutoDB path = (++) <$> packageDBLoc StackDB path <*> packageDBLoc CabalSandboxDB path packageDBLoc DefaultDB _ = return [] @@ -32,14 +31,43 @@ else return "" return $ map (drop (length "package-db: ")) $ filter ("package-db: " `isPrefixOf`) $ lines config packageDBLoc StackDB path = withCurrentDirectory path $ do - (_, snapshotDB, snapshotDBErrs) <- readProcessWithExitCode "stack" ["path", "--snapshot-pkg-db"] "" - (_, localDB, localDBErrs) <- readProcessWithExitCode "stack" ["path", "--local-pkg-db"] "" + (_, snapshotDB, snapshotDBErrs) <- readProcessWithExitCode "stack" ["path", "--allow-different-user", "--snapshot-pkg-db"] "" + (_, localDB, localDBErrs) <- readProcessWithExitCode "stack" ["path", "--allow-different-user", "--local-pkg-db"] "" return $ [trim localDB | null localDBErrs] ++ [trim snapshotDB | null snapshotDBErrs] packageDBLoc (ExplicitDB dir) path = do hasDir <- doesDirectoryExist (path </> dir) if hasDir then return [path </> dir] else return [] +-- | Gets the (probable) location of autogen folder depending on which type of +-- build we are using. +detectAutogen :: FilePath -> PackageDB -> IO (Maybe FilePath) +detectAutogen root AutoDB = do + defDB <- detectAutogen root DefaultDB + sandboxDB <- detectAutogen root CabalSandboxDB + stackDB <- detectAutogen root StackDB + return $ choose [ defDB, sandboxDB, stackDB ] +detectAutogen root DefaultDB = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root (ExplicitDB _) = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root CabalSandboxDB = ifExists (root </> "dist" </> "build" </> "autogen") +detectAutogen root StackDB = do + distExists <- doesDirectoryExist (root </> ".stack-work" </> "dist") + existing <- if distExists then (do + contents <- listDirectory (root </> ".stack-work" </> "dist") + let dirs = map ((root </> ".stack-work" </> "dist") </>) contents + subDirs <- mapM (\d -> map (d </>) <$> listDirectory d) dirs + mapM (ifExists . (</> "build" </> "autogen")) (dirs ++ concat subDirs)) else return [] + return (choose existing) + + trim :: String -> String trim = f . f - where f = reverse . dropWhile isSpace \ No newline at end of file + where f = reverse . dropWhile isSpace + +choose :: Alternative f => [f a] -> f a +choose = foldl (<|>) empty + +ifExists :: FilePath -> IO (Maybe FilePath) +ifExists fp = do exists <- doesDirectoryExist fp + if exists then return (Just fp) + else return Nothing diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs --- old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon/State.hs 2017-06-07 10:55:20.000000000 +0200 @@ -4,12 +4,14 @@ import Control.Reference import Language.Haskell.Tools.Refactor.Daemon.PackageDB +import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Session -data DaemonSessionState +data DaemonSessionState = DaemonSessionState { _refactorSession :: RefactorSessionState , _packageDB :: PackageDB , _packageDBSet :: Bool + , _packageDBLocs :: [FilePath] , _exiting :: Bool } @@ -17,4 +19,4 @@ instance IsRefactSessionState DaemonSessionState where refSessMCs = refactorSession & refSessMCs - initSession = DaemonSessionState initSession AutoDB False False \ No newline at end of file + initSession = DaemonSessionState initSession AutoDB False [] False diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon.hs new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon.hs --- old/haskell-tools-daemon-0.5.0.0/Language/Haskell/Tools/Refactor/Daemon.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/Language/Haskell/Tools/Refactor/Daemon.hs 2017-06-17 11:26:16.000000000 +0200 @@ -1,9 +1,11 @@ {-# LANGUAGE ScopedTypeVariables - , OverloadedStrings + , OverloadedStrings , DeriveGeneric , LambdaCase , TemplateHaskell , FlexibleContexts + , MultiWayIf + , TypeApplications #-} module Language.Haskell.Tools.Refactor.Daemon where @@ -11,13 +13,16 @@ import Control.Concurrent.MVar import Control.Exception import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Control.Reference import qualified Data.Aeson as A ((.=)) import Data.Aeson hiding ((.=)) +import Data.Algorithm.Diff +import qualified Data.ByteString.Char8 as StrictBS import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (unpack) import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Either import Data.IORef import Data.List hiding (insert) import qualified Data.Map as Map @@ -29,6 +34,8 @@ import System.Directory import System.Environment import System.IO +import System.IO.Strict as StrictIO (hGetContents) +import Data.Version import Bag import DynFlags @@ -50,10 +57,7 @@ import Language.Haskell.Tools.Refactor.Prepare import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Session - -import Debug.Trace - --- TODO: handle boot files +import Paths_haskell_tools_daemon runDaemonCLI :: IO () runDaemonCLI = getArgs >>= runDaemon @@ -62,15 +66,14 @@ runDaemon args = withSocketsDo $ do let finalArgs = args ++ drop (length args) defaultArgs isSilent = read (finalArgs !! 1) + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering when (not isSilent) $ putStrLn $ "Starting Haskell Tools daemon" - addrinfos <- getAddrInfo - (Just (defaultHints {addrFlags = [AI_PASSIVE]})) - Nothing (Just (finalArgs !! 0)) - let serveraddr = head addrinfos - sock <- socket (addrFamily serveraddr) Stream defaultProtocol + sock <- socket AF_INET Stream 0 setSocketOption sock ReuseAddr 1 - bind sock (addrAddress serveraddr) - listen sock 1 + when (not isSilent) $ putStrLn $ "Listening on port " ++ finalArgs !! 0 + bind sock (SockAddrInet (read (finalArgs !! 0)) iNADDR_ANY) + listen sock 4 clientLoop isSilent sock defaultArgs :: [String] @@ -115,58 +118,41 @@ -- | This function does the real job of acting upon client messages in a stateful environment of a client updateClient :: (ResponseMsg -> IO ()) -> ClientMessage -> StateT DaemonSessionState Ghc Bool +updateClient resp (Handshake _) = liftIO (resp $ HandshakeResponse $ versionBranch version) >> return True updateClient resp KeepAlive = liftIO (resp KeepAliveResponse) >> return True updateClient resp Disconnect = liftIO (resp Disconnected) >> return False -updateClient _ (SetPackageDB pkgDB) = modify (packageDB .= pkgDB) >> return True +updateClient _ (SetPackageDB pkgDB) = modify (packageDB .= pkgDB) >> return True updateClient resp (AddPackages packagePathes) = do - existingMCs <- gets (^. refSessMCs) - let existing = map ms_mod $ (existingMCs ^? traversal & filtered isTheAdded & mcModules & traversal & modRecMS) - needToReload <- (filter (\ms -> not $ ms_mod ms `elem` existing)) - <$> getReachableModules (\ms -> ms_mod ms `elem` existing) - modify $ refSessMCs .- filter (not . isTheAdded) -- remove the added package from the database - forM_ existing $ \mn -> removeTarget (TargetModule (GHC.moduleName mn)) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) }) - initializePackageDBIfNeeded - res <- loadPackagesFrom (return . getModSumOrig) packagePathes - case res of - Right (modules, ignoredMods) -> do - mapM_ (reloadModule (\_ -> return ())) needToReload -- don't report consequent reloads (not expected) - liftIO $ resp - $ if not (null ignoredMods) - then ErrorMessage - $ "The following modules are ignored: " - ++ concat (intersperse ", " ignoredMods) - ++ ". Multiple modules with the same qualified name are not supported." - else LoadedModules modules - Left err -> liftIO $ resp $ either ErrorMessage CompilationProblem (getProblems err) + addPackages resp packagePathes return True - where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes - initializePackageDBIfNeeded = do - pkgDBAlreadySet <- gets (^. packageDBSet) - when (not pkgDBAlreadySet) $ do - pkgDB <- gets (^. packageDB) - pkgDBLocs <- liftIO $ packageDBLocs pkgDB packagePathes - usePackageDB pkgDBLocs - modify (packageDBSet .= True) - updateClient _ (RemovePackages packagePathes) = do mcs <- gets (^. refSessMCs) - let existing = map ms_mod (mcs ^? traversal & filtered isRemoved & mcModules & traversal & modRecMS) - lift $ forM_ existing (\modName -> removeTarget (TargetModule (GHC.moduleName modName))) + let existingFiles = concatMap @[] (map (^. sfkFileName) . Map.keys) (mcs ^? traversal & filtered isRemoved & mcModules) + lift $ forM_ existingFiles (\fs -> removeTarget (TargetFile fs Nothing)) lift $ deregisterDirs (mcs ^? traversal & filtered isRemoved & mcSourceDirs & traversal) modify $ refSessMCs .- filter (not . isRemoved) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) }) + modifySession (\s -> s { hsc_mod_graph = filter ((`notElem` existingFiles) . getModSumOrig) (hsc_mod_graph s) }) + mcs <- gets (^. refSessMCs) + when (null mcs) $ modify (packageDBSet .= False) return True where isRemoved mc = (mc ^. mcRoot) `elem` packagePathes -updateClient resp (ReLoad changed removed) = - do removedMods <- gets (map ms_mod . filter ((`elem` removed) . getModSumOrig) . (^? refSessMCs & traversal & mcModules & traversal & modRecMS)) - lift $ forM_ removedMods (\modName -> removeTarget (TargetModule (GHC.moduleName modName))) - modify $ refSessMCs & traversal & mcModules - .- Map.filter (\m -> maybe True (not . (`elem` removed) . getModSumOrig) (m ^? modRecMS)) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` removedMods) . ms_mod) (hsc_mod_graph s) }) - reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms])) +updateClient resp (ReLoad added changed removed) = + -- TODO: check for changed cabal files and reload their packages + do mcs <- gets (^. refSessMCs) + lift $ forM_ removed (\src -> removeTarget (TargetFile src Nothing)) + -- remove targets deleted + modify $ refSessMCs & traversal & mcModules + .- Map.filter (\m -> maybe True ((`notElem` removed) . getModSumOrig) (m ^? modRecMS)) + modifySession (\s -> s { hsc_mod_graph = filter (\mod -> getModSumOrig mod `notElem` removed) (hsc_mod_graph s) }) + -- reload changed modules + -- TODO: filter those that are in reloaded packages + reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)])) + (\mss -> resp (LoadingModules (map getModSumOrig mss))) (\ms -> getModSumOrig ms `elem` changed) + 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 liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage CompilationProblem (getProblems errs)) Right _ -> return () return True @@ -174,51 +160,135 @@ updateClient _ Stop = modify (exiting .= True) >> return False updateClient resp (PerformRefactoring refact modPath selection args) = do - (Just actualMod, otherMods) <- getFileMods modPath - let cmd = analyzeCommand refact (selection:args) - res <- lift $ performCommand cmd actualMod otherMods - case res of - Left err -> liftIO $ resp $ ErrorMessage err - Right diff -> do changedMods <- catMaybes <$> applyChanges diff - liftIO $ resp $ ModulesChanged (map snd changedMods) - -- when a new module is added, we need to compile it with the correct package db - void $ reloadChanges (map ((^. sfkModuleName) . fst) changedMods) + (selectedMod, otherMods) <- getFileMods modPath + case selectedMod of + Just actualMod -> do + case analyzeCommand refact (selection:args) of + Right cmd -> do res <- lift $ performCommand cmd actualMod otherMods + case res of + Left err -> liftIO $ resp $ ErrorMessage err + Right diff -> do changedMods <- applyChanges diff + liftIO $ resp $ ModulesChanged (map (either id (\(_,_,ch) -> ch)) changedMods) + void $ reloadChanges (map ((^. sfkModuleName) . (\(key,_,_) -> key)) (rights changedMods)) + Left err -> liftIO $ resp $ ErrorMessage err + Nothing -> liftIO $ resp $ ErrorMessage $ "The following file is not loaded to Haskell-tools: " + ++ modPath ++ ". Please add the containing package." return True - where applyChanges changes = do - forM changes $ \case - ModuleCreated n m otherM -> do + + where applyChanges changes = do + forM changes $ \case + ModuleCreated n m otherM -> do mcs <- gets (^. refSessMCs) Just (_, otherMR) <- gets (lookupModInSCs otherM . (^. refSessMCs)) let Just otherMS = otherMR ^? modRecMS Just mc = lookupModuleColl (otherM ^. sfkModuleName) mcs - modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcId) == (mc ^. mcId)) & mcModules - .- Map.insert (SourceFileKey NormalHs n) (ModuleNotLoaded False) otherSrcDir <- liftIO $ getSourceDir otherMS let loc = toFileName otherSrcDir n - liftIO $ withBinaryFile loc WriteMode (`hPutStr` prettyPrint m) - lift $ addTarget (Target (TargetModule (GHC.mkModuleName n)) True Nothing) - return $ Just (SourceFileKey NormalHs n, loc) + modify $ refSessMCs & traversal & filtered (\mc' -> (mc' ^. mcId) == (mc ^. mcId)) & mcModules + .- Map.insert (SourceFileKey loc n) (ModuleNotLoaded False False) + liftIO $ withBinaryFile loc WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle (prettyPrint m) + lift $ addTarget (Target (TargetFile loc Nothing) True Nothing) + return $ Right (SourceFileKey loc n, loc, RemoveAdded loc) ContentChanged (n,m) -> do - Just (_, mr) <- gets (lookupModInSCs n . (^. refSessMCs)) - let Just ms = mr ^? modRecMS - liftIO $ withBinaryFile (getModSumOrig ms) WriteMode (`hPutStr` prettyPrint m) - return $ Just (n, getModSumOrig ms) + let newCont = prettyPrint m + file = n ^. sfkFileName + origCont <- liftIO $ withBinaryFile file ReadMode $ \handle -> do + hSetEncoding handle utf8 + StrictIO.hGetContents handle + let undo = createUndo 0 $ getGroupedDiff origCont newCont + origCont <- liftIO $ withBinaryFile file WriteMode $ \handle -> do + hSetEncoding handle utf8 + hPutStr handle newCont + return $ Right (n, file, UndoChanges file undo) ModuleRemoved mod -> do - Just (_,m) <- gets (lookupModInSCs (SourceFileKey NormalHs mod) . (^. refSessMCs)) + Just (_,m) <- gets (lookupModuleInSCs mod . (^. refSessMCs)) let modName = GHC.moduleName $ fromJust $ fmap semanticsModule (m ^? typedRecModule) <|> fmap semanticsModule (m ^? renamedRecModule) ms <- getModSummary modName - lift $ removeTarget (TargetModule modName) + let file = getModSumOrig ms + origCont <- liftIO (StrictBS.unpack <$> StrictBS.readFile file) + lift $ removeTarget (TargetFile file Nothing) modify $ (refSessMCs .- removeModule mod) - liftIO $ removeFile (getModSumOrig ms) - return Nothing - - reloadChanges changedMods - = do reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [getModSumOrig ms])) + liftIO $ removeFile file + return $ Left $ RestoreRemoved file origCont + + reloadChanges changedMods + = do reloadRes <- reloadChangedModules (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)])) + (\mss -> resp (LoadingModules (map getModSumOrig mss))) (\ms -> modSumName ms `elem` changedMods) liftIO $ case reloadRes of Left errs -> resp (either ErrorMessage (ErrorMessage . ("The result of the refactoring contains errors: " ++) . show) (getProblems errs)) Right _ -> return () +addPackages :: (ResponseMsg -> IO ()) -> [FilePath] -> StateT DaemonSessionState Ghc () +addPackages resp [] = return () +addPackages resp packagePathes = do + nonExisting <- filterM ((return . not) <=< liftIO . doesDirectoryExist) packagePathes + if (not (null nonExisting)) + then liftIO $ resp $ ErrorMessage $ "The following packages are not found: " ++ concat (intersperse ", " nonExisting) + else do + -- clear existing removed packages + existingMCs <- gets (^. refSessMCs) + let existing = (existingMCs ^? traversal & filtered isTheAdded & mcModules & traversal & modRecMS) + existingModNames = map ms_mod existing + needToReload <- handleErrors $ (filter (\ms -> not $ ms_mod ms `elem` existingModNames)) + <$> getReachableModules (\_ -> return ()) (\ms -> ms_mod ms `elem` existingModNames) + modify $ refSessMCs .- filter (not . isTheAdded) -- remove the added package from the database + forM_ existing $ \ms -> removeTarget (TargetFile (getModSumOrig ms) Nothing) + modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existingModNames) . ms_mod) (hsc_mod_graph s) }) + -- load new modules + pkgDBok <- initializePackageDBIfNeeded + if pkgDBok then do + res <- loadPackagesFrom (\ms -> resp (LoadedModules [(getModSumOrig ms, getModSumName ms)]) >> return (getModSumOrig ms)) + (resp . LoadingModules . map getModSumOrig) (\st fp -> maybeToList <$> detectAutogen fp (st ^. packageDB)) packagePathes + case res of + Right modules -> do + mapM_ (reloadModule (\_ -> return ())) (either (const []) id needToReload) -- don't report consequent reloads (not expected) + Left err -> liftIO $ resp $ either ErrorMessage CompilationProblem (getProblems err) + else liftIO $ resp $ ErrorMessage $ "Attempted to load two packages with different package DB. " + ++ "Stack, cabal-sandbox and normal packages cannot be combined" + where isTheAdded mc = (mc ^. mcRoot) `elem` packagePathes + initializePackageDBIfNeeded = do + pkgDBAlreadySet <- gets (^. packageDBSet) + pkgDB <- gets (^. packageDB) + locs <- liftIO $ mapM (packageDBLoc pkgDB) packagePathes + case locs of + firstLoc:rest -> + if | not (all (== firstLoc) rest) + -> return False + | pkgDBAlreadySet -> do + pkgDBLocs <- gets (^. packageDBLocs) + return (pkgDBLocs == firstLoc) + | otherwise -> do + usePackageDB firstLoc + modify ((packageDBSet .= True) . (packageDBLocs .= firstLoc)) + return True + [] -> return True + + +data UndoRefactor = RemoveAdded { undoRemovePath :: FilePath } + | RestoreRemoved { undoRestorePath :: FilePath + , undoRestoreContents :: String + } + | UndoChanges { undoChangedPath :: FilePath + , undoDiff :: FileDiff + } + deriving (Show, Generic) + +instance ToJSON UndoRefactor + +type FileDiff = [(Int, Int, String)] + +createUndo :: Eq a => Int -> [Diff [a]] -> [(Int, Int, [a])] +createUndo i (Both str _ : rest) = createUndo (i + length str) rest +createUndo i (First rem : Second add : rest) + = (i, i + length add, rem) : createUndo (i + length add) rest +createUndo i (First rem : rest) = (i, i, rem) : createUndo i rest +createUndo i (Second add : rest) + = (i, i + length add, []) : createUndo (i + length add) rest +createUndo _ [] = [] + initGhcSession :: IO Session initGhcSession = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlags >> getSession)) @@ -226,9 +296,9 @@ usePackageDB [] = return () usePackageDB pkgDbLocs = do dfs <- getSessionDynFlags - dfs' <- liftIO $ fmap fst $ initPackages + dfs' <- liftIO $ fmap fst $ initPackages $ dfs { extraPkgConfs = (map PkgConfFile pkgDbLocs ++) . extraPkgConfs dfs - , pkgDatabase = Nothing + , pkgDatabase = Nothing } void $ setSessionDynFlags dfs' @@ -238,6 +308,7 @@ data ClientMessage = KeepAlive + | Handshake { clientVersion :: [Int] } | SetPackageDB { pkgDB :: PackageDB } | AddPackages { addedPathes :: [FilePath] } | RemovePackages { removedPathes :: [FilePath] } @@ -248,19 +319,22 @@ } | Stop | Disconnect - | ReLoad { changedModules :: [FilePath] + | ReLoad { addedModules :: [FilePath] + , changedModules :: [FilePath] , removedModules :: [FilePath] } deriving (Show, Generic) -instance FromJSON ClientMessage +instance FromJSON ClientMessage data ResponseMsg = KeepAliveResponse + | HandshakeResponse { serverVersion :: [Int] } | ErrorMessage { errorMsg :: String } | CompilationProblem { errorMarkers :: [(SrcSpan, String)] } - | ModulesChanged { moduleChanges :: [FilePath] } - | LoadedModules { loadedModules :: [FilePath] } + | ModulesChanged { undoChanges :: [UndoRefactor] } + | LoadedModules { loadedModules :: [(FilePath, String)] } + | LoadingModules { modulesToLoad :: [FilePath] } | Disconnected deriving (Show, Generic) @@ -268,9 +342,9 @@ 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) + , "startRow" A..= srcLocLine (realSrcSpanStart sp) + , "startCol" A..= srcLocCol (realSrcSpanStart sp) + , "endRow" A..= srcLocLine (realSrcSpanEnd sp) , "endCol" A..= srcLocCol (realSrcSpanEnd sp) ] toJSON _ = Null diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/A.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/A.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/A.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/A.hs 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,5 @@ +module A where + +import B + +a = b \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/B.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/B.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/B.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/B.hs 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,3 @@ +module B where + +b = () \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/some-test-package.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/some-test-package.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/additional-files/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/additional-files/some-test-package.cabal 2017-05-03 22:13:55.000000000 +0200 @@ -0,0 +1,19 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 +extra-src-files: B.hs + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/UseGroups.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/UseGroups.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/UseGroups.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/UseGroups.hs 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,7 @@ +module UseGroups where + +import Data.Group +import Data.Monoid + +x :: Sum Int +x = 3 `pow` 5 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,30 @@ +Copyright (c) 2013, Nathan "Taneb" van Doorn + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nathan "Taneb" van Doorn nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal 2017-04-01 13:42:31.000000000 +0200 @@ -0,0 +1,19 @@ +name: groups +version: 0.4.0.0 +synopsis: Haskell 98 groups +description: + Haskell 98 groups. A group is a monoid with invertibility. +license: BSD3 +license-file: LICENSE +author: Nathan "Taneb" van Doorn +maintainer: nvd1234@gmail.com +copyright: Copyright (C) 2013 Nathan van Doorn +category: Algebra, Data, Math +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Data.Group + -- other-modules: + build-depends: base <5 + hs-source-dirs: src diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,92 @@ +module Data.Group where + +import Data.Monoid + +-- |A 'Group' is a 'Monoid' plus a function, 'invert', such that: +-- +-- @a \<> invert a == mempty@ +-- +-- @invert a \<> a == mempty@ +class Monoid m => Group m where + invert :: m -> m + -- |@'pow' a n == a \<> a \<> ... \<> a @ + -- + -- @ (n lots of a) @ + -- + -- If n is negative, the result is inverted. + pow :: Integral x => m -> x -> m + pow x0 n0 = case compare n0 0 of + LT -> invert . f x0 $ negate n0 + EQ -> mempty + GT -> f x0 n0 + where + f x n + | even n = f (x `mappend` x) (n `quot` 2) + | n == 1 = x + | otherwise = g (x `mappend` x) ((n - 1) `quot` 2) x + g x n c + | even n = g (x `mappend` x) (n `quot` 2) c + | n == 1 = x `mappend` c + | otherwise = g (x `mappend` x) ((n - 1) `quot` 2) (x `mappend` c) + +instance Group () where + invert () = () + pow () _ = () + +instance Num a => Group (Sum a) where + invert = Sum . negate . getSum + {-# INLINE invert #-} + pow (Sum a) b = Sum (a * fromIntegral b) + +instance Fractional a => Group (Product a) where + invert = Product . recip . getProduct + {-# INLINE invert #-} + pow (Product a) b = Product (a ^^ b) + +instance Group a => Group (Dual a) where + invert = Dual . invert . getDual + {-# INLINE invert #-} + pow (Dual a) n = Dual (pow a n) + +instance Group b => Group (a -> b) where + invert f = invert . f + pow f n e = pow (f e) n + +instance (Group a, Group b) => Group (a, b) where + invert (a, b) = (invert a, invert b) + pow (a, b) n = (pow a n, pow b n) + +instance (Group a, Group b, Group c) => Group (a, b, c) where + invert (a, b, c) = (invert a, invert b, invert c) + pow (a, b, c) n = (pow a n, pow b n, pow c n) + +instance (Group a, Group b, Group c, Group d) => Group (a, b, c, d) where + invert (a, b, c, d) = (invert a, invert b, invert c, invert d) + pow (a, b, c, d) n = (pow a n, pow b n, pow c n, pow d n) + +instance (Group a, Group b, Group c, Group d, Group e) => Group (a, b, c, d, e) where + invert (a, b, c, d, e) = (invert a, invert b, invert c, invert d, invert e) + pow (a, b, c, d, e) n = (pow a n, pow b n, pow c n, pow d n, pow e n) + +-- |An 'Abelian' group is a 'Group' that follows the rule: +-- +-- @a \<> b == b \<> a@ +class Group g => Abelian g + +instance Abelian () + +instance Num a => Abelian (Sum a) + +instance Fractional a => Abelian (Product a) + +instance Abelian a => Abelian (Dual a) + +instance Abelian b => Abelian (a -> b) + +instance (Abelian a, Abelian b) => Abelian (a, b) + +instance (Abelian a, Abelian b, Abelian c) => Abelian (a, b, c) + +instance (Abelian a, Abelian b, Abelian c, Abelian d) => Abelian (a, b, c, d) + +instance (Abelian a, Abelian b, Abelian c, Abelian d, Abelian e) => Abelian (a, b, c, d, e) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/some-test-package.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/some-test-package.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/cabal-sandbox/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/cabal-sandbox/some-test-package.cabal 2017-04-01 13:42:30.000000000 +0200 @@ -0,0 +1,18 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: UseGroups + build-depends: base + , groups + default-language: Haskell2010 \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package1/package1.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package1/package1.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package1/package1.cabal 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package1/package1.cabal 2017-05-03 22:13:55.000000000 +0200 @@ -1,7 +1,7 @@ name: package1 version: 1.2.3.4 synopsis: A package just for testing Haskell-tools support. Don't install it. -description: +description: homepage: https://github.com/nboldi/haskell-tools license: BSD3 @@ -14,5 +14,5 @@ library exposed-modules: A - build-depends: base + build-depends: base, template-haskell default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package2/package2.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package2/package2.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/th-added-later/package2/package2.cabal 2017-01-08 10:56:21.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/th-added-later/package2/package2.cabal 2017-05-03 22:13:55.000000000 +0200 @@ -1,7 +1,7 @@ name: package2 version: 1.2.3.4 synopsis: A package just for testing Haskell-tools support. Don't install it. -description: +description: homepage: https://github.com/nboldi/haskell-tools license: BSD3 @@ -14,5 +14,5 @@ library exposed-modules: B - build-depends: base, package1 + build-depends: base, package1, template-haskell default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Main.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Main.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Main.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Main.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello World" \ No newline at end of file diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Unused.hs new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Unused.hs --- old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/Unused.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/Unused.hs 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1 @@ +Not a valid haskell program diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/some-test-package.cabal new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/some-test-package.cabal --- old/haskell-tools-daemon-0.5.0.0/examples/Project/unused-mod/some-test-package.cabal 1970-01-01 01:00:00.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/examples/Project/unused-mod/some-test-package.cabal 2017-06-07 10:55:20.000000000 +0200 @@ -0,0 +1,19 @@ +name: some-test-package +version: 1.2.3.4 +synopsis: A package just for testing Haskell-tools support. Don't install it. +description: + +homepage: https://github.com/nboldi/haskell-tools +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + other-modules: Unused diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/haskell-tools-daemon.cabal new/haskell-tools-daemon-0.8.0.0/haskell-tools-daemon.cabal --- old/haskell-tools-daemon-0.5.0.0/haskell-tools-daemon.cabal 2017-01-31 20:56:31.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/haskell-tools-daemon.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-daemon -version: 0.5.0.0 +version: 0.8.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 @@ -50,13 +50,24 @@ , examples/Project/load-error/*.hs , examples/Project/source-error/*.hs , examples/Project/empty/*.hs + , examples/Project/additional-files/*.hs + , examples/Project/additional-files/*.cabal + , examples/Project/cabal-sandbox/*.hs + , examples/Project/cabal-sandbox/*.cabal + , examples/Project/cabal-sandbox/groups-0.4.0.0/LICENSE + , examples/Project/cabal-sandbox/groups-0.4.0.0/Setup.hs + , examples/Project/cabal-sandbox/groups-0.4.0.0/groups.cabal + , examples/Project/cabal-sandbox/groups-0.4.0.0/src/Data/Group.hs + , examples/Project/unused-mod/*.hs + , examples/Project/unused-mod/*.cabal + library - ghc-options: -O2 build-depends: base >= 4.9 && < 5.0 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 1.0 , filepath >= 1.4 && < 2.0 + , strict >= 0.3 && < 0.4 , containers >= 0.5 && < 0.6 , mtl >= 2.2 && < 2.3 , split >= 0.2 && < 1.0 @@ -66,30 +77,32 @@ , ghc-paths >= 0.1 && < 0.2 , references >= 0.3.2 && < 1.0 , network >= 2.6 && < 3.0 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 + , Diff >= 0.3 && < 0.4 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 exposed-modules: Language.Haskell.Tools.Refactor.Daemon , Language.Haskell.Tools.Refactor.Daemon.State , Language.Haskell.Tools.Refactor.Daemon.PackageDB + , Paths_haskell_tools_daemon default-language: Haskell2010 executable ht-daemon - ghc-options: -O2 + ghc-options: -rtsopts build-depends: base >= 4.9 && < 5.0 - , haskell-tools-daemon >= 0.5 && < 0.6 + , haskell-tools-daemon >= 0.8 && < 0.9 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 test-suite haskell-tools-daemon-tests type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2.5g -O2 + ghc-options: -with-rtsopts=-M2.5g hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: base >= 4.9 && < 4.10 - , HUnit >= 1.5 && < 1.6 + , HUnit >= 1.5 && < 1.7 , ghc >= 8.0 && < 8.1 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 @@ -98,6 +111,6 @@ , filepath >= 1.4 && < 2.0 , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 - , aeson >= 1.0 && < 1.2 - , haskell-tools-daemon >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , aeson >= 1.0 && < 1.3 + , haskell-tools-daemon >= 0.8 && < 0.9 + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-daemon-0.5.0.0/test/Main.hs new/haskell-tools-daemon-0.8.0.0/test/Main.hs --- old/haskell-tools-daemon-0.5.0.0/test/Main.hs 2017-01-31 20:34:13.000000000 +0100 +++ new/haskell-tools-daemon-0.8.0.0/test/Main.hs 2017-06-07 10:55:20.000000000 +0200 @@ -17,6 +17,7 @@ import Network.Socket.ByteString.Lazy as Sock import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.List as List +import Data.List (sort) import Data.Aeson import Data.Maybe import System.IO @@ -32,37 +33,38 @@ main :: IO () main = do unsetEnv "GHC_PACKAGE_PATH" - portCounter <- newMVar pORT_NUM_START + portCounter <- newMVar pORT_NUM_START tr <- canonicalizePath testRoot - isStackRun <- isJust <$> lookupEnv "STACK_EXE" - defaultMain (allTests isStackRun tr portCounter) + hasStack <- isJust <$> findExecutable "stack" + hasCabal <- isJust <$> findExecutable "cabal" + defaultMain (allTests (hasStack && hasCabal) tr portCounter) allTests :: Bool -> FilePath -> MVar Int -> TestTree allTests isSource testRoot portCounter - = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) - $ testGroup "daemon-tests" - [ testGroup "simple-tests" - $ map (makeDaemonTest portCounter . (\(label, input, output) -> (Nothing, label, input, output))) simpleTests - , testGroup "loading-tests" - $ map (makeDaemonTest portCounter . (\(label, input, output) -> (Nothing, label, input, output))) loadingTests - , testGroup "refactor-tests" - $ map (makeDaemonTest portCounter . (\(label, dir, input, output) -> (Just (testRoot </> dir), label, input, output))) (refactorTests testRoot) - , testGroup "reload-tests" + = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 20)) + $ testGroup "daemon-tests" + [ testGroup "simple-tests" + $ map (makeDaemonTest portCounter) simpleTests + , testGroup "loading-tests" + $ map (makeDaemonTest portCounter) loadingTests + , testGroup "refactor-tests" + $ map (makeRefactorTest portCounter) (refactorTests testRoot) + , testGroup "reload-tests" $ map (makeReloadTest portCounter) reloadingTests - , testGroup "compilation-problem-tests" + , testGroup "compilation-problem-tests" $ map (makeCompProblemTest portCounter) compProblemTests -- if not a stack build, we cannot guarantee that stack is on the path , if isSource then testGroup "pkg-db-tests" $ map (makePkgDbTest portCounter) pkgDbTests else testCase "IGNORED pkg-db-tests" (return ()) -- cannot execute this when the source is not present - , if isSource then selfLoadingTest portCounter else testCase "IGNORED self-load" (return ()) + -- , if isSource then selfLoadingTest portCounter else testCase "IGNORED self-load" (return ()) ] testSuffix = "_test" simpleTests :: [(String, [ClientMessage], [ResponseMsg])] -simpleTests = +simpleTests = [ ( "empty-test", [], [] ) , ( "keep-alive", [KeepAlive], [KeepAliveResponse] ) ] @@ -71,199 +73,207 @@ loadingTests = [ ( "load-package" , [AddPackages [testRoot </> "has-cabal"]] - , [LoadedModules [testRoot </> "has-cabal" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "has-cabal" </> "A.hs"] + , LoadedModules [(testRoot </> "has-cabal" </> "A.hs", "A")]] ) , ( "no-cabal" , [AddPackages [testRoot </> "no-cabal"]] - , [LoadedModules [testRoot </> "no-cabal" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "no-cabal" </> "A.hs"] + , LoadedModules [(testRoot </> "no-cabal" </> "A.hs", "A")]] ) , ( "source-dir" , [AddPackages [testRoot </> "source-dir"]] - , [LoadedModules [testRoot </> "source-dir" </> "src" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "source-dir" </> "src" </> "A.hs"] + , LoadedModules [(testRoot </> "source-dir" </> "src" </> "A.hs", "A")]] ) , ( "source-dir-outside" , [AddPackages [testRoot </> "source-dir-outside"]] - , [LoadedModules [testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs"]] ) + , [ LoadingModules [testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs"] + , LoadedModules [(testRoot </> "source-dir-outside" </> ".." </> "src" </> "A.hs", "A")]] ) , ( "multi-packages" , [ AddPackages [ testRoot </> "multi-packages" </> "package1" , testRoot </> "multi-packages" </> "package2" ]] - , [ LoadedModules [ testRoot </> "multi-packages" </> "package2" </> "B.hs" - , testRoot </> "multi-packages" </> "package1" </> "A.hs"]] ) + , [ LoadingModules [ testRoot </> "multi-packages" </> "package2" </> "B.hs" + , testRoot </> "multi-packages" </> "package1" </> "A.hs" ] + , LoadedModules [ (testRoot </> "multi-packages" </> "package2" </> "B.hs", "B") ] + , LoadedModules [ (testRoot </> "multi-packages" </> "package1" </> "A.hs", "A") ] ] ) , ( "multi-packages-flags" , [ AddPackages [ testRoot </> "multi-packages-flags" </> "package1" , testRoot </> "multi-packages-flags" </> "package2" ]] - , [ LoadedModules [ testRoot </> "multi-packages-flags" </> "package2" </> "B.hs" - , testRoot </> "multi-packages-flags" </> "package1" </> "A.hs"]] ) + , [ LoadingModules [ testRoot </> "multi-packages-flags" </> "package2" </> "B.hs" + , testRoot </> "multi-packages-flags" </> "package1" </> "A.hs" ] + , LoadedModules [ (testRoot </> "multi-packages-flags" </> "package2" </> "B.hs", "B") ] + , LoadedModules [ (testRoot </> "multi-packages-flags" </> "package1" </> "A.hs", "A") ] ] ) , ( "multi-packages-dependent" , [ AddPackages [ testRoot </> "multi-packages-dependent" </> "package1" , testRoot </> "multi-packages-dependent" </> "package2" ]] - , [ LoadedModules [ testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs" - , testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs"]] ) + , [ LoadingModules [ testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs" + , testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs" ] + , LoadedModules [ (testRoot </> "multi-packages-dependent" </> "package1" </> "A.hs", "A") ] + , LoadedModules [ (testRoot </> "multi-packages-dependent" </> "package2" </> "B.hs", "B") ] ] ) , ( "has-th" , [AddPackages [testRoot </> "has-th"]] - , [LoadedModules [testRoot </> "has-th" </> "TH.hs", testRoot </> "has-th" </> "A.hs"]] ) + , [ LoadingModules [ testRoot </> "has-th" </> "TH.hs", testRoot </> "has-th" </> "A.hs" ] + , LoadedModules [ (testRoot </> "has-th" </> "TH.hs", "TH") ] + , LoadedModules [ (testRoot </> "has-th" </> "A.hs", "A") ] ] ) , ( "th-added-later" , [ AddPackages [testRoot </> "th-added-later" </> "package1"] , AddPackages [testRoot </> "th-added-later" </> "package2"] ] - , [ LoadedModules [testRoot </> "th-added-later" </> "package1" </> "A.hs"] - , LoadedModules [testRoot </> "th-added-later" </> "package2" </> "B.hs"]] ) + , [ LoadingModules [ testRoot </> "th-added-later" </> "package1" </> "A.hs" ] + , LoadedModules [(testRoot </> "th-added-later" </> "package1" </> "A.hs", "A")] + , LoadingModules [ testRoot </> "th-added-later" </> "package2" </> "B.hs" ] + , LoadedModules [(testRoot </> "th-added-later" </> "package2" </> "B.hs", "B")] ] ) + , ( "unused-module" + , [ AddPackages [testRoot </> "unused-mod"] ] + , [ LoadingModules [ testRoot </> "unused-mod" </> "Main.hs" ] + , LoadedModules [ (testRoot </> "unused-mod" </> "Main.hs", "Main") ] ] ) ] compProblemTests :: [(String, [Either (IO ()) ClientMessage], [ResponseMsg] -> Bool)] -compProblemTests = +compProblemTests = [ ( "load-error" - , [ Right $ AddPackages [testRoot </> "load-error"] ] - , \case [CompilationProblem {}] -> True; _ -> False) + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "load-error"] ] + , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) , ( "source-error" - , [ Right $ AddPackages [testRoot </> "source-error"] ] - , \case [CompilationProblem {}] -> True; _ -> False) + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "source-error"] ] + , \case [LoadingModules{}, CompilationProblem {}] -> True; _ -> False) , ( "reload-error" - , [ Right $ AddPackages [testRoot </> "empty"] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "empty"] , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\nimport No.Such.Module" - , Right $ ReLoad [testRoot </> "empty" </> "A.hs"] [] + , Right $ ReLoad [] [testRoot </> "empty" </> "A.hs"] [] , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"] - , \case [LoadedModules {}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules {}, LoadedModules {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) , ( "reload-source-error" - , [ Right $ AddPackages [testRoot </> "empty"] + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "empty"] , Left $ appendFile (testRoot </> "empty" </> "A.hs") "\n\naa = 3 + ()" - , Right $ ReLoad [testRoot </> "empty" </> "A.hs"] [] + , Right $ ReLoad [] [testRoot </> "empty" </> "A.hs"] [] , Left $ writeFile (testRoot </> "empty" </> "A.hs") "module A where"] - , \case [LoadedModules {}, CompilationProblem {}] -> True; _ -> False) + , \case [LoadingModules {}, LoadedModules {}, LoadingModules {}, CompilationProblem {}] -> True; _ -> False) + , ( "no-such-file" + , [ Right $ PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] ] + , \case [ ErrorMessage _ ] -> True; _ -> False ) + , ( "additional-files" + , [ Right $ SetPackageDB DefaultDB, Right $ AddPackages [testRoot </> "additional-files"] ] + , \case [ LoadingModules {}, ErrorMessage _ ] -> True; _ -> False ) ] sourceRoot = ".." </> ".." </> "src" selfLoadingTest :: MVar Int -> TestTree -selfLoadingTest port = localOption (mkTimeout ({- 5 min -} 1000 * 1000 * 60 * 5)) $ testCase "self-load" $ do +selfLoadingTest port = localOption (mkTimeout ({- 5 min -} 1000 * 1000 * 60 * 5)) $ testCase "self-load" $ do actual <- communicateWithDaemon port - [ Right $ AddPackages (map (sourceRoot </>) ["ast", "backend-ghc", "prettyprint", "rewrite", "refactor", "daemon"]) ] - assertBool ("The expected result is a nonempty response message list that does not contain errors. Actual result: " ++ show actual) + [ Right $ AddPackages (map (sourceRoot </>) ["ast", "backend-ghc", "prettyprint", "rewrite", "refactor"]) ] + assertBool ("The expected result is a nonempty response message list that does not contain errors. Actual result: " ++ show actual) (not (null actual) && all (\case ErrorMessage {} -> False; _ -> True) actual) -refactorTests :: FilePath -> [(String, FilePath, [ClientMessage], [ResponseMsg])] +refactorTests :: FilePath -> [(String, FilePath, [ClientMessage], [ResponseMsg] -> Bool)] refactorTests testRoot = - [ ( "simple-refactor", "simple-refactor" + [ ( "simple-refactor", testRoot </> "simple-refactor" , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "3:1-3:2" ["y"] ] - , [ LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - , ModulesChanged [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - ] ) - , ( "hs-boots", "hs-boots" + , \case [ LoadingModules{}, LoadedModules [ (aPath, _) ], ModulesChanged _, LoadingModules{}, LoadedModules [ (aPath', _) ]] + -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" && aPath == aPath'; _ -> False ) + , ( "hs-boots", testRoot </> "hs-boots" , [ AddPackages [ testRoot </> "hs-boots" ++ testSuffix ] , PerformRefactoring "RenameDefinition" (testRoot </> "hs-boots" ++ testSuffix </> "A.hs") "5:1-5:2" ["aa"] ] - , [ LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs-boot", testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" - , testRoot </> "hs-boots" ++ testSuffix </> "A.hs", testRoot </> "hs-boots" ++ testSuffix </> "B.hs" ] - , ModulesChanged [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs", testRoot </> "hs-boots" ++ testSuffix </> "B.hs" - , testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs-boot" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs-boot" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "hs-boots" ++ testSuffix </> "B.hs" ] - ] ) - , ( "remove-module", "simple-refactor" + , \case [ LoadingModules{}, LoadedModules _, LoadedModules _, LoadedModules _, LoadedModules _, ModulesChanged _ + , LoadingModules{}, LoadedModules [ (path1, _) ], LoadedModules [ (path2, _) ] + , LoadedModules [ (path3, _) ], LoadedModules [ (path4, _) ] + ] -> let allPathes = map ((testRoot </> "hs-boots" ++ testSuffix) </>) ["A.hs","B.hs","A.hs-boot","B.hs-boot"] + in sort [path1,path2,path3,path4] == sort allPathes + _ -> False ) + , ( "remove-module", testRoot </> "simple-refactor" , [ AddPackages [ testRoot </> "simple-refactor" ++ testSuffix ] , PerformRefactoring "RenameDefinition" (testRoot </> "simple-refactor" ++ testSuffix </> "A.hs") "1:8-1:9" ["AA"] ] - , [ LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" ] - , ModulesChanged [ testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" ] - , LoadedModules [ testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" ] - ] ) + , \case [ LoadingModules{},LoadedModules [ (aPath, _) ], ModulesChanged _, LoadingModules{},LoadedModules [ (aaPath, _) ]] + -> aPath == testRoot </> "simple-refactor" ++ testSuffix </> "A.hs" + && aaPath == testRoot </> "simple-refactor" ++ testSuffix </> "AA.hs" + _ -> False ) ] -reloadingTests :: [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg])] +reloadingTests :: [(String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool)] reloadingTests = [ ( "reloading-module", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]] - , writeFile (testRoot </> "reloading" ++ testSuffix </> "C.hs") "module C where\nc = ()" - , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "C.hs"] [] - , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "2:1-2:2" ["d"] - ] - , [ LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" - , testRoot </> "reloading" ++ testSuffix </> "B.hs" - , testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - , ModulesChanged [ testRoot </> "reloading" ++ testSuffix </> "C.hs" - , testRoot </> "reloading" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - ] - ) + , writeFile (testRoot </> "reloading" ++ testSuffix </> "C.hs") "module C where\nc = ()" + , [ ReLoad [] [testRoot </> "reloading" ++ testSuffix </> "C.hs"] [] + , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "2:1-2:2" ["d"] + ] + , \case [ LoadingModules{}, LoadedModules [(pathC'',_)], LoadedModules [(pathB'',_)], LoadedModules [(pathA'',_)] + , LoadingModules{}, LoadedModules [(pathC,_)], LoadedModules [(pathB,_)], LoadedModules [(pathA,_)] + , ModulesChanged _, LoadingModules{},LoadedModules [(pathC',_)], LoadedModules [(pathB',_)], LoadedModules [(pathA',_)] + ] -> let allPathes = map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs","A.hs"] + in [pathC,pathB,pathA] == allPathes + && [pathC',pathB',pathA'] == allPathes + && [pathC'',pathB'',pathA''] == allPathes + _ -> False ) , ( "reloading-package", testRoot </> "changing-cabal" , [ AddPackages [ testRoot </> "changing-cabal" ++ testSuffix ]] - , appendFile (testRoot </> "changing-cabal" ++ testSuffix </> "some-test-package.cabal") ", B" + , appendFile (testRoot </> "changing-cabal" ++ testSuffix </> "some-test-package.cabal") ", B" , [ AddPackages [testRoot </> "changing-cabal" ++ testSuffix] - , PerformRefactoring "RenameDefinition" (testRoot </> "changing-cabal" ++ testSuffix </> "A.hs") "3:1-3:2" ["z"] - ] - , [ LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" - , testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ] - , ModulesChanged [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" - , testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ] - , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "changing-cabal" ++ testSuffix </> "B.hs" ] + , PerformRefactoring "RenameDefinition" (testRoot </> "changing-cabal" ++ testSuffix </> "A.hs") "3:1-3:2" ["z"] ] - ) + , \case [ LoadingModules{}, LoadedModules [(pathA,_)], LoadingModules{}, LoadedModules [(pathA',_)] + , LoadedModules [(pathB',_)], ModulesChanged _ + , LoadingModules{}, LoadedModules [(pathA'',_)], LoadedModules [(pathB'',_)] + ] -> let [pA,pB] = map ((testRoot </> "changing-cabal" ++ testSuffix) </>) ["A.hs","B.hs"] + in pA == pathA && pA == pathA' && pA == pathA'' && pB == pathB' && pB == pathB'' + _ -> False ) + , ( "adding-module", testRoot </> "reloading", [AddPackages [ testRoot </> "reloading" ++ testSuffix ]] + , writeFile (testRoot </> "reloading" ++ testSuffix </> "D.hs") "module D where\nd = ()" + , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "D.hs"] [] [] ] + , \case [ LoadingModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}, LoadingModules {} + , LoadingModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}, LoadedModules {}] -> True + _ -> False ) , ( "reloading-remove", testRoot </> "reloading", [ AddPackages [ testRoot </> "reloading" ++ testSuffix ]] , do removeFile (testRoot </> "reloading" ++ testSuffix </> "A.hs") removeFile (testRoot </> "reloading" ++ testSuffix </> "B.hs") - , [ ReLoad [testRoot </> "reloading" ++ testSuffix </> "C.hs"] - [testRoot </> "reloading" ++ testSuffix </> "A.hs", testRoot </> "reloading" ++ testSuffix </> "B.hs"] - , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "3:1-3:2" ["d"] - ] - , [ LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" - , testRoot </> "reloading" ++ testSuffix </> "B.hs" - , testRoot </> "reloading" ++ testSuffix </> "A.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , ModulesChanged [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - , LoadedModules [ testRoot </> "reloading" ++ testSuffix </> "C.hs" ] - ] - ) + , [ ReLoad [] [testRoot </> "reloading" ++ testSuffix </> "C.hs"] + [testRoot </> "reloading" ++ testSuffix </> "A.hs", testRoot </> "reloading" ++ testSuffix </> "B.hs"] + , PerformRefactoring "RenameDefinition" (testRoot </> "reloading" ++ testSuffix </> "C.hs") "3:1-3:2" ["d"] + ] + , \case [ LoadingModules{}, LoadedModules [(pathC,_)], LoadedModules [(pathB,_)], LoadedModules [(pathA,_)] + , LoadingModules{}, LoadedModules [(pathC',_)], ModulesChanged _, LoadingModules{}, LoadedModules [(pathC'',_)] ] + -> let [pC,pB,pA] = map ((testRoot </> "reloading" ++ testSuffix) </>) ["C.hs","B.hs","A.hs"] + in pA == pathA && pB == pathB && pC == pathC && pC == pathC' && pC == pathC'' + _ -> False ) , ( "remove-package", testRoot </> "multi-packages-dependent" , [ AddPackages [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" , testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2" ]] , removeDirectoryRecursive (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2") - , [ RemovePackages [testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2"] - , PerformRefactoring "RenameDefinition" (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs") - "3:1-3:2" ["d"] - ] - , [ LoadedModules [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" - , testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2" </> "B.hs" ] - , ModulesChanged [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" ] - , LoadedModules [ testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs" ] - ] - ) + , [ RemovePackages [testRoot </> "multi-packages-dependent" ++ testSuffix </> "package2"] + , PerformRefactoring "RenameDefinition" (testRoot </> "multi-packages-dependent" ++ testSuffix </> "package1" </> "A.hs") + "3:1-3:2" ["d"] + ] + , \case [ LoadingModules{}, LoadedModules [(pathA',_)], LoadedModules [(pathB',_)], ModulesChanged _, LoadingModules{}, LoadedModules [(pathA,_)] ] + -> let [pA,pB] = map ((testRoot </> "multi-packages-dependent" ++ testSuffix) </>) [ "package1" </> "A.hs", "package2" </> "B.hs"] + in pA == pathA && pA == pathA' && pB == pathB' + _ -> False ) ] pkgDbTests :: [(String, IO (), [ClientMessage], [ResponseMsg])] -pkgDbTests - = [ {- ( "stack" - , withCurrentDirectory (testRoot </> "stack") initStack - , [SetPackageDB StackDB, AddPackages [testRoot </> "stack"]] - , [LoadedModules [testRoot </> "stack" </> "UseGroups.hs"]] ) - , -} ( "cabal-sandbox" +pkgDbTests + = [ ( "cabal-sandbox" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox , [SetPackageDB CabalSandboxDB, AddPackages [testRoot </> "cabal-sandbox"]] - , [LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"]] ) + , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")]] ) , ( "cabal-sandbox-auto" , 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"]] ) + , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")]] ) , ( "pkg-db-reload" , withCurrentDirectory (testRoot </> "cabal-sandbox") initCabalSandbox , [ SetPackageDB AutoDB , AddPackages [testRoot </> "cabal-sandbox"] - , ReLoad [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] []] - , [ LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] - , LoadedModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] ]) - ] + , ReLoad [] [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] []] + , [ LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")] + , LoadingModules [testRoot </> "cabal-sandbox" </> "UseGroups.hs"] + , LoadedModules [(testRoot </> "cabal-sandbox" </> "UseGroups.hs", "UseGroups")] ]) + ] where initCabalSandbox = do sandboxExists <- doesDirectoryExist ".cabal-sandbox" when sandboxExists $ tryToExecute "cabal" ["sandbox", "delete"] @@ -277,48 +287,50 @@ execute :: String -> [String] -> IO () -execute cmd args +execute cmd args = do let command = (cmd ++ concat (map (" " ++) args)) (_, Just stdOut, Just stdErr, handle) <- createProcess ((shell command) { std_out = CreatePipe, std_err = CreatePipe }) exitCode <- waitForProcess handle - when (exitCode /= ExitSuccess) $ do + when (exitCode /= ExitSuccess) $ do output <- hGetContents stdOut errors <- hGetContents stdErr error ("Command exited with nonzero: " ++ command ++ " output:\n" ++ output ++ "\nerrors:\n" ++ errors) tryToExecute :: String -> [String] -> IO () -tryToExecute cmd args +tryToExecute cmd args = do let command = (cmd ++ concat (map (" " ++) args)) (_, _, _, handle) <- createProcess ((shell command) { std_out = NoStream, std_err = NoStream }) void $ waitForProcess handle -makeDaemonTest :: MVar Int -> (Maybe FilePath, String, [ClientMessage], [ResponseMsg]) -> TestTree -makeDaemonTest port (Nothing, label, input, expected) = testCase label $ do +makeDaemonTest :: MVar Int -> (String, [ClientMessage], [ResponseMsg]) -> TestTree +makeDaemonTest port (label, input, expected) = testCase label $ do actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input)) assertEqual "" expected actual -makeDaemonTest port (Just dir, label, input, expected) = testCase label $ do + +makeRefactorTest :: MVar Int -> (String, FilePath, [ClientMessage], [ResponseMsg] -> Bool) -> TestTree +makeRefactorTest port (label, dir, input, validator) = testCase label $ do exists <- doesDirectoryExist (dir ++ testSuffix) -- clear the target directory from possible earlier test runs when exists $ removeDirectoryRecursive (dir ++ testSuffix) copyDir dir (dir ++ testSuffix) actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input)) - assertEqual "" expected actual + assertBool ("The responses are not the expected: " ++ show actual) (validator actual) `finally` removeDirectoryRecursive (dir ++ testSuffix) -makeReloadTest :: MVar Int -> (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg]) -> TestTree -makeReloadTest port (label, dir, input1, io, input2, expected) = testCase label $ do +makeReloadTest :: MVar Int -> (String, FilePath, [ClientMessage], IO (), [ClientMessage], [ResponseMsg] -> Bool) -> TestTree +makeReloadTest port (label, dir, input1, io, input2, validator) = testCase label $ do exists <- doesDirectoryExist (dir ++ testSuffix) -- clear the target directory from possible earlier test runs when exists $ removeDirectoryRecursive (dir ++ testSuffix) copyDir dir (dir ++ testSuffix) actual <- communicateWithDaemon port (map Right (SetPackageDB DefaultDB : input1) ++ [Left io] ++ map Right input2) - assertEqual "" expected actual + assertBool ("The responses are not the expected: " ++ show actual) (validator actual) `finally` removeDirectoryRecursive (dir ++ testSuffix) makePkgDbTest :: MVar Int -> (String, IO (), [ClientMessage], [ResponseMsg]) -> TestTree -makePkgDbTest port (label, prepare, inputs, expected) - = localOption (mkTimeout ({- 30s -} 1000 * 1000 * 30)) - $ testCase label $ do +makePkgDbTest port (label, prepare, inputs, expected) + = localOption (mkTimeout ({- 30s -} 1000 * 1000 * 30)) + $ testCase label $ do actual <- communicateWithDaemon port ([Left prepare] ++ map Right inputs) assertEqual "" expected actual @@ -344,14 +356,14 @@ sendAll sock $ encode Stop close sock return (concat intermedRes ++ resps) - where waitToConnect sock addr + where waitToConnect sock addr = connect sock addr `catch` \(e :: SomeException) -> waitToConnect sock addr - retryConnect port = do portNum <- readMVar port + retryConnect port = do portNum <- readMVar port forkIO $ runDaemon [show portNum, "True"] return portNum `catch` \(e :: SomeException) -> do putStrLn ("exception caught: `" ++ show e ++ "` trying with a new port") - modifyMVar_ port (\i -> if i < pORT_NUM_END - then return (i+1) + modifyMVar_ port (\i -> if i < pORT_NUM_END + then return (i+1) else error "The port number reached the maximum") retryConnect port @@ -360,18 +372,20 @@ readSockResponsesUntil sock rsp bs = do resp <- recv sock 2048 let fullBS = bs `BS.append` resp - if BS.null resp + if BS.null resp then return [] else let splitted = BS.split '\n' fullBS recognized = catMaybes $ map decode splitted - in if rsp `elem` recognized - then return $ List.delete rsp recognized + in if rsp `elem` recognized + then return $ List.delete rsp recognized else readSockResponsesUntil sock rsp fullBS testRoot = "examples" </> "Project" +deriving instance Eq UndoRefactor deriving instance Eq ResponseMsg +instance FromJSON UndoRefactor instance FromJSON ResponseMsg instance ToJSON ClientMessage instance ToJSON PackageDB @@ -400,15 +414,15 @@ longestCommonPrefix = foldl1 commonPrefix instance FromJSON SrcSpan where - parseJSON (Object v) = mkSrcSpanReal <$> v .: "file" - <*> v .: "startRow" - <*> v .: "startCol" + 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 +mkSrcSpanReal file startRow startCol endRow endCol = mkSrcSpan (mkSrcLoc (mkFastString file) startRow startCol) (mkSrcLoc (mkFastString file) endRow endCol)