packages feed

haskell-tools-demo 0.4.1.3 → 0.5.0.0

raw patch · 4 files changed

+43/−28 lines, 4 filesdep ~aesondep ~haskell-tools-astdep ~haskell-tools-backend-ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, haskell-tools-ast, haskell-tools-backend-ghc, haskell-tools-demo, haskell-tools-prettyprint, haskell-tools-refactor

API changes (from Hackage documentation)

+ Language.Haskell.Tools.Demo: reloadAllMods :: FilePath -> StateT RefactorSessionState Ghc ()

Files

haskell-tools-demo.cabal view
@@ -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
src/Language/Haskell/Tools/ASTDebug/Instances.hs view
@@ -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
src/Language/Haskell/Tools/Demo.hs view
@@ -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
test/Main.hs view
@@ -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"] ]