Hello community, here is the log from the commit of package ghc-haskell-tools-demo for openSUSE:Factory checked in at 2017-08-31 20:56:04 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-demo (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-demo.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-demo" Thu Aug 31 20:56:04 2017 rev:2 rq:513373 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-demo/ghc-haskell-tools-demo.changes 2017-04-12 18:06:45.838150689 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-demo.new/ghc-haskell-tools-demo.changes 2017-08-31 20:56:06.042474906 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons@suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-demo-0.5.0.0.tar.gz New: ---- haskell-tools-demo-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-demo.spec ++++++ --- /var/tmp/diff_new_pack.T1hxQe/_old 2017-08-31 20:56:06.774372073 +0200 +++ /var/tmp/diff_new_pack.T1hxQe/_new 2017-08-31 20:56:06.790369825 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-demo %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: A web-based demo for Haskell-tools Refactor License: BSD-3-Clause ++++++ haskell-tools-demo-0.5.0.0.tar.gz -> haskell-tools-demo-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/haskell-tools-demo.cabal new/haskell-tools-demo-0.8.0.0/haskell-tools-demo.cabal --- old/haskell-tools-demo-0.5.0.0/haskell-tools-demo.cabal 2017-01-31 20:57:57.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/haskell-tools-demo.cabal 2017-07-01 12:51:24.000000000 +0200 @@ -1,6 +1,6 @@ name: haskell-tools-demo -version: 0.5.0.0 -synopsis: A web-based demo for Haskell-tools Refactor. +version: 0.8.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 @@ -22,38 +21,38 @@ , transformers >= 0.5 && < 0.6 , directory >= 1.2 && < 1.4 , containers >= 0.5 && < 0.6 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 0.11 , http-types >= 0.9 && < 0.10 , warp >= 3.2 && < 3.3 , wai >= 3.2 && < 3.3 - , websockets >= 0.10 && < 0.11 + , websockets >= 0.10 && < 0.12 , 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.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 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.8 && < 0.9 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 @@ -61,6 +60,6 @@ , bytestring >= 0.10 && < 0.11 , 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 \ No newline at end of file + , aeson >= 1.0 && < 1.3 + , haskell-tools-demo >= 0.8 && < 0.9 + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs 2017-05-17 10:56:29.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug.hs 2017-05-22 15:12:54.000000000 +0200 @@ -53,11 +53,11 @@ deriving instance Domain dom => Show (TreeDebugNode dom) -data SemanticInfoType dom - = DefaultInfoType { semaInfoTypeRng :: SrcSpan +data SemanticInfoType dom + = DefaultInfoType { semaInfoTypeRng :: SrcSpan } | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls - , semaInfoTypeRng :: SrcSpan + , semaInfoTypeRng :: SrcSpan } | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls , semaInfoTypeRng :: SrcSpan @@ -88,7 +88,7 @@ astDebugToJson :: AssocSema dom => [DebugNode dom] -> Seq Char astDebugToJson nodes = fromList "[ " >< childrenJson >< fromList " ]" where treeNodes = List.filter (\case TreeNode {} -> True; _ -> False) nodes - childrenJson = case map debugTreeNode treeNodes of + childrenJson = case map debugTreeNode treeNodes of first:rest -> first >< foldl (><) Seq.empty (fmap (fromList ", " ><) (fromList rest)) [] -> Seq.empty debugTreeNode (TreeNode "" s) = astDebugElemJson s @@ -96,20 +96,20 @@ debugTreeNode (SimpleNode {}) = error "debugTreeNode: simple SimpleNode not allowed" astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char -astDebugElemJson (TreeDebugNode name info children) - = fromList "{ \"text\" : \"" >< fromList name - >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" +astDebugElemJson (TreeDebugNode name info children) + = fromList "{ \"text\" : \"" >< fromList name + >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" >< fromList (shortShowSpan (semaInfoTypeRng info)) - >< fromList "\", \"data-elems\" : \"" + >< fromList "\", \"data-elems\" : \"" >< foldl (><) Seq.empty dataElems - >< fromList "\", \"data-sema\" : \"" + >< fromList "\", \"data-sema\" : \"" >< fromList (showSema info) - >< fromList "\" }, \"children\" : " + >< fromList "\" }, \"children\" : " >< astDebugToJson children >< fromList " }" where dataElems = catMaybes (map (\case SimpleNode l v -> Just (fromList (formatScalarElem l v)); _ -> Nothing) children) formatScalarElem l v = "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ tail (init (show v)) ++ "</div>" - showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" - ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) + showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" + ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) class AssocData a where assocName :: a -> String @@ -140,15 +140,15 @@ toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni)) , ("isDefined", show (semanticsDefining ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance AssocData CNameInfo where assocName _ = "CNameInfo" toAssoc ni = [ ("name", inspect (semanticsId ni)) , ("isDefined", show (semanticsDefining ni)) - , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance (HasModuleInfo' (ModuleInfo n)) => AssocData (ModuleInfo n) where @@ -157,25 +157,28 @@ , ("isBoot", show (isBootModule mi)) , ("implicitImports", concat (intersperse ", " (map inspect (semanticsImplicitImports mi)))) ] - + instance (HasImportInfo' (ImportInfo n)) => AssocData (ImportInfo n) where assocName _ = "ImportInfo" - toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) - , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) - , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) - ] - + toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) + , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) + , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) + ] + instance AssocData ImplicitFieldInfo where assocName _ = "ImplicitFieldInfo" toAssoc ifi = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") (semanticsImplicitFlds ifi)))) - ] + ] -inspectScope :: InspectableName n => [[n]] -> String +inspectScope :: InspectableName n => [[(n, Maybe [UsageSpec])]] -> String inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect) class InspectableName n where inspect :: n -> String +instance InspectableName n => InspectableName (n, Maybe [UsageSpec]) where + inspect (n,usage) = inspect n ++ showSDocUnsafe (ppr usage) + instance InspectableName GHC.Name where inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" @@ -193,35 +196,35 @@ | Just (_, t') <- splitForAllTy_maybe t = getTVs t' | otherwise = [] -class (Domain dom, SourceInfo st) +class (Domain dom, SourceInfo st) => ASTDebug e dom st where astDebug' :: e dom st -> [DebugNode dom] default astDebug' :: (GAstDebug (Rep (e dom st)) dom, Generic (e dom st)) => e dom st -> [DebugNode dom] astDebug' = gAstDebug . from -class GAstDebug f dom where +class GAstDebug f dom where gAstDebug :: f p -> [DebugNode dom] - + instance GAstDebug V1 dom where gAstDebug _ = error "GAstDebug V1" - + instance GAstDebug U1 dom where - gAstDebug U1 = [] - + gAstDebug U1 = [] + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :+: g) dom where gAstDebug (L1 x) = gAstDebug x gAstDebug (R1 x) = gAstDebug x - + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :*: g) dom where - gAstDebug (x :*: y) + gAstDebug (x :*: y) = gAstDebug x ++ gAstDebug y instance {-# OVERLAPPING #-} ASTDebug e dom st => GAstDebug (K1 i (e dom st)) dom where gAstDebug (K1 x) = astDebug' x - + instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) dom where gAstDebug (K1 x) = [SimpleNode "" (show x)] - + instance (GAstDebug f dom, Constructor c) => GAstDebug (M1 C c f) dom where gAstDebug c@(M1 x) = [TreeNode "" (TreeDebugNode (conName c) undefined (gAstDebug x))] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/Demo.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/Demo.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/Demo.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/Demo.hs 2017-06-07 10:55:20.000000000 +0200 @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings - , DeriveGeneric + , DeriveGeneric , TypeApplications , TupleSections , ScopedTypeVariables @@ -52,13 +52,13 @@ import Language.Haskell.Tools.PrettyPrint import Language.Haskell.Tools.Refactor.Perform import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.RefactorBase hiding (initSession) type ClientId = Int data RefactorSessionState - = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom) - , _actualMod :: Maybe (String, String, IsBoot) + = RefactorSessionState { _refSessMods :: Map.Map (String, String, FilePath) (UnnamedModule IdDom) + , _actualMod :: Maybe (String, String, FilePath) , _isDisconnecting :: Bool } @@ -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) @@ -129,9 +129,9 @@ return Nothing updateClient dir (ModuleDeleted name) = do lift $ removeTarget (TargetModule (GHC.mkModuleName name)) - modify $ refSessMods .- Map.delete (dir, name, NormalHs) + modify $ refSessMods .- Map.delete (dir, name, dir </> moduleSourceFile name) 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,24 +148,29 @@ 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) + modify $ refSessMods .- Map.delete (dir, mod, dir </> moduleSourceFile mod) lift $ removeTarget (TargetModule (GHC.mkModuleName mod)) reloadAllMods dir @@ -173,22 +178,23 @@ 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 - modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, NormalHs) mod + mod <- lift $ getModSummary modName >>= parseTyped wd + modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, dir </> moduleSourceFile (GHC.moduleNameString modName)) mod createFileForModule :: FilePath -> String -> String -> IO () 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 -moduleNameAndContent :: ((String,String,IsBoot), mod) -> (SourceFileKey, mod) +moduleNameAndContent :: ((String,String,FilePath), mod) -> (SourceFileKey, mod) moduleNameAndContent ((_,name,isBoot), mod) = (SourceFileKey isBoot name, mod) dataDirs :: FilePath -> FilePath @@ -198,25 +204,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 +239,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 +259,7 @@ | Disconnect deriving (Show, Generic) -instance FromJSON ClientMessage +instance FromJSON ClientMessage data ResponseMsg = RefactorChanges { moduleChanges :: [(String, Maybe String)] }