diff --git a/haskell-tools-demo.cabal b/haskell-tools-demo.cabal --- a/haskell-tools-demo.cabal +++ b/haskell-tools-demo.cabal @@ -1,6 +1,6 @@ name: haskell-tools-demo -version: 0.5.0.0 -synopsis: A web-based demo for Haskell-tools Refactor. +version: 0.6.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 license: BSD3 @@ -11,9 +11,8 @@ build-type: Simple cabal-version: >=1.10 -library +library hs-source-dirs: src - ghc-options: -O2 exposed-modules: Language.Haskell.Tools.Demo other-modules: Language.Haskell.Tools.ASTDebug , Language.Haskell.Tools.ASTDebug.Instances @@ -30,30 +29,30 @@ , websockets >= 0.10 && < 0.11 , wai-websockets >= 3.0 && < 3.1 , references >= 0.3 && < 0.4 - , ghc >= 8.0 && < 8.1 + , ghc >= 8.0.2 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , filepath >= 1.4 && < 1.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 + , haskell-tools-ast >= 0.6 && < 0.7 + , haskell-tools-backend-ghc >= 0.6 && < 0.7 + , haskell-tools-prettyprint >= 0.6 && < 0.7 + , haskell-tools-refactor >= 0.6 && < 0.7 default-language: Haskell2010 executable ht-demo main-is: Main.hs hs-source-dirs: exe - ghc-options: -with-rtsopts=-M1500m -O2 + ghc-options: -with-rtsopts=-M1500m build-depends: base >= 4.9 && < 4.10 - , haskell-tools-demo >= 0.5 && < 0.6 + , haskell-tools-demo >= 0.6 && < 0.7 default-language: Haskell2010 test-suite haskell-tools-demo-tests type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2g -O2 + ghc-options: -with-rtsopts=-M2g 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 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 @@ -62,5 +61,5 @@ , network >= 2.6 && < 2.7 , websockets >= 0.10 && < 0.11 , aeson >= 1.0 && < 1.2 - , haskell-tools-demo >= 0.5 && < 0.6 - default-language: Haskell2010 + , haskell-tools-demo >= 0.6 && < 0.7 + 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 @@ -3,7 +3,7 @@ , MultiParamTypeClasses , StandaloneDeriving , DeriveGeneric - , UndecidableInstances + , UndecidableInstances , TypeFamilies #-} module Language.Haskell.Tools.ASTDebug.Instances where @@ -40,7 +40,7 @@ instance (ASTDebug e dom st) => ASTDebug (AnnListG e) dom st where astDebug' (AnnListG a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] - + instance (ASTDebug e dom st) => ASTDebug (AnnMaybeG e) dom st where astDebug' (AnnMaybeG a e) = [TreeNode "" (TreeDebugNode "?" (DefaultInfoType (getRange (a ^. sourceInfo))) (maybe [] astDebug' e))] @@ -103,6 +103,7 @@ instance (Domain dom, SourceInfo st) => ASTDebug UBracket dom st instance (Domain dom, SourceInfo st) => ASTDebug UTopLevelPragma dom st instance (Domain dom, SourceInfo st) => ASTDebug URule dom st +instance (Domain dom, SourceInfo st) => ASTDebug URuleVar dom st instance (Domain dom, SourceInfo st) => ASTDebug UAnnotationSubject dom st instance (Domain dom, SourceInfo st) => ASTDebug UMinimalFormula dom st instance (Domain dom, SourceInfo st) => ASTDebug UExprPragma dom st @@ -131,6 +132,7 @@ 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 +instance (Domain dom, SourceInfo st) => ASTDebug USpecializePragma 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 @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings - , DeriveGeneric + , DeriveGeneric , TypeApplications , TupleSections , ScopedTypeVariables @@ -75,7 +75,7 @@ wd <- case args of dir:_ -> return dir [] -> return "." counter <- newMVar [] - let settings = setPort 8206 $ setTimeout 20 $ defaultSettings + let settings = setPort 8206 $ setTimeout 20 $ defaultSettings runSettings settings (app counter wd) -- | The application that is evoked for each incoming request @@ -96,10 +96,10 @@ do Text msg <- receiveDataMessage conn respondTo wd sessId ghcSess state (sendTextData conn) msg currState <- readMVar state - if currState ^. isDisconnecting + if currState ^. isDisconnecting then sendClose conn ("" :: ByteString) else serverLoop sessId ghcSess state conn - `catch` \(_ :: ConnectionException) -> do + `catch` \(_ :: ConnectionException) -> do modifyMVar_ sessions (return . delete sessId) liftIO $ removeDirectoryIfPresent (userDir wd sessId) @@ -131,7 +131,7 @@ lift $ removeTarget (TargetModule (GHC.mkModuleName name)) modify $ refSessMods .- Map.delete (dir, name, NormalHs) return Nothing -updateClient dir (InitialProject modules) = do +updateClient dir (InitialProject modules) = do -- clean the workspace to remove source files from earlier sessions liftIO $ removeDirectoryIfPresent dir liftIO $ createDirectoryIfMissing True dir @@ -148,21 +148,26 @@ 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)) - let command = analyzeCommand refact (selection:args) - 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" + 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 where trfDiff (ContentChanged (key,cont)) = (key ^. sfkModuleName, Just (prettyPrint cont)) trfDiff (ModuleCreated name mod _) = (name, Just (prettyPrint mod)) trfDiff (ModuleRemoved name) = (name, Nothing) applyChanges diff - = do forM_ diff $ \case - ModuleCreated n m _ -> writeModule n m - ContentChanged (n,m) -> writeModule (n ^. sfkModuleName) m + = do forM_ diff $ \case + ModuleCreated n m _ -> do + writeModule n m + lift $ addTarget (Target (TargetModule (GHC.mkModuleName n)) True Nothing) + ContentChanged (n,m) -> + writeModule (n ^. sfkModuleName) m ModuleRemoved mod -> do liftIO $ removeFile (toFileName dir mod) modify $ refSessMods .- Map.delete (dir, mod, NormalHs) @@ -183,7 +188,7 @@ createFileForModule dir name newContent = do let fname = toFileName dir name createDirectoryIfMissing True (takeDirectory fname) - withBinaryFile fname WriteMode (`hPutStr` newContent) + withBinaryFile fname WriteMode (`hPutStr` newContent) removeDirectoryIfPresent :: FilePath -> IO () removeDirectoryIfPresent dir = removeDirectoryRecursive dir `catch` \e -> if isDoesNotExistError e then return () else throwIO e @@ -198,25 +203,30 @@ userDir wd id = dataDirs wd show id initGhcSession :: FilePath -> IO Session -initGhcSession workingDir +initGhcSession workingDir = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlagsForTest >> useDirs [workingDir] >> getSession)) handleErrors :: FilePath -> ClientMessage -> (ResponseMsg -> IO ()) -> IO () -> IO () handleErrors wd req next io = io `catch` (next <=< handleException) where handleException :: SomeException -> IO ResponseMsg - handleException e - | Just (se :: SourceError) <- fromException e - = return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) + handleException e + | Just (se :: SourceError) <- fromException e + = if isReloading + then do logToFile wd (show e) req + return $ ErrorMessage ("The generated code cannot be compiled. The problem had been reported. Please restart the demo or correct the results manually.") + else 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) - + showMsg msg = showSpan (errMsgSpan msg) ++ "\n" ++ show msg showSpan (RealSrcSpan sp) = showFileName (srcLocFile (realSrcSpanStart sp)) ++ " " ++ show (srcLocLine (realSrcSpanStart sp)) ++ ":" ++ show (srcLocCol (realSrcSpanStart sp)) showSpan _ = "" + isReloading = case req of PerformRefactoring {} -> True; _ -> False + showFileName = joinPath . drop 2 . splitPath . makeRelative wd . unpackFS showInternalError :: SomeException -> String @@ -228,8 +238,8 @@ withFile logFile AppendMode $ \handle -> do size <- hFileSize handle when (size < logSizeLimit) $ hPutStrLn handle ("\n### " ++ msg) - `catch` \e -> print ("The error message cannot be logged because: " - ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) + `catch` \e -> print ("The error message cannot be logged because: " + ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) where logFile = wd "error-log.txt" logSizeLimit = 100 * 1024 * 1024 -- 100 MB @@ -248,7 +258,7 @@ | Disconnect deriving (Show, Generic) -instance FromJSON ClientMessage +instance FromJSON ClientMessage data ResponseMsg = RefactorChanges { moduleChanges :: [(String, Maybe String)] }