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 - [email protected]
+
+- 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: [email protected]
+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: [email protected]
+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: [email protected]
+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: [email protected]
+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)
