diff --git a/Language/Haskell/Tools/Refactor/Daemon.hs b/Language/Haskell/Tools/Refactor/Daemon.hs --- a/Language/Haskell/Tools/Refactor/Daemon.hs +++ b/Language/Haskell/Tools/Refactor/Daemon.hs @@ -5,6 +5,7 @@ , TemplateHaskell , FlexibleContexts , MultiWayIf + , TypeApplications #-} module Language.Haskell.Tools.Refactor.Daemon where @@ -126,11 +127,11 @@ return 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 @@ -139,12 +140,11 @@ updateClient resp (ReLoad added changed removed) = -- TODO: check for changed cabal files and reload their packages do mcs <- gets (^. refSessMCs) - removedMods <- gets (map ms_mod . filter ((`elem` removed) . getModSumOrig) . (^? refSessMCs & traversal & mcModules & traversal & modRecMS)) - lift $ forM_ removedMods (\modName -> removeTarget (TargetModule (GHC.moduleName modName))) + lift $ forM_ removed (\src -> removeTarget (TargetFile src Nothing)) -- remove targets deleted 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) }) + .- 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)])) @@ -183,20 +183,18 @@ 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 + 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 (TargetModule (GHC.mkModuleName n)) True Nothing) - return $ Right (SourceFileKey NormalHs n, loc, RemoveAdded loc) + 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 let newCont = prettyPrint m - file = getModSumOrig ms + file = n ^. sfkFileName origCont <- liftIO $ withBinaryFile file ReadMode $ \handle -> do hSetEncoding handle utf8 StrictIO.hGetContents handle @@ -206,12 +204,12 @@ 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 let file = getModSumOrig ms origCont <- liftIO (StrictBS.unpack <$> StrictBS.readFile file) - lift $ removeTarget (TargetModule modName) + lift $ removeTarget (TargetFile file Nothing) modify $ (refSessMCs .- removeModule mod) liftIO $ removeFile file return $ Left $ RestoreRemoved file origCont @@ -232,25 +230,21 @@ else do -- clear existing removed packages existingMCs <- gets (^. refSessMCs) - let existing = map ms_mod $ (existingMCs ^? traversal & filtered isTheAdded & mcModules & traversal & modRecMS) - needToReload <- handleErrors $ (filter (\ms -> not $ ms_mod ms `elem` existing)) - <$> getReachableModules (\_ -> return ()) (\ms -> ms_mod ms `elem` existing) + 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 $ \mn -> removeTarget (TargetModule (GHC.moduleName mn)) - modifySession (\s -> s { hsc_mod_graph = filter (not . (`elem` existing) . ms_mod) (hsc_mod_graph s) }) + 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, ignoredMods) -> do + Right modules -> do mapM_ (reloadModule (\_ -> return ())) (either (const []) id needToReload) -- don't report consequent reloads (not expected) - liftIO $ when (not $ null ignoredMods) - $ resp $ ErrorMessage - $ "The following modules are ignored: " - ++ concat (intersperse ", " ignoredMods) - ++ ". Multiple modules with the same qualified name are not supported." 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" diff --git a/Language/Haskell/Tools/Refactor/Daemon/State.hs b/Language/Haskell/Tools/Refactor/Daemon/State.hs --- a/Language/Haskell/Tools/Refactor/Daemon/State.hs +++ b/Language/Haskell/Tools/Refactor/Daemon/State.hs @@ -4,6 +4,7 @@ import Control.Reference import Language.Haskell.Tools.Refactor.Daemon.PackageDB +import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Session data DaemonSessionState diff --git a/examples/Project/unused-mod/Main.hs b/examples/Project/unused-mod/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Project/unused-mod/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello World" diff --git a/examples/Project/unused-mod/Unused.hs b/examples/Project/unused-mod/Unused.hs new file mode 100644 --- /dev/null +++ b/examples/Project/unused-mod/Unused.hs @@ -0,0 +1,1 @@ +Not a valid haskell program diff --git a/examples/Project/unused-mod/some-test-package.cabal b/examples/Project/unused-mod/some-test-package.cabal new file mode 100644 --- /dev/null +++ b/examples/Project/unused-mod/some-test-package.cabal @@ -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 --git a/haskell-tools-daemon.cabal b/haskell-tools-daemon.cabal --- a/haskell-tools-daemon.cabal +++ b/haskell-tools-daemon.cabal @@ -1,5 +1,5 @@ name: haskell-tools-daemon -version: 0.7.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 @@ -58,6 +58,8 @@ , 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 @@ -76,9 +78,9 @@ , references >= 0.3.2 && < 1.0 , network >= 2.6 && < 3.0 , Diff >= 0.3 && < 0.4 - , haskell-tools-ast >= 0.7 && < 0.8 - , haskell-tools-prettyprint >= 0.7 && < 0.8 - , haskell-tools-refactor >= 0.7 && < 0.8 + , 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 @@ -89,7 +91,7 @@ executable ht-daemon ghc-options: -rtsopts build-depends: base >= 4.9 && < 5.0 - , haskell-tools-daemon >= 0.7 && < 0.8 + , haskell-tools-daemon >= 0.8 && < 0.9 hs-source-dirs: exe main-is: Main.hs default-language: Haskell2010 @@ -110,5 +112,5 @@ , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 , aeson >= 1.0 && < 1.3 - , haskell-tools-daemon >= 0.7 && < 0.8 + , haskell-tools-daemon >= 0.8 && < 0.9 default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -58,7 +58,7 @@ 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" @@ -121,6 +121,10 @@ , 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)]