Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Try to recognise if a given session is already running.

  • Loading branch information...
commit 37d142e39b954a28a6fbe2a945dcadd09f803f43 1 parent cb30eae
@nominolo authored
View
10 Makefile
@@ -8,7 +8,7 @@ default: install
TOP := $(shell pwd)
DIST ?= dist
HC ?= ghc
-RUNHC ?= runghc
+RUNHC ?= runghc -f $(HC)
#HC = ghc-6.12.1
#RUNHC = runghc -f$(HC)
@@ -29,8 +29,12 @@ inplace:
.PHONY: install
install:
- cabal -v install --builddir=$(DIST)/cabal --with-compiler=$(HC)
+ time cabal -v install --builddir=$(DIST)/cabal --with-compiler=$(HC)
.PHONY: test
test:
- runghc test/TestSuite.hs
+ $(RUNHC) test/TestSuite.hs
+
+.PHONY: docs
+docs:
+ cabal -v haddock --builddir=$(DIST)/cabal
View
23 emacs/scion.el
@@ -193,8 +193,9 @@ You might prefer `ido-completing-read' to the default, but that
leads to problems on some versions of Emacs which are so severe
that Emacs needs to be restarted. (You have been warned!)")
-(defun scion-completing-read (prompt collection &optional predicate require-match
- initial-input hist def inherit-input-method)
+(defun scion-completing-read (prompt collection
+ &optional predicate require-match
+ initial-input hist def inherit-input-method)
(if (eq scion-completing-read-function 'ido-completing-read)
;; ido-completing-read does not support the last argument. What
;; a mess.
@@ -1197,7 +1198,8 @@ deal with that."
(interactive)
(scion-eval '(quit))
(scion-disconnect)
- (scion-set-buffer-sessions nil))
+ (scion-set-buffer-sessions nil)
+ (setq scion-sessions nil))
;; (defun scion-send-sigint ()
;; (interactive)
@@ -2533,12 +2535,15 @@ loaded."
)))
(defun scion-complete-load-component (result)
- (destructuring-bind (session-id home-dir notes graph) result
- (let ((session (list session-id home-dir graph (scion-make-notes notes))))
- (push session scion-sessions)
- (scion-set-buffer-sessions session)
- (scion-report-compilation-result
- (list :succeeded t :notes notes :duration 0.42)))))
+ (destructuring-bind (new-session-p session-id home-dir notes graph) result
+ (if new-session-p
+ (let ((session (list session-id home-dir graph
+ (scion-make-notes notes))))
+ (push session scion-sessions)
+ (scion-set-buffer-sessions session)
+ (scion-report-compilation-result
+ (list :succeeded t :notes notes :duration 0.42)))
+ (message "Component already loaded as session #%s" session-id))))
(defun scion-cabal-component-p (comp)
(cond
View
18 scion.cabal
@@ -38,23 +38,24 @@ extra-source-files: README.markdown
library
default-language: Haskell2010
build-depends:
- base >= 4.2 && < 4.4,
- Cabal >= 1.8 && < 1.12,
+ base >= 4.2 && < 4.5,
+ Cabal >= 1.8 && < 1.13,
containers >= 0.3 && < 0.5,
directory >= 1.0 && < 1.2,
filepath >= 1.1 && < 1.3,
- ghc >= 6.12 && < 7.2,
+ ghc >= 6.12 && < 7.3,
ghc-paths == 0.1.*,
multiset >= 0.1 && < 0.3,
time >= 1.1 && < 1.3,
text >= 0.11 && < 0.12,
- process >= 1.0 && < 1.1,
+ process >= 1.0 && < 1.2,
unix-compat >= 0.2 && < 0.3,
bytestring >= 0.9 && < 0.10,
binary >= 0.5 && < 0.6,
old-locale >= 1.0 && < 1.1,
network >= 2.3 && < 2.4,
- temporary == 1.1.*
+ temporary == 1.1.*,
+ canonical-filepath == 1.0.*
hs-source-dirs: src
default-extensions: CPP, PatternGuards
@@ -93,7 +94,7 @@ executable scion-worker
default-language: Haskell2010
build-depends:
scion,
- base >= 4.2 && < 4.4
+ base >= 4.2 && < 4.5
executable scion-server
main-is: Server.hs
@@ -103,8 +104,9 @@ executable scion-server
scion,
atto-lisp >= 0.2 && < 0.3,
attoparsec >= 0.8.5.1 && < 0.9,
- base >= 4.2 && < 4.4,
+ base >= 4.2 && < 4.5,
bytestring >= 0.9 && < 0.10,
multiset >= 0.1 && < 0.3,
network >= 2.3 && < 2.4,
- text >= 0.11 && < 0.12
+ text >= 0.11 && < 0.12,
+ canonical-filepath == 1.0.*
View
30 src-execs/Server.hs
@@ -14,6 +14,7 @@ import Control.Applicative
--import Control.Exception ( throwIO, handle, IOException )
import Data.AttoLisp ( FromLisp(..), ToLisp(..) )
import Data.Bits ( shiftL, (.|.) )
+import Data.Maybe ( isNothing )
import Data.Monoid
import Data.String
--import Data.Char ( chr )
@@ -22,6 +23,7 @@ import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import Numeric ( showHex )
import System.IO
+import System.FilePath.Canonical
import qualified Network.Socket.ByteString.Lazy as NL
import qualified Data.AttoLisp as L
import qualified Data.Attoparsec as A
@@ -177,9 +179,11 @@ data ServerResponse
| RSupportedLanguages [Extension]
| RQuitting
| RFileConfigs [SessionConfig]
- | RSessionCreated SessionId FilePath Notes [ModuleSummary]
+ | RSessionCreated IsNewSession SessionId FilePath Notes [ModuleSummary]
| RFileModifiedResult Bool Notes
+type IsNewSession = Bool
+
data Response
= Ok ServerResponse
| Error String
@@ -221,8 +225,8 @@ instance ToLisp ServerResponse where
toLisp RQuitting = L.nil
toLisp (RFileConfigs confs) =
toLisp confs
- toLisp (RSessionCreated sid root_path notes graph) =
- L.List [toLisp sid, toLisp (T.pack root_path), toLisp notes, toLisp graph]
+ toLisp (RSessionCreated ex sid root_path notes graph) =
+ L.List [toLisp ex, toLisp sid, toLisp (T.pack root_path), toLisp notes, toLisp graph]
toLisp (RFileModifiedResult inGraph notes) =
L.List [toLisp inGraph, toLisp notes]
@@ -289,8 +293,9 @@ instance ToLisp LocSource where
instance ToLisp ModuleSummary where
toLisp modsum =
- L.mkStruct "modsum" [toLisp (ms_module modsum),
- toLisp (T.pack $ ms_location modsum)]
+ L.mkStruct "modsum"
+ [toLisp (ms_module modsum),
+ toLisp (T.pack $ canonicalFilePath $ ms_location modsum)]
instance ToLisp ModuleName where
toLisp modname = toLisp (moduleNametoText modname)
@@ -333,11 +338,15 @@ handleRequest ListSupportedLanguages _ =
handleRequest (ListAvailConfigs file) _ =
RFileConfigs <$> cabalSessionConfigs (T.unpack file)
handleRequest (CreateSession conf) _ = do
- sid <- createSession conf
+ existing <- sessionForConfig conf
+ sid <- case existing of
+ Nothing -> createSession conf
+ Just sid_ -> return sid_
notes <- sessionNotes sid
mods <- sessionModules sid
home <- sessionHomeDir <$> getSessionState sid
- return (RSessionCreated sid home notes mods)
+ return (RSessionCreated (isNothing existing) sid
+ (canonicalFilePath home) notes mods)
handleRequest (FileModified file) (Just sid) = do
fileModified sid (T.unpack file)
let fileInModuleGraph = True -- FIXME: find out
@@ -352,5 +361,12 @@ handleRequest (FileModified file0) Nothing = do
fileModified sid file
RFileModifiedResult True <$> sessionNotes sid
+--handleRequest (FileModififedInMemory filename newcontents) (Just sid) = do
+ -- 1. Put newcontents into a file, add that file to the module graph
+ -- import Foo.Bar
+ -- src/Foo/Bar.hs old version
+ -- /tmp/scion/Foo/Bar.hs
+-- error "unimplmented"
+
handleRequest QuitServer _ =
error "handleRequest: should not have reached this point"
View
8 src/Scion/Ghc.hs
@@ -22,7 +22,7 @@ import qualified Data.MultiSet as MS
import qualified Data.Text as T
import Data.String ( fromString )
-import System.Directory ( canonicalizePath )
+import System.FilePath.Canonical
-- * Converting from Ghc types.
@@ -84,8 +84,8 @@ ghcMessagesToNotes base_dir (warns, errs) =
fromGhcModSummary :: MonadIO m => Ghc.ModSummary -> m ModuleSummary
fromGhcModSummary ms = do
- path <- case Ghc.ml_hs_file (Ghc.ms_location ms) of
- Just fp -> io $ canonicalizePath fp
+ cpath <- case Ghc.ml_hs_file (Ghc.ms_location ms) of
+ Just fp -> io $ canonical fp
Nothing -> error "Module has no location"
return $ ModuleSummary
{ ms_module = convert (Ghc.moduleName (Ghc.ms_mod ms))
@@ -95,7 +95,7 @@ fromGhcModSummary ms = do
, ms_imports =
map (convert . Ghc.unLoc
. Ghc.ideclName . Ghc.unLoc) (Ghc.ms_imps ms)
- , ms_location = path
+ , ms_location = cpath
}
instance Convert Ghc.ModuleName ModuleName where
View
57 src/Scion/Session.hs
@@ -32,19 +32,24 @@ import Control.Exception ( throwIO )
import Control.Monad ( when, unless, forever, filterM )
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
import Data.Char ( ord )
import Data.Maybe
import Data.Time.Clock ( getCurrentTime )
import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
import System.Directory ( doesFileExist, getTemporaryDirectory,
- removeDirectoryRecursive, canonicalizePath )
+ removeDirectoryRecursive )
import System.Exit ( ExitCode(..) )
-import System.FilePath ( dropFileName, (</>), takeFileName, makeRelative )
+import System.FilePath ( dropFileName, (</>), takeFileName,
+ makeRelative, takeDirectory )
+import System.FilePath.Canonical
import System.IO
import System.IO.Temp ( createTempDirectory )
import System.PosixCompat.Files ( getFileStatus, modificationTime )
import System.Process ( getProcessExitCode, terminateProcess )
+import Debug.Trace
+
-- -------------------------------------------------------------------
-- | Throw a 'ScionException' if the file does not exist.
@@ -64,10 +69,11 @@ createSession sc0@FileConfig{ sc_fileName = file } = do
mod_time <- convert . modificationTime <$> io (getFileStatus file)
starter <- getWorkerStarter
- let working_dir = dropFileName file
- sc = sc0{ sc_fileName = takeFileName file }
+ working_dir <- io $ canonical $ dropFileName file
+ let sc = sc0{ sc_fileName = takeFileName file }
- (whdl, rslt, graph) <- startWorker starter working_dir sc
+ (whdl, rslt, graph)
+ <- startWorker starter (canonicalFilePath working_dir) sc
outdir0 <- io $ getTemporaryDirectory
sid <- genSessionId
@@ -93,7 +99,7 @@ createSession sc0@CabalConfig{ sc_cabalFile = file } = do
mod_time <- convert . modificationTime <$> io (getFileStatus file)
starter <- getWorkerStarter
- let working_dir = dropFileName file
+ working_dir <- io $ canonical $ dropFileName file
sid <- genSessionId
@@ -108,7 +114,8 @@ createSession sc0@CabalConfig{ sc_cabalFile = file } = do
let sc = sc0{ sc_buildDir = Just build_dir,
sc_cabalFile = takeFileName file -- TODO: use absolute path instead
}
- (whdl, rslt, graph) <- startWorker starter working_dir sc
+ (whdl, rslt, graph)
+ <- startWorker starter (canonicalFilePath working_dir) sc
let sess0 = SessionState
{ sessionConfig = sc
@@ -126,8 +133,9 @@ createSession sc0@CabalConfig{ sc_cabalFile = file } = do
createSession sc@EmptyConfig{} = do
starter <- getWorkerStarter
- working_dir <- io $ getTemporaryDirectory
- (whdl, rslt, graph) <- startWorker starter working_dir sc
+ working_dir <- io $ canonical =<< getTemporaryDirectory
+ (whdl, rslt, graph)
+ <- startWorker starter (canonicalFilePath working_dir) sc
outdir0 <- io $ getTemporaryDirectory
sid <- genSessionId
let outdir = outdir0 </> show sid
@@ -372,6 +380,8 @@ ignoreMostErrors act = do
HandlerM $ \(ex :: RecConError) -> return (Left (show ex))
]
+
+-- | Find the (active) sessions that the given file is part of.
fileSessions :: FilePath -> ScionM [SessionId]
fileSessions path = do
filterM (fileInSession path) =<< activeSessions
@@ -379,6 +389,33 @@ fileSessions path = do
fileInSession :: FilePath -> SessionId -> ScionM Bool
fileInSession path0 sid = do
home <- sessionHomeDir <$> getSessionState sid
- path <- io $ canonicalizePath $ home </> path0
+ path <- io $ canonical $ canonicalFilePath home </> path0
mods <- sessionModules sid
return $ not $ null [ m | m <- mods, ms_location m == path ]
+
+-- | Find a session for the given configuration (if any).
+--
+-- This uses linear search, so the assumption is that there won't be
+-- too many sessions active at any one time.
+--
+-- Note that no normalisation of any flags specified inside the
+-- session occurs. So searching for an existing session with possibly
+-- different flag assignments will fail.
+sessionForConfig :: SessionConfig -> ScionM (Maybe SessionId)
+sessionForConfig conf_ = do
+ sessions <- activeSessionsFull
+ let (conf, path_) = normaliseConf conf_
+ path <- io $ canonical path_
+ --message silent $ "Sessions: " ++ show conf ++ "\n" ++
+ -- show (map (sessionConfig . snd) (M.toList sessions))
+ case [ sid | (sid, s) <- M.toList sessions
+ , sessionConfig s == conf &&
+ (if path_ /= "" then path == sessionHomeDir s else True) ]
+ of [] -> return Nothing
+ (sid:_) -> return (Just sid)
+ where
+ normaliseConf c@FileConfig{ sc_fileName = f } =
+ (c{ sc_fileName = takeFileName f }, takeDirectory f)
+ normaliseConf c@CabalConfig{ sc_cabalFile = f } =
+ (c{ sc_cabalFile = takeFileName f }, takeDirectory f)
+ normaliseConf c = (c, "")
View
2  src/Scion/Types/Compiler.hs
@@ -19,4 +19,4 @@ instance Binary Extension where
get = Ext . T.decodeUtf8 <$> get
instance IsString Extension where
- fromString s = Ext (T.pack s)
+ fromString s = Ext (T.pack s)
View
5 src/Scion/Types/Monad.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-}
--- | Definitions concerning the
+-- | Definitions concerning the 'ScionM' monad.
module Scion.Types.Monad
( module Scion.Types.Monad,
module Scion.Types.Core
@@ -105,6 +105,9 @@ activeSessions :: ScionM [SessionId]
activeSessions = ScionM $ \r -> do
M.keys . gsSessions <$> readIORef r
+activeSessionsFull :: ScionM (M.Map SessionId SessionState)
+activeSessionsFull = ScionM $ \r -> gsSessions <$> readIORef r
+
-- | Unregister a 'SessionId'. NOTE: Does not stop the worker.
unregisterSession :: SessionId -> ScionM ()
unregisterSession sid = ScionM $ \r ->
View
25 src/Scion/Types/Session.hs
@@ -26,6 +26,7 @@ import Data.Typeable ( Typeable )
import qualified Distribution.ModuleName as DM
import System.Directory ( findExecutable, doesFileExist )
import System.FilePath ( (</>) )
+import System.FilePath.Canonical
import System.IO ( Handle )
import System.Locale ( defaultTimeLocale )
import System.Process ( ProcessHandle, runInteractiveProcess )
@@ -104,7 +105,19 @@ data SessionConfig =
-- | A configuration with no files.
EmptyConfig
{ sc_flags :: [String] }
- deriving (Eq, Show)
+ deriving (Show)
+
+instance Eq SessionConfig where
+ c1@FileConfig{} == c2@FileConfig{} =
+ sc_fileName c1 == sc_fileName c2 && sc_flags c1 == sc_flags c2
+ c1@CabalConfig{} == c2@CabalConfig{} =
+ sc_name c1 == sc_name c2 &&
+ sc_cabalFile c1 == sc_cabalFile c2 &&
+ sc_component c1 == sc_component c2 &&
+ sc_configFlags c1 == sc_configFlags c2
+ -- Ignore buildDir when testing for equality
+ c1@EmptyConfig{} == c2@EmptyConfig{} = sc_flags c1 == sc_flags c2
+ _ == _ = False
-- | The @SessionState@ contains the cached part of a worker's state.
data SessionState = SessionState
@@ -123,7 +136,7 @@ data SessionState = SessionState
-- caches to speed things up.
, sessionModuleGraph :: [ModuleSummary]
, sessionLastCompilation :: CompilationResult
- , sessionHomeDir :: FilePath
+ , sessionHomeDir :: CanonicalFilePath
-- ^ All file paths are relative to this directory.
} deriving (Show)
@@ -216,19 +229,23 @@ data ModuleSummary = ModuleSummary
{ ms_module :: ModuleName
, ms_fileType :: HsFileType
, ms_imports :: [ModuleName]
- , ms_location :: FilePath
+ , ms_location :: CanonicalFilePath
} deriving Eq
instance Show ModuleSummary where
show ms =
"<summary:" ++ show (ms_module ms) ++ "," ++
- ms_location ms ++ ">"
+ show (ms_location ms) ++ ">"
instance Binary ModuleSummary where
put (ModuleSummary mdl ft imps loc) =
put mdl >> put ft >> put imps >> put loc
get = ModuleSummary <$> get <*> get <*> get <*> get
+instance Binary CanonicalFilePath where
+ put cfp = put (originalFilePath cfp) >> put (canonicalFilePath cfp)
+ get = unsafeCanonicalise <$> get <*> get
+
data HsFileType
= HaskellFile
| HaskellBootFile
View
4 src/Scion/Worker/Main.hs
@@ -46,6 +46,7 @@ import System.IO
import System.IO.Unsafe ( unsafePerformIO )
import System.Directory hiding ( getModificationTime )
import System.PosixCompat.Files ( getFileStatus, modificationTime )
+import System.FilePath.Canonical
------------------------------------------------------------------------
--
@@ -238,7 +239,8 @@ initGhcSession targets args1 _debugMsg kont = do
dflags0 <- Ghc.getSessionDynFlags
notes_ref <- liftIO $ newIORef []
- base_dir <- liftIO $ canonicalizePath =<< getCurrentDirectory
+ base_dir <- liftIO $ canonicalFilePath <$>
+ (canonical =<< getCurrentDirectory)
let addNote :: NoteKind -> Ghc.SrcSpan -> SDoc -> IO ()
addNote nkind loc msg =
View
7 test/TestSuite.hs
@@ -73,7 +73,12 @@ tests =
notes <- sessionNotes sid
io $ MS.size notes @?= 0,
- testCase "recomp01" test_recomp01
+ testCase "recomp01" test_recomp01,
+
+ testCase "findConfig01" $ run $ do
+ withSession (cabal_config001 ".") $ \sid -> do
+ sid' <- sessionForConfig (cabal_config001 ".")
+ io $ sid' @?= Just sid
]
-- Tests recompilation
Please sign in to comment.
Something went wrong with that request. Please try again.