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 - [email protected]
+
+- 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)] }
