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.4.1.3 +version: 0.5.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 @@ -22,7 +22,7 @@ , transformers >= 0.5 && < 0.6 , directory >= 1.2 && < 1.4 , containers >= 0.5 && < 0.6 - , aeson >= 1.0 && < 1.1 + , aeson >= 1.0 && < 1.2 , bytestring >= 0.10 && < 0.11 , http-types >= 0.9 && < 0.10 , warp >= 3.2 && < 3.3 @@ -33,10 +33,10 @@ , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , filepath >= 1.4 && < 1.5 - , haskell-tools-ast >= 0.4 && < 0.5 - , haskell-tools-backend-ghc >= 0.4 && < 0.5 - , haskell-tools-prettyprint >= 0.4 && < 0.5 - , haskell-tools-refactor >= 0.4 && < 0.5 + , haskell-tools-ast >= 0.5 && < 0.6 + , haskell-tools-backend-ghc >= 0.5 && < 0.6 + , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-refactor >= 0.5 && < 0.6 default-language: Haskell2010 executable ht-demo @@ -44,7 +44,7 @@ hs-source-dirs: exe ghc-options: -with-rtsopts=-M1500m -O2 build-depends: base >= 4.9 && < 4.10 - , haskell-tools-demo >= 0.4 && < 0.5 + , haskell-tools-demo >= 0.5 && < 0.6 default-language: Haskell2010 test-suite haskell-tools-demo-tests @@ -61,6 +61,6 @@ , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 , websockets >= 0.10 && < 0.11 - , aeson >= 1.0 && < 1.1 - , haskell-tools-demo >= 0.4 && < 0.5 + , aeson >= 1.0 && < 1.2 + , haskell-tools-demo >= 0.5 && < 0.6 default-language: Haskell2010 diff --git a/src/Language/Haskell/Tools/ASTDebug/Instances.hs b/src/Language/Haskell/Tools/ASTDebug/Instances.hs --- a/src/Language/Haskell/Tools/ASTDebug/Instances.hs +++ b/src/Language/Haskell/Tools/ASTDebug/Instances.hs @@ -130,6 +130,7 @@ instance (Domain dom, SourceInfo st) => ASTDebug UCmd dom st instance (Domain dom, SourceInfo st) => ASTDebug ULanguageExtension dom st instance (Domain dom, SourceInfo st) => ASTDebug UMatchLhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug UInlinePragma dom st -- ULiteral instance (Domain dom, SourceInfo st) => ASTDebug ULiteral dom st 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 @@ -125,8 +125,7 @@ when (isNothing . find ((\case (TargetModule n) -> GHC.moduleNameString n == name; _ -> False) . targetId) $ targets) $ lift $ addTarget (Target (TargetModule (GHC.mkModuleName name)) True Nothing) void $ lift $ load LoadAllTargets - mod <- lift $ getModSummary (GHC.mkModuleName name) >>= parseTyped - modify $ refSessMods .- Map.insert (dir, name, NormalHs) mod + reloadAllMods dir return Nothing updateClient dir (ModuleDeleted name) = do lift $ removeTarget (TargetModule (GHC.mkModuleName name)) @@ -139,10 +138,7 @@ liftIO $ forM_ modules $ \(mod, cont) -> do withBinaryFile (toFileName dir mod) WriteMode (`hPutStr` cont) lift $ setTargets (map ((\modName -> Target (TargetModule (GHC.mkModuleName modName)) True Nothing) . fst) modules) - void $ lift $ load LoadAllTargets - forM_ (map fst modules) $ \modName -> do - mod <- lift $ getModSummary (GHC.mkModuleName modName) >>= parseTyped - modify $ refSessMods .- Map.insert (dir, modName, NormalHs) mod + reloadAllMods dir return Nothing updateClient _ (PerformRefactoring "UpdateAST" modName _ _) = do mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) @@ -163,20 +159,26 @@ trfDiff (ModuleCreated name mod _) = (name, Just (prettyPrint mod)) trfDiff (ModuleRemoved name) = (name, Nothing) - applyChanges - = mapM_ $ \case - ModuleCreated n m _ -> writeModule n m - ContentChanged (n,m) -> writeModule (n ^. sfkModuleName) m - ModuleRemoved mod -> do - liftIO $ removeFile (toFileName dir mod) - modify $ refSessMods .- Map.delete (dir, mod, NormalHs) + applyChanges diff + = do forM_ diff $ \case + ModuleCreated n m _ -> writeModule n m + ContentChanged (n,m) -> writeModule (n ^. sfkModuleName) m + ModuleRemoved mod -> do + liftIO $ removeFile (toFileName dir mod) + modify $ refSessMods .- Map.delete (dir, mod, NormalHs) + lift $ removeTarget (TargetModule (GHC.mkModuleName mod)) + reloadAllMods dir - writeModule n m = do - liftIO $ withBinaryFile (toFileName dir n) WriteMode (`hPutStr` prettyPrint m) - void $ gets (find ((n ==) . (\(_,m,_) -> m)) . Map.keys . (^. refSessMods)) - newm <- lift $ (parseTyped =<< loadModule dir n) - modify $ refSessMods .- Map.insert (dir, n, NormalHs) newm + writeModule n m = liftIO $ withBinaryFile (toFileName dir n) WriteMode (`hPutStr` prettyPrint m) +reloadAllMods :: FilePath -> StateT RefactorSessionState Ghc () +reloadAllMods dir = do + void $ lift $ load LoadAllTargets + targets <- lift getTargets + forM_ (map ((\case (TargetModule n) -> n) . targetId) targets) $ \modName -> do + mod <- lift $ getModSummary modName >>= parseTyped + modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, NormalHs) mod + createFileForModule :: FilePath -> String -> String -> IO () createFileForModule dir name newContent = do let fname = toFileName dir name @@ -207,6 +209,7 @@ = return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) | Just (ae :: AsyncException) <- fromException e = throw ae | Just (ge :: GhcException) <- fromException e = return $ ErrorMessage $ show ge + | Just (re :: RefactorException) <- fromException e = return $ ErrorMessage $ displayException re | otherwise = do logToFile wd (show e) req return $ ErrorMessage (showInternalError e) @@ -217,7 +220,7 @@ showFileName = joinPath . drop 2 . splitPath . makeRelative wd . unpackFS showInternalError :: SomeException -> String - showInternalError e = "An internal error happened. The report has been sent to the developers. " ++ show e + showInternalError e = "An internal error happened. The report has been sent to the developers. " ++ displayException e logToFile :: FilePath -> String -> ClientMessage -> IO () logToFile wd err input = do diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -75,6 +75,17 @@ , [ InitialProject [("A", "module A where\n\na = ()"), ("B", "module B where\n\nimport A\n\nb = a")] , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["x"] ] , [ RefactorChanges [("A", Just "module A where\n\nx = ()"), ("B", Just "module B where\n\nimport A\n\nb = x")] ] ) + , ( "multi-module-refactor-user-added-later" + , [ InitialProject [("A", "module A where\n\na = ()")] + , ModuleChanged "B" "module B where\n\nimport A\n\nb = a" + , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["x"] ] + , [ RefactorChanges [("A", Just "module A where\n\nx = ()"), ("B", Just "module B where\n\nimport A\n\nb = x")] ] ) + , ( "multi-module-refactor-both-added-later" + , [ InitialProject [("B", "module B where")] + , ModuleChanged "A" "module A where\n\na = ()" + , ModuleChanged "B" "module B where\n\nimport A\n\nb = a" + , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["x"] ] + , [ RefactorChanges [("A", Just "module A where\n\nx = ()"), ("B", Just "module B where\n\nimport A\n\nb = x")] ] ) , ( "rename-module" , [ InitialProject [("A", "module A where\n\na = ()")] , PerformRefactoring "RenameDefinition" "A" "1:8-1:9" ["AA"] ]