diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,6 +1,6 @@ module Main where -import Language.Haskell.Tools.Demo +import Language.Haskell.Tools.Demo (runFromCLI) main :: IO () main = runFromCLI diff --git a/haskell-tools-demo.cabal b/haskell-tools-demo.cabal --- a/haskell-tools-demo.cabal +++ b/haskell-tools-demo.cabal @@ -1,5 +1,5 @@ name: haskell-tools-demo -version: 0.8.1.0 +version: 0.9.0.0 synopsis: A web-based demo for Haskell-tools Refactor. description: Allows websocket clients to connect and performs refactorings on demand. The clients maintain a continous connection with the server, sending changes in the source files. When a refactor request is received, it performs the changes and sends the modified source files to the client. homepage: https://github.com/haskell-tools/haskell-tools @@ -26,16 +26,17 @@ , http-types >= 0.9 && < 0.10 , warp >= 3.2 && < 3.3 , wai >= 3.2 && < 3.3 - , websockets >= 0.10 && < 0.13 + , websockets >= 0.10 && < 0.12 , wai-websockets >= 3.0 && < 3.1 , references >= 0.3 && < 0.4 - , ghc >= 8.0.2 && < 8.3 + , ghc >= 8.0.2 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , filepath >= 1.4 && < 1.5 - , haskell-tools-ast >= 0.8 && < 0.9 - , haskell-tools-backend-ghc >= 0.8 && < 0.9 - , haskell-tools-prettyprint >= 0.8 && < 0.9 - , haskell-tools-refactor >= 0.8 && < 0.9 + , haskell-tools-ast >= 0.9 && < 0.10 + , haskell-tools-backend-ghc >= 0.9 && < 0.10 + , haskell-tools-prettyprint >= 0.9 && < 0.10 + , haskell-tools-builtin-refactorings >= 0.9 && < 0.10 + , haskell-tools-refactor >= 0.9 && < 0.10 default-language: Haskell2010 executable ht-demo @@ -59,7 +60,7 @@ , filepath >= 1.4 && < 2.0 , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 - , websockets >= 0.10 && < 0.13 + , websockets >= 0.10 && < 0.11 , aeson >= 1.0 && < 1.3 , haskell-tools-demo default-language: Haskell2010 diff --git a/src/Language/Haskell/Tools/ASTDebug.hs b/src/Language/Haskell/Tools/ASTDebug.hs --- a/src/Language/Haskell/Tools/ASTDebug.hs +++ b/src/Language/Haskell/Tools/ASTDebug.hs @@ -170,14 +170,14 @@ toAssoc ifi = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") (semanticsImplicitFlds ifi)))) ] -inspectScope :: InspectableName n => [[(n, Maybe [UsageSpec])]] -> String +inspectScope :: InspectableName n => [[(n, Maybe [UsageSpec], Maybe n)]] -> String inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect) -class InspectableName n where +class Outputable n => InspectableName n where inspect :: n -> String -instance InspectableName n => InspectableName (n, Maybe [UsageSpec]) where - inspect (n,usage) = inspect n ++ showSDocUnsafe (ppr usage) +instance InspectableName n => InspectableName (n, Maybe [UsageSpec], Maybe n) where + inspect (n,usage,parent) = inspect n ++ showSDocUnsafe (ppr usage) ++ maybe "" (\p -> "( in " ++ showSDocUnsafe (ppr p) ++ ")") parent instance InspectableName GHC.Name where inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" diff --git a/src/Language/Haskell/Tools/Demo.hs b/src/Language/Haskell/Tools/Demo.hs --- a/src/Language/Haskell/Tools/Demo.hs +++ b/src/Language/Haskell/Tools/Demo.hs @@ -50,9 +50,8 @@ import Language.Haskell.Tools.ASTDebug import Language.Haskell.Tools.ASTDebug.Instances () import Language.Haskell.Tools.PrettyPrint -import Language.Haskell.Tools.Refactor.Perform -import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase hiding (initSession) +import Language.Haskell.Tools.Refactor hiding (initSession) +import Language.Haskell.Tools.Refactor.Builtin type ClientId = Int @@ -147,16 +146,18 @@ updateClient _ (PerformRefactoring "TestErrorLogging" _ _ _) = error "This is a test" updateClient dir (PerformRefactoring refact modName selection args) = do mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) - allModules <- gets (filter ((modName /=) . (^. sfkModuleName) . fst) . map moduleNameAndContent . Map.assocs . (^. refSessMods)) - case analyzeCommand refact (selection:args) of - Right command -> - case mod of Just m -> do res <- lift $ performCommand command (moduleNameAndContent m) allModules - case res of - Left err -> return $ Just $ ErrorMessage err - Right diff -> do applyChanges diff - return $ Just $ RefactorChanges (map trfDiff diff) - Nothing -> return $ Just $ ErrorMessage "The module is not found" - Left err -> return $ Just $ ErrorMessage err + otherModules <- gets (filter ((modName /=) . (^. sfkModuleName) . fst) . map moduleNameAndContent . Map.assocs . (^. refSessMods)) + + case mod of + Just m -> + do res <- lift $ performCommand builtinRefactorings + ([refact,selection] ++ args) + (Right $ moduleNameAndContent m) otherModules + case res of + Right diff -> do applyChanges diff + return $ Just $ RefactorChanges (map trfDiff diff) + Left err -> return $ Just $ ErrorMessage err + Nothing -> return $ Just $ ErrorMessage "The module is not found" where trfDiff (ContentChanged (key,cont)) = (key ^. sfkModuleName, Just (prettyPrint cont)) trfDiff (ModuleCreated name mod _) = (name, Just (prettyPrint mod)) trfDiff (ModuleRemoved name) = (name, Nothing) @@ -178,11 +179,10 @@ reloadAllMods :: FilePath -> StateT RefactorSessionState Ghc () reloadAllMods dir = do - wd <- liftIO getCurrentDirectory void $ lift $ load LoadAllTargets targets <- lift getTargets forM_ (map ((\case (TargetModule n) -> n) . targetId) targets) $ \modName -> do - mod <- lift $ getModSummary modName >>= parseTyped wd + mod <- lift $ getModSummary modName >>= parseTyped modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, dir moduleSourceFile (GHC.moduleNameString modName)) mod createFileForModule :: FilePath -> String -> String -> IO () diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,26 +1,18 @@ {-# LANGUAGE StandaloneDeriving, LambdaCase #-} module Main where -import Test.Tasty -import Test.Tasty.HUnit -import System.Exit -import System.Directory -import System.FilePath -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.MVar -import Network.WebSockets -import qualified Data.ByteString.Lazy.Char8 as BS -import qualified Data.List as List +import Control.Concurrent (killThread, forkIO) +import Control.Monad (Monad(..), mapM) import Data.Aeson -import Data.Maybe -import System.IO -import System.Directory - -import Debug.Trace +import qualified Data.ByteString.Lazy.Char8 as BS (unpack) +import qualified Data.List as List ((++), map) +import Data.Maybe (Maybe(..)) +import Network.WebSockets +import System.IO (IO(..)) +import Test.Tasty +import Test.Tasty.HUnit (assertEqual, assertBool, testCase) -import Language.Haskell.Tools.Demo +import Language.Haskell.Tools.Demo (ResponseMsg(..), ClientMessage(..), runDemo) main :: IO () main = do -- create one daemon process for the whole testing session @@ -31,8 +23,8 @@ allTests :: TestTree allTests - = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) - $ testGroup "daemon-tests" + = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) + $ testGroup "daemon-tests" [ testGroup "simple-tests" $ map makeDemoTest simpleTests , testGroup "loading-tests" $ map makeDemoTest loadingTests , testGroup "refactor-tests" $ map makeDemoTest refactorTests @@ -40,7 +32,7 @@ ] simpleTests :: [(String, [ClientMessage], [ResponseMsg])] -simpleTests = +simpleTests = [ ( "empty-test", [], [] ) , ( "keep-alive", [KeepAlive], [] ) ] @@ -103,15 +95,15 @@ ] makeDemoTest :: (String, [ClientMessage], [ResponseMsg]) -> TestTree -makeDemoTest (label, input, expected) = testCase label $ do +makeDemoTest (label, input, expected) = testCase label $ do actual <- communicateWithDemo input assertEqual "" expected actual astViewTest :: TestTree -astViewTest = testCase "ast-view-test" $ do +astViewTest = testCase "ast-view-test" $ do actual <- communicateWithDemo [ InitialProject [("A", "module A where\n\na = ()")] , PerformRefactoring "UpdateAST" "A" "1:1" [] ] - assertBool "The response must be a simple ASTViewContent message" + assertBool "The response must be a simple ASTViewContent message" $ case actual of [ ASTViewContent _ ] -> True _ -> False