Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Rewrite from scratch using new multi-process architecture.

It turned out that using a single-process design was not
going to work well enough in the long-run.  Offloading process
management to the front-end is against the goals of Scion, so
the new architecture fully embraces the need for multiple
processes.

See docs/Architecture.markdown for details.
  • Loading branch information...
commit dc0193c32ec32dc8db8f08877e4f670edc008dcd 1 parent e0cd3e5
Thomas Schilling authored
106 Makefile
View
@@ -1,75 +1,31 @@
-.PHONY: default clean install-lib install-deps setup
-
-default: all
-all: build
-
-include config.mk
-
-# If not set in custom config.mk, use the default versions
-HC ?= ghc
-PKG ?= ghc-pkg
-HADDOCK ?= haddock
-
-DIST = dist
-DIST_LIB = $(DIST)/lib
-DIST_SERVER = $(DIST)/server
-SETUP_DIST = setup-dist
-SETUP = $(SETUP_DIST)/Setup
-
-DOTDOTSETUP = cabal
-
-CABAL_INSTALL_OPTS += --ghc --with-compiler=$(HC) --with-hc-pkg=$(PKG)
-CABAL_FLAGS ?=
-# -ftesting
-
-$(DIST)/setup-config: $(SETUP) scion.cabal $(DIST)
- $(SETUP) configure -v --builddir=$(DIST) \
- --with-compiler=$(HC) --with-hc-pkg=$(PKG) \
- --user $(CABAL_FLAGS) > $(DIST)/lib-config-log
-
-$(DIST)/build/libHSscion-0.1.a: $(SETUP) $(DIST)/setup-config $(wildcard lib/**/*.hs lib/**/**/*.hs server/**/*.hs)
- @echo === Building scion ===
- $(SETUP) build --builddir=$(DIST)
-
-$(DIST):
- mkdir $(DIST)
-
-$(SETUP): Setup.hs $(SETUP_DIST)
- $(HC) --make $< -o $@
-
-$(SETUP_DIST):
- mkdir $@
-
-setup: $(SETUP)
-
-build: $(DIST)/build/libHSscion-0.1.a
-
-# TODO: dodgy
-install: $(DIST)/build/libHSscion-0.1.a
- cabal install
-
-# test: build
-# echo main | $(HC) --interactive -package ghc -DDEBUG -isrc -idist/build tests/RunTests.hs
-# # ./dist/build/test_get_imports/test_get_imports $(GHC_PATH)/compiler dist-stage2 +RTS -s -RTS
-
-clean:
- $(SETUP) clean --builddir=$(DIST) || rm -rf $(DIST)
-
-distclean: clean
- rm -rf $(SETUP_DIST)
-
-# doc: configure
-# $(SETUP) haddock --with-haddock=$(HADDOCK)
-
-printvars:
- @echo "UseInplaceGhc = $(UseInplaceGhc)"
- @echo "GHC_PATH = $(GHC_PATH)"
- @echo "HC = $(HC)"
- @echo "PKG = $(PKG)"
- @echo "HADDOCK = $(HADDOCK)"
- @echo "CABAL_INSTALL = $(CABAL_INSTALL)"
- @echo " ..._OPTS = $(CABAL_INSTALL_OPTS)"
- @echo "CABAL_FLAGS = $(CABAL_FLAGS)"
- @echo "---------------------------------------------------------------"
- @echo "DIST_LIB = $(DIST_LIB)"
- @echo "SETUP_DIST = $(SETUP_DIST)"
+default: inplace
+
+TOP := $(shell pwd)
+DIST = $(HOME)/tmp/dist-devel/scion-0.4/
+HC ?= ghc
+RUNHC ?= runghc
+
+#HC = ghc-6.12.1
+#RUNHC = runghc -f$(HC)
+
+boot:
+ mkdir -p $(DIST)
+
+.PHONY: inplace
+inplace:
+ $(HC) --make -outputdir $(DIST) -isrc -package ghc Scion.Session
+ $(HC) --make -outputdir $(DIST) -isrc -package ghc Scion.Worker.Main
+ $(HC) --make -outputdir $(DIST) -isrc -package ghc src/Worker.hs -o $(DIST)/scion-worker
+# cp src/Worker.hs $(DIST)/Worker.hs
+ echo "#!/bin/sh\n$(DIST)/scion-worker \$${1+\"\$$@\"}" > inplace/scion-worker
+ chmod +x inplace/scion-worker
+ echo "#!/bin/sh\n$(RUNHC) -i\"$(TOP)/src\" -package --ghc-arg=ghc -i\"$(DIST)\" \"$(TOP)/src/Server.hs\"" > inplace/scion-server
+ chmod +x inplace/scion-server
+
+.PHONY: install
+install:
+ cabal -v install --builddir=$(DIST)/cabal
+
+.PHONY: test
+test:
+ runghc test/TestSuite.hs
62 docs/Architecture.markdown
View
@@ -0,0 +1,62 @@
+Since version 0.3 Scion uses a multi-process architecture. The Scion
+library starts one or more `scion-worker` processes which do the
+actual work. The Scion library just manages these processes (and
+caches some of their state). This solves the following problems:
+
+ - *Static Flags*. Some of GHC's command line flags can only be set
+ on start-up. This is important mainly for flags that control the
+ kind of compilation (profiled, threaded).
+
+ - *Other write-once state*. GHC only reads the package database once
+ on startup. If new packages have been installed since startup
+ they will not be visible. Changing the database by force while a
+ session is running is likely to cause problems.
+
+ - *Caches*. There are a few caches in GHC that cannot be flushed.
+ These include the name cache, and the package DB cache.
+
+ - *Multiple Compiler Versions*. It is not possible to link to two
+ different versions of GHC from within the same program. If we
+ want to make sure a program compiles with multiple versions of GHC
+ (or multiple combinations of its dependencies) we need to use
+ multiple processes.
+
+The downside of a multi-process architecture is of course the
+additional context switches and communication overhead. To reduce
+this, we:
+
+ - use a binary protocol,
+
+ - cache some information on the library side, and
+
+ - avoid sending too much data between library and worker.
+
+Non-Haskell front-ends use a scion-server that takes the place of the
+library.
+
+The architecture therefore looks as follows:
+
+ +-----------------------+
+ | Non-Haskell frontend |
+ | (Eclipse, Emacs, Vim) |
+ +-----------------------+
+ ^
+ | front-end specific protocol
+ | (e.g., json, s-exprs)
+ v
+ +-----------------+
+ | Scion server / |
+ | Scion library |
+ +-----------------+
+ ^ ^ ^
+ | | | binary protocol
+ v v v
+ +--------------+ +--------------+
+ | Scion worker | ... | Scion worker |
+ +--------------+ +--------------+
+
+If the front-end is written in Haskell, it will take the part of the
+Scion library. The Scion server, in turn, translates between a
+front-end-specific serialisation format to Scion library API calls.
+
+The library-worker protocol is defined in `src/Scion/Types/Commands`.
157 scion.cabal
View
@@ -1,5 +1,5 @@
name: scion
-version: 0.1.0.2
+version: 0.3
license: BSD3
license-file: LICENSE
author: Thomas Schilling <nominolo@googlemail.com>
@@ -19,59 +19,61 @@ description:
category: Development
stability: provisional
build-type: Simple
-cabal-version: >= 1.6
+cabal-version: >= 1.10
extra-source-files: README.markdown
-data-files:
- emacs/*.el
- vim_runtime_path/autoload/*.vim
- vim_runtime_path/ftplugin/*.vim
- vim_runtime_path/plugin/*.vim
+--data-files:
+-- emacs/*.el
+-- vim_runtime_path/autoload/*.vim
+-- vim_runtime_path/ftplugin/*.vim
+-- vim_runtime_path/plugin/*.vim
-flag testing
- description: Enable Debugging things like QuickCheck properties, etc.
- default: False
+--flag testing
+-- description: Enable Debugging things like QuickCheck properties, etc.
+-- default: False
-flag server
- description: Install the scion-server.
- default: True
+--flag server
+-- description: Install the scion-server.
+-- default: True
library
+ default-language: Haskell2010
build-depends:
- base == 4.*,
- Cabal >= 1.5 && < 1.7,
- containers == 0.2.*,
- directory == 1.0.*,
- filepath == 1.1.*,
- ghc >= 6.10 && < 6.12,
+ base >= 4.2 && < 4.4,
+ Cabal >= 1.8 && < 1.12,
+ containers >= 0.3 && < 0.5,
+ directory >= 1.0 && < 1.2,
+ filepath >= 1.1 && < 1.3,
+ ghc >= 6.12 && < 7.2,
ghc-paths == 0.1.*,
- ghc-syb == 0.1.*,
- hslogger == 1.0.*,
- json == 0.4.*,
- multiset == 0.1.*,
- time == 1.1.*,
- uniplate == 1.2.*
-
- hs-source-dirs: lib
- extensions: CPP, PatternGuards
+ multiset >= 0.1 && < 0.3,
+ time >= 1.1 && < 1.3,
+ text >= 0.11 && < 0.12,
+ process >= 1.0 && < 1.1,
+ 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
+
+ hs-source-dirs: src
+ default-extensions: CPP, PatternGuards
exposed-modules:
- Scion.Types,
- Scion.Types.ExtraInstances,
- Scion.Types.Notes,
- Scion.Inspect,
- Scion.Inspect.Find,
- Scion.Inspect.TypeOf,
- Scion.Inspect.DefinitionSite,
- Scion.Utils,
+ Scion.Ghc,
Scion.Session,
- Scion.Configure,
- Scion
-
- if flag(testing)
- build-depends: QuickCheck == 2.*
- cpp-options: -DDEBUG
+ Scion.Types.Compiler,
+ Scion.Types.Commands,
+ Scion.Types.Monad,
+ Scion.Types.Note,
+ Scion.Types.Session,
+ Scion.Types.Worker,
+ Scion.Utils.Convert,
+ Scion.Utils.IO,
+ Scion.Worker.Commands,
+ Scion.Worker.Main
+ other-modules:
+ Paths_scion
- if impl(ghc > 6.11)
- cpp-options: -DHAVE_PACKAGE_DB_MODULES
+ cpp-options: -DHAVE_PACKAGE_DB_MODULES
-- TODO: drop after 6.10.2 is out
if impl(ghc >= 6.11.20081113) || impl(ghc >= 6.10.2 && < 6.11)
@@ -82,65 +84,10 @@ library
ghc-options: -Wall
-executable scion-server
- if !flag(server)
- buildable: False
-
- main-is: Main.hs
- hs-source-dirs: lib server
-
+executable scion-worker
+ main-is: Worker.hs
+ hs-source-dirs: src-execs
+ default-language: Haskell2010
build-depends:
- -- From the library:
- base == 4.*,
- Cabal >= 1.5 && < 1.7,
- containers == 0.2.*,
- directory == 1.0.*,
- filepath == 1.1.*,
- ghc >= 6.10 && < 6.12,
- ghc-paths == 0.1.*,
- ghc-syb == 0.1.*,
- hslogger == 1.0.*,
- json == 0.4.*,
- multiset == 0.1.*,
- time == 1.1.*
-
- if flag(server)
- build-depends:
- -- Server only
- bytestring == 0.9.*,
- network >= 2.1 && < 2.3,
- network-bytestring == 0.1.*,
- utf8-string == 0.3.*
-
- other-modules:
- Scion
- Scion.Configure
- Scion.Inspect
- Scion.Inspect.DefinitionSite
- Scion.Session
- Scion.Types
- Scion.Types.Notes
- Scion.Utils
-
- Scion.Server.Commands
- Scion.Server.ConnectionIO
- Scion.Server.Generic
- Scion.Server.Protocol
-
- ghc-options: -Wall
- extensions: CPP, PatternGuards
-
- if flag(testing)
- build-depends: QuickCheck == 2.*
- cpp-options: -DDEBUG
-
- if impl(ghc > 6.11)
- cpp-options: -DHAVE_PACKAGE_DB_MODULES
-
- -- TODO: drop after 6.10.2 is out
- if impl(ghc >= 6.11.20081113) || impl(ghc >= 6.10.2 && < 6.11)
- cpp-options: -DRECOMPILE_BUG_FIXED
-
- if impl(ghc == 6.10.*)
- cpp-options: -DWPINLINE
-
+ scion,
+ base >= 4.2 && < 4.4
6 src-execs/Worker.hs
View
@@ -0,0 +1,6 @@
+module Main where
+
+import Scion.Worker.Main ( workerMain )
+
+main = workerMain 42
+--main = soloWorkerMain
124 src/Scion/Ghc.hs
View
@@ -0,0 +1,124 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Scion.Ghc
+ ( -- * Converting from GHC error messages
+ ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote,
+ ghcMessagesToNotes
+ )
+where
+
+import Scion.Types.Note
+import Scion.Types.Session
+import Scion.Utils.Convert
+
+import qualified ErrUtils as Ghc ( ErrMsg(..), WarnMsg, Messages )
+import qualified SrcLoc as Ghc
+import qualified HscTypes as Ghc
+import qualified Module as Ghc
+import qualified GHC as Ghc
+import qualified FastString as Ghc ( unpackFS )
+import qualified Outputable as Ghc ( showSDoc, ppr, showSDocForUser )
+import qualified Bag ( bagToList )
+import qualified Data.MultiSet as MS
+import qualified Data.Text as T
+
+import Data.String ( fromString )
+
+-- * Converting from Ghc types.
+
+-- | Convert a 'Ghc.SrcSpan' to a 'Location'.
+--
+-- The first argument is used to normalise relative source locations to an
+-- absolute file path.
+ghcSpanToLocation :: FilePath -- ^ Base directory
+ -> Ghc.SrcSpan
+ -> Location
+ghcSpanToLocation baseDir sp
+ | Ghc.isGoodSrcSpan sp =
+ mkLocation mkLocFile
+ (Ghc.srcSpanStartLine sp)
+ (Ghc.srcSpanStartCol sp)
+ (Ghc.srcSpanEndLine sp)
+ (Ghc.srcSpanEndCol sp)
+ | otherwise =
+ mkNoLoc (Ghc.showSDoc (Ghc.ppr sp))
+ where
+ mkLocFile =
+ case Ghc.unpackFS (Ghc.srcSpanFile sp) of
+ s@('<':_) -> OtherSrc s
+ p -> FileSrc $ mkAbsFilePath baseDir p
+
+ghcErrMsgToNote :: FilePath -> Ghc.ErrMsg -> Note
+ghcErrMsgToNote = ghcMsgToNote ErrorNote
+
+ghcWarnMsgToNote :: FilePath -> Ghc.WarnMsg -> Note
+ghcWarnMsgToNote = ghcMsgToNote WarningNote
+
+-- Note that we don *not* include the extra info, since that information is
+-- only useful in the case where we don not show the error location directly
+-- in the source.
+ghcMsgToNote :: NoteKind -> FilePath -> Ghc.ErrMsg -> Note
+ghcMsgToNote note_kind base_dir msg =
+ Note { noteLoc = ghcSpanToLocation base_dir loc
+ , noteKind = note_kind
+ , noteMessage = T.pack (show_msg (Ghc.errMsgShortDoc msg))
+ }
+ where
+ loc | (s:_) <- Ghc.errMsgSpans msg = s
+ | otherwise = Ghc.noSrcSpan
+ unqual = Ghc.errMsgContext msg
+ show_msg = Ghc.showSDocForUser unqual
+
+-- | Convert 'Ghc.Messages' to 'Notes'.
+--
+-- This will mix warnings and errors, but you can split them back up
+-- by filtering the 'Notes' based on the 'noteKind'.
+ghcMessagesToNotes :: FilePath -- ^ Base path for normalising paths.
+ -- See 'mkAbsFilePath'.
+ -> Ghc.Messages -> Notes
+ghcMessagesToNotes base_dir (warns, errs) =
+ MS.union (map_bag2ms (ghcWarnMsgToNote base_dir) warns)
+ (map_bag2ms (ghcErrMsgToNote base_dir) errs)
+ where
+ map_bag2ms f = MS.fromList . map f . Bag.bagToList
+
+fromGhcModSummary :: Ghc.ModSummary -> ModuleSummary
+fromGhcModSummary ms =
+ ModuleSummary
+ { ms_module = convert (Ghc.moduleName (Ghc.ms_mod ms))
+ , ms_fileType = case Ghc.ms_hsc_src ms of
+ Ghc.HsSrcFile -> HaskellFile
+ Ghc.HsBootFile -> HaskellBootFile
+ , ms_imports =
+ map (convert . Ghc.unLoc
+ . Ghc.ideclName . Ghc.unLoc) (Ghc.ms_imps ms)
+ , ms_location =
+ case Ghc.ml_hs_file (Ghc.ms_location ms) of
+ Just fp -> fp
+ Nothing -> error "Module has no location"
+ }
+
+instance Convert Ghc.ModSummary ModuleSummary where
+ convert = fromGhcModSummary
+
+instance Convert Ghc.ModuleName ModuleName where
+ convert m = fromString (Ghc.moduleNameString m)
+
+instance Convert Target Ghc.Target where
+ convert = targetToGhcTarget
+
+targetToGhcTarget :: Target -> Ghc.Target
+targetToGhcTarget (ModuleTarget mdl) =
+ Ghc.Target { Ghc.targetId = Ghc.TargetModule mdl'
+ , Ghc.targetAllowObjCode = True
+ , Ghc.targetContents = Nothing
+ }
+ where mdl' = convert mdl -- Ghc.mkModuleName (C.display mdl)
+targetToGhcTarget (FileTarget path) =
+ -- TODO: make sure paths are absolute or relative to a known directory
+ Ghc.Target { Ghc.targetId = Ghc.TargetFile path Nothing
+ , Ghc.targetAllowObjCode = True
+ , Ghc.targetContents = Nothing
+ }
+
+instance Convert ModuleName Ghc.ModuleName where
+ convert (ModuleName s) = Ghc.mkModuleName (T.unpack s)
309 src/Scion/Session.hs
View
@@ -0,0 +1,309 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings,
+ ScopedTypeVariables #-}
+-- | Basic Ideas:
+--
+-- All we need to /describe/ a session is a 'SessionConfig'. From
+-- that we can reconstruct all internal state on demand. Of course,
+-- for efficiency we do lots of caching (preferably on disk).
+--
+-- Session state stored and managed by a separate process, the Scion
+-- worker. This causes a bit of overhead, but for most actions will
+-- be negligible.
+--
+-- Most interactions will be of the form \"This file has changed,
+-- please update the state\" or \"Give me this information based on
+-- the current state.\"
+--
+module Scion.Session where
+
+import Scion.Types.Compiler
+import Scion.Types.Note
+import Scion.Types.Session
+import Scion.Types.Commands
+import Scion.Types.Monad
+--import Scion.Worker
+import Scion.Utils.Convert
+import Scion.Utils.IO
+import Control.Exception ( bracketOnError, throwIO, handle )
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception ( throwIO )
+import Control.Monad ( when, unless, forever )
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import Data.Char ( ord )
+import Data.Maybe
+import Data.Time.Clock ( getCurrentTime )
+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+import System.Directory ( doesFileExist, getTemporaryDirectory )
+import System.FilePath ( dropFileName, (</>), takeFileName )
+import System.IO
+import System.PosixCompat.Files ( getFileStatus, modificationTime )
+import System.Process ( getProcessExitCode, terminateProcess )
+
+-- -------------------------------------------------------------------
+
+-- | Create a new session for the given session config.
+--
+-- Starts a new worker and returns the associated session ID.
+createSession :: SessionConfig
+ -> ScionM SessionId
+createSession sc0@FileConfig{ sc_fileName = file } = do
+ ok <- io $ doesFileExist file
+ when (not ok) $
+ io $ throwIO $ userError $
+ "createSession: File does not exist: " ++ file
+
+ mod_time <- convert . modificationTime <$> io (getFileStatus file)
+
+ starter <- getWorkerStarter
+ let working_dir = dropFileName file
+ sc = sc0{ sc_fileName = takeFileName file }
+
+ (whdl, rslt, graph) <- startWorker starter working_dir sc
+
+ outdir0 <- io $ getTemporaryDirectory
+ sid <- genSessionId
+ let outdir = outdir0 </> show sid
+
+ -- TODO: specify output directory to worker
+ let sess0 = SessionState
+ { sessionConfig = sc
+ , sessionConfigTimeStamp = mod_time
+ , sessionWorker = whdl
+ , sessionOutputDir = outdir
+ , sessionModuleGraph = graph
+ , sessionLastCompilation = rslt
+ }
+
+ registerSession sid sess0
+ return sid
+
+createSession sc@EmptyConfig{} = do
+ starter <- getWorkerStarter
+ working_dir <- io $ getTemporaryDirectory
+ (whdl, rslt, graph) <- startWorker starter working_dir sc
+ outdir0 <- io $ getTemporaryDirectory
+ sid <- genSessionId
+ let outdir = outdir0 </> show sid
+ timestamp <- convert <$> io getCurrentTime
+ -- TODO: specify output directory to worker
+ let sess0 = SessionState
+ { sessionConfig = sc
+ , sessionConfigTimeStamp = timestamp
+ , sessionWorker = whdl
+ , sessionOutputDir = outdir
+ , sessionModuleGraph = graph
+ , sessionLastCompilation = rslt
+ }
+
+ registerSession sid sess0
+ return sid
+
+-- | Stop the session and associated worker.
+destroySession :: SessionId -> ScionM ()
+destroySession sid = do
+ sess <- getSessionState sid
+ _ <- io $ stopWorker (sessionWorker sess) (Just 3)
+ unregisterSession sid
+ return ()
+
+-- | Create a temporary session that is destroyed when the
+-- continuation exits (normally or via an exception).
+withSession :: SessionConfig -> (SessionId -> ScionM a) -> ScionM a
+withSession sconf k = do
+ sid <- createSession sconf
+ k sid `gfinally` (do destroySession sid; unregisterSession sid)
+
+-- | Return messages for each node.
+sessionNotes :: SessionId -> ScionM Notes
+sessionNotes sid = do
+ compilationNotes . sessionLastCompilation <$> getSessionState sid
+
+supportedLanguagesAndExtensions :: ScionM [Extension]
+supportedLanguagesAndExtensions = do
+ exts <- getExtensions
+ case exts of
+ Just e -> return e
+ Nothing -> do
+ withSession (EmptyConfig []) $ \sid -> do
+ wh <- sessionWorker <$> getSessionState sid
+ (ans, _) <- io $ callWorker wh Extensions
+ case ans of
+ AvailExtensions exts -> do
+ setExtensions exts
+ return exts
+
+-- | Notify the worker that a file has changed. The worker will then
+-- update its internal state.
+fileModified :: SessionId -> FilePath -> ScionM ()
+fileModified sid path = do
+ -- TODO: check whether file is actually part of module graph
+ -- TODO: properly merge compilation results
+ st <- getSessionState sid
+ let wh = sessionWorker st
+ (ans, _) <- io $ callWorker wh Reload
+ case ans of
+ CompResult rslt graph -> do
+ modifySessionState sid $ \ss ->
+ (ss{ sessionModuleGraph = graph
+ , sessionLastCompilation = rslt }, ())
+
+
+
+-- -------------------------------------------------------------------
+
+-- Internal: mainly for testing purposes
+ping :: SessionId -> ScionM Bool
+ping sid = do
+ st <- getSessionState sid
+ let wh = sessionWorker st
+ (ans, _) <- io $ callWorker wh Ping {-$ mkMap [("method", "ping")
+ ,("params", MsgNull)
+ ,("id", 42)]-}
+ return $ case ans of Pong -> True; _ -> False --decodeKey ans "result" == Ok ("pong" :: T.Text)
+
+-- Internal: targets are derived from the SessionConfig
+setTargets :: SessionId -> [Target] -> ScionM ()
+setTargets sid _targets = do
+ st <- getSessionState sid
+ let _targets = sessionTargets (sessionConfig st)
+
+ return ()
+
+sessionTargets :: SessionConfig -> [Target]
+sessionTargets FileConfig{ sc_fileName = f} = [FileTarget f]
+sessionTargets CabalConfig{} = []
+
+-- -------------------------------------------------------------------
+
+-- | Start a worker process.
+--
+-- Blocks until the worker is ready.
+startWorker :: WorkerStarter
+ -> FilePath -- ^ Working directory.
+ -> SessionConfig
+ -> ScionM (WorkerHandle, CompilationResult, [ModuleSummary])
+startWorker start_worker homedir conf = do
+ loglvl <- getLogLevel
+ io $ bracketOnError
+ (start_worker homedir [])
+ close_all $
+ \(inp, out, err, proc) -> do
+ hSetBinaryMode inp True
+ hSetBinaryMode out True
+ if loglvl > 2 then forkIO (printFromHandle err) else return undefined
+ -- Wait for worker to start up.
+ wait_for_READY out
+
+ sendMessageToHandle inp conf
+ ok <- recvMessageFromHandle out
+ --killThread dumper
+ case ok of
+ Nothing -> do
+ threadDelay 2000000
+ throwIO $ CannotStartWorker "Wrong worker or worker version"
+ Just (rslt :: CompilationResult, graph :: [ModuleSummary]) ->
+ return
+ (WorkerHandle { workerStdin = inp
+ , workerStdout = out
+ , workerStderr = err
+ , workerProcess = proc
+ , workerFlags = []
+ },
+ rslt, graph)
+ where
+ close_all (inp, out, err, _) =
+ hClose inp >> hClose out >> hClose err
+ wait_for_READY h = do
+ l <- S.hGetLine h
+ if l == str_READY then return () else do
+ -- ignore other lines
+ putStrLn $ "Worker: " ++ show l
+ wait_for_READY h
+
+ str_READY = S.pack (map (fromIntegral . ord) "READY")
+ printFromHandle hdl =
+ handle (\(_e :: IOError) -> return ()) $ do
+ forever $ do
+ hWaitForInput hdl (-1)
+ s <- S.hGetNonBlocking hdl 256
+ hPutStr stderr (show hdl ++ ": ")
+ S.hPutStr stderr s
+
+-- | Stop a worker with optional timeout (in milliseconds).
+--
+-- Send the worker a @quit@ message. If it doesn't respond within the
+-- specified timeout terminate its process. A timeout of @0@
+-- terminates the process immediately.
+--
+-- Note: This function does not block; it returns immediately. You
+-- can block on the returned 'MVar' to wait for the server to exit.
+stopWorker ::
+ WorkerHandle
+ -> Maybe Int -- ^ Timeout in milliseconds. If @Nothing@ a
+ -- default will be used (currently 60s).
+ -> IO (MVar ())
+ -- ^ The returned 'MVar' is written to when the server actually
+ -- stopped.
+stopWorker h mb_timeout = do
+ stopped <- newEmptyMVar
+ let timeout = fromMaybe (60 * 1000) mb_timeout
+
+ thr <- forkIO $ do
+ sendMessageToHandle (workerStdin h) Quit
+ (_ :: Maybe Answer) <- recvMessageFromHandle (workerStdout h)
+ tryPutMVar stopped () >> return ()
+ _ <- forkIO $ do
+ let exact_timeout_us = fromIntegral timeout * 1000 :: Integer
+ timeout_us
+ | exact_timeout_us > fromIntegral (maxBound :: Int) =
+ maxBound
+ | otherwise =
+ fromIntegral exact_timeout_us
+ threadDelay timeout_us
+ exited <- getProcessExitCode (workerProcess h)
+ unless (isJust exited) $ do
+ terminateProcess (workerProcess h)
+ killThread thr
+ tryPutMVar stopped () >> return ()
+ return stopped
+
+-- | Concurrently read lines from the handle until action completes.
+--
+-- Runs the given 'IO' computation and concurrently reads lines from
+-- the handle until the 'IO' computation returns.
+collectLines ::
+ Handle -- ^ The handle to read from.
+ -> IO a -- ^ The computation to run.
+ -> IO (a, L.ByteString)
+ -- ^ Result of the computation and the output that was read while
+ -- the computation was running.
+collectLines h act = do
+ chunks_var <- newMVar []
+ collector <- forkIO $ loop chunks_var
+ result <- act
+ lines_ <- takeMVar chunks_var -- blocks the thread if necessary
+ killThread collector
+ return (result, L.fromChunks $ reverse lines_)
+ where
+ loop var =
+ handle (\(_e :: IOError) -> return ()) $ do
+ hWaitForInput h (-1)
+ modifyMVar_ var $ \cs -> do
+ chunk <- S.hGetNonBlocking h (2*4096)
+ return (chunk:cs)
+ loop var
+
+-- | Invoke an operation on the worker. Waits for worker to respond.
+--
+-- Returns the worker's response and the output it generated.
+callWorker :: WorkerHandle -> Command -> IO (Answer, L.ByteString)
+callWorker h request = do
+ collectLines (workerStderr h) $ do
+ sendMessageToHandle (workerStdin h) request
+ ans_ <- recvMessageFromHandle (workerStdout h)
+ case ans_ of
+ Just ans -> return ans
+ Nothing -> return (Error "callWorker: Could not parse answer")
57 src/Scion/Types/Commands.hs
View
@@ -0,0 +1,57 @@
+module Scion.Types.Commands where
+
+import Scion.Types.Compiler
+import Scion.Types.Session
+
+import Control.Applicative
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+
+data Command
+ = Ping
+ | SetConfig SessionConfig
+ | Quit
+ | Reload
+ | Extensions
+ deriving Show
+
+data Answer
+ = Pong
+ | CompResult CompilationResult [ModuleSummary]
+ | Error String
+ | Quitting
+ | AvailExtensions [Extension]
+ deriving Show
+
+instance Binary Command where
+ put Ping = putWord16le 1
+ put (SetConfig cfg) = putWord16le 2 >> put cfg
+ put Quit = putWord16le 3
+ put Reload = putWord16le 4
+ put Extensions = putWord16le 5
+
+ get = do
+ tag <- getWord16le
+ case tag of
+ 1 -> pure Ping
+ 2 -> SetConfig <$> get
+ 3 -> pure Quit
+ 4 -> pure Reload
+ 5 -> pure Extensions
+
+instance Binary Answer where
+ put Pong = putWord16le 1
+ put (CompResult r g) = putWord16le 2 >> put r >> put g
+ put (Error msg) = putWord16le 3 >> put msg
+ put Quitting = putWord16le 4
+ put (AvailExtensions exts) = putWord16le 5 >> put exts
+
+ get = do
+ tag <- getWord16le
+ case tag of
+ 1 -> pure Pong
+ 2 -> CompResult <$> get <*> get
+ 3 -> Error <$> get
+ 4 -> pure Quitting
+ 5 -> AvailExtensions <$> get
22 src/Scion/Types/Compiler.hs
View
@@ -0,0 +1,22 @@
+module Scion.Types.Compiler where
+
+import Control.Applicative
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.String ( IsString(fromString) )
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+
+newtype Extension = Ext { extensionName :: T.Text }
+ deriving (Eq, Ord)
+
+instance Show Extension where
+ show = T.unpack . extensionName
+
+instance Binary Extension where
+ put (Ext nm) = put (T.encodeUtf8 nm)
+ get = Ext . T.decodeUtf8 <$> get
+
+instance IsString Extension where
+ fromString s = Ext (T.pack s)
142 src/Scion/Types/Monad.hs
View
@@ -0,0 +1,142 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-}
+-- | Definitions concerning the
+module Scion.Types.Monad
+ ( module Scion.Types.Monad,
+ ExceptionMonad(..), MonadIO(..)
+ )
+where
+
+import Scion.Types.Compiler
+import Scion.Types.Session
+
+import Control.Applicative
+import qualified Data.Map as M
+import qualified Data.Text as T
+import Data.IORef
+import MonadUtils -- from GHC
+import Exception -- from GHC
+
+-- * The Scion Monad and Session State
+
+data GlobalState = GlobalState
+ { gsSessions :: M.Map SessionId SessionState
+ , gsNextSessionId :: !SessionId
+ , gsWorkerStarter :: WorkerStarter
+ , gsLogLevel :: Int
+ , gsExtensions :: Maybe [Extension]
+ }
+
+mkGlobalState :: IO (IORef GlobalState)
+mkGlobalState = newIORef
+ GlobalState { gsSessions = M.empty
+ , gsNextSessionId = firstSessionId
+ , gsWorkerStarter = defaultWorkerStarter "scion-worker"
+ , gsLogLevel = 0
+ , gsExtensions = Nothing
+ }
+
+-- | The 'ScionM' monad. It contains the state to manage multiple
+-- active sessions.
+newtype ScionM a
+ = ScionM { unScionM :: IORef GlobalState -> IO a }
+
+runScion :: ScionM a -> IO a
+runScion m = do
+ ref <- mkGlobalState
+ unScionM m ref
+
+instance Monad ScionM where
+ return x = ScionM $ \_ -> return x
+ (ScionM ma) >>= fb = ScionM $ \s -> do
+ a <- ma s
+ unScionM (fb a) s
+ fail msg = error $ "FATAL: " ++ msg --dieHard msg
+
+instance Functor ScionM where
+ fmap f (ScionM ma) = ScionM (fmap f . ma)
+
+instance Applicative ScionM where
+ pure a = ScionM $ \_ -> return a
+ ScionM mf <*> ScionM ma =
+ ScionM $ \s -> do f <- mf s; a <- ma s; return (f a)
+
+liftScionM :: IO a -> ScionM a
+liftScionM m = ScionM $ \_ -> m
+
+getLogLevel :: ScionM Int
+getLogLevel = ScionM $ \r -> gsLogLevel <$> readIORef r
+
+genSessionId :: ScionM SessionId
+genSessionId = ScionM $ \ref ->
+ atomicModifyIORef ref $ \gs ->
+ let !sid = gsNextSessionId gs in
+ (gs{ gsNextSessionId = succ sid }, sid)
+
+-- | Register a 'SessionState' with the given 'SessionId'. (Internal)
+--
+-- Assumes that no other state is registered with this @SessionId@.
+registerSession :: SessionId -> SessionState -> ScionM ()
+registerSession sid sess = ScionM $ \r ->
+ atomicModifyIORef r $ \gs ->
+ let !sessions' = M.insert sid sess (gsSessions gs) in
+ (gs{ gsSessions = sessions' }, ())
+
+-- | Return the state for the 'SessionId'. The session must exist.
+getSessionState :: SessionId -> ScionM SessionState
+getSessionState sid = ScionM $ \r -> do
+ gs <- readIORef r
+ case M.lookup sid (gsSessions gs) of
+ Just s -> return s
+ Nothing -> error $ "Not an active session: " ++ show sid
+
+-- | Unregister a 'SessionId'. NOTE: Does not stop the worker.
+unregisterSession :: SessionId -> ScionM ()
+unregisterSession sid = ScionM $ \r ->
+ atomicModifyIORef r $ \gs ->
+ let !sessions' = M.delete sid (gsSessions gs) in
+ let !gs' = gs{ gsSessions = sessions' } in
+ (gs', ())
+
+-- | Set the function that starts a worker process. See
+-- 'WorkerStarter'.
+setWorkerStarter :: WorkerStarter -> ScionM ()
+setWorkerStarter f = ScionM $ \r ->
+ atomicModifyIORef r $ \gs -> (gs{ gsWorkerStarter = f }, ())
+
+-- | Get the current function that starts a worker process. See
+-- 'WorkerStarter'.
+getWorkerStarter :: ScionM WorkerStarter
+getWorkerStarter =
+ ScionM $ \r -> gsWorkerStarter `fmap` readIORef r
+
+modifySessionState :: SessionId -> (SessionState -> (SessionState, a))
+ -> ScionM a
+modifySessionState sid f = ScionM $ \r ->
+ atomicModifyIORef r $ \gs ->
+ case M.lookup sid (gsSessions gs) of
+ Just ss -> do
+ let (!ss', a) = f ss
+ (gs{ gsSessions = M.insert sid ss' (gsSessions gs) }, a)
+ Nothing ->
+ error $ "modifySessionState: Not an active session: " ++ show sid
+
+getExtensions :: ScionM (Maybe [Extension])
+getExtensions = ScionM $ \r -> gsExtensions <$> readIORef r
+
+setExtensions :: [Extension] -> ScionM ()
+setExtensions exts = ScionM $ \r ->
+ atomicModifyIORef r $ \gs ->
+ (gs{ gsExtensions = Just exts }, ())
+
+instance MonadIO ScionM where
+ liftIO m = liftScionM $ liftIO m
+
+instance ExceptionMonad ScionM where
+ gcatch (ScionM act) handler =
+ ScionM $ \s -> act s `gcatch` (\e -> unScionM (handler e) s)
+ gblock (ScionM act) = ScionM $ \s -> gblock (act s)
+ gunblock (ScionM act) = ScionM $ \s -> gunblock (act s)
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
+{-# INLINE io #-}
229 src/Scion/Types/Note.hs
View
@@ -0,0 +1,229 @@
+module Scion.Types.Note
+ ( -- * Locations
+ Location, LocSource(..), mkLocation, mkNoLoc,
+ locSource, isValidLoc, noLocText, viewLoc,
+ locStartCol, locEndCol, locStartLine, locEndLine,
+ -- ** Absolute FilePaths
+ AbsFilePath(toFilePath), mkAbsFilePath,
+ -- * Notes
+ Note(..), NoteKind(..), Notes
+ -- ** Converting from GHC Notes
+ )
+where
+
+import Control.Applicative
+import Data.Binary
+import qualified Data.MultiSet as MS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import System.FilePath
+
+-- | A note from the compiler or some other tool.
+data Note = Note
+ { noteKind :: NoteKind
+ , noteLoc :: Location
+ , noteMessage :: T.Text
+ } deriving (Eq, Ord, Show)
+
+instance Binary Note where
+ put (Note knd loc msg) = put knd >> put loc >> put (T.encodeUtf8 msg)
+ get = Note <$> get <*> get <*> (T.decodeUtf8 <$> get)
+
+-- | Classifies the kind (or severity) of a note.
+data NoteKind
+ = ErrorNote
+ | WarningNote
+ | InfoNote
+ | OtherNote
+ deriving (Eq, Ord, Show, Enum)
+
+instance Binary NoteKind where
+ put nk = putWord8 (fromIntegral (fromEnum nk))
+ get = toEnum . fromIntegral <$> getWord8
+
+type Notes = MS.MultiSet Note
+
+-- | Represents a 'FilePath' which we know is absolute.
+--
+-- Since relative 'FilePath's depend on the a current working directory we
+-- normalise all paths to absolute paths. Use 'mkAbsFilePath' to create
+-- absolute file paths.
+newtype AbsFilePath = AFP { toFilePath :: FilePath } deriving (Eq, Ord)
+
+instance Binary AbsFilePath where
+ put (AFP fp) = put fp
+ get = AFP <$> get
+
+instance Show AbsFilePath where show (AFP s) = show s
+
+-- | Create an absolute file path given a base directory.
+--
+-- Throws an error if the first argument is not an absolute path.
+mkAbsFilePath :: FilePath -- ^ base directory (must be absolute)
+ -> FilePath -- ^ absolute or relative
+ -> AbsFilePath
+mkAbsFilePath baseDir dir
+ | isAbsolute baseDir = AFP $ normalise $ baseDir </> dir
+ | otherwise =
+ error "mkAbsFilePath: first argument must be an absolute path"
+
+-- | Scion's type for source code locations (regions).
+--
+-- We use a custom location type for two reasons:
+--
+-- 1. We enforce the invariant that the file path of the location is an
+-- absolute path.
+--
+-- 2. Independent evolution from the GHC API.
+--
+-- To save space, the 'Location' type is kept abstract and uses special
+-- cases for notes that span only one line or are only one character wide.
+-- Use 'mkLocation' and 'viewLoc' as well as the respective accessor
+-- functions to construct and destruct nodes.
+--
+-- If no reasonable location info can be given, use the 'mkNoLoc'
+-- function, but be careful not to call 'viewLoc' or any other
+-- accessor function on such a 'Location'.
+--
+data Location
+ = LocOneLine {
+ locSource :: LocSource,
+ locLine :: {-# UNPACK #-} !Int,
+ locSCol :: {-# UNPACK #-} !Int,
+ locECol :: {-# UNPACK #-} !Int
+ }
+ | LocMultiLine {
+ locSource :: LocSource,
+ locSLine :: {-# UNPACK #-} !Int,
+ locELine :: {-# UNPACK #-} !Int,
+ locSCol :: {-# UNPACK #-} !Int,
+ locECol :: {-# UNPACK #-} !Int
+ }
+ | LocPoint {
+ locSource :: LocSource,
+ locLine :: {-# UNPACK #-} !Int,
+ locCol :: {-# UNPACK #-} !Int
+ }
+ | LocNone { noLocText :: String }
+ deriving (Eq, Show)
+
+instance Binary Location where
+ put (LocNone msg) = putWord8 1 >> put msg
+ put loc | (src, l1, c1, l2, c2) <- viewLoc loc =
+ putWord8 2 >> put src >> put l1 >> put c1 >> put l2 >> put c2
+ get = do
+ tag <- getWord8
+ case tag of
+ 1 -> LocNone <$> get
+ 2 -> mkLocation <$> get <*> get <*> get <*> get <*> get
+
+-- | The \"source\" of a location.
+data LocSource
+ = FileSrc AbsFilePath
+ -- ^ The location refers to a position in a file.
+ | OtherSrc String
+ -- ^ The location refers to something else, e.g., the command line, or
+ -- stdin.
+ deriving (Eq, Ord, Show)
+
+instance Binary LocSource where
+ put (FileSrc fp) = putWord8 1 >> put fp
+ put (OtherSrc s) = putWord8 2 >> put s
+ get = do tag <- getWord8
+ case tag of
+ 1 -> FileSrc <$> get
+ 2 -> OtherSrc <$> get
+
+instance Ord Location where compare = cmpLoc
+
+-- | Construct a source code location from start and end point.
+--
+-- If the start point is after the end point, they are swapped
+-- automatically.
+mkLocation :: LocSource
+ -> Int -- ^ start line
+ -> Int -- ^ start column
+ -> Int -- ^ end line
+ -> Int -- ^ end column
+ -> Location
+mkLocation file l0 c0 l1 c1
+ | l0 > l1 = mkLocation file l1 c0 l0 c1
+ | l0 == l1 && c0 > c1 = mkLocation file l0 c1 l1 c0
+ | l0 == l1 = if c0 == c1
+ then LocPoint file l0 c0
+ else LocOneLine file l0 c0 c1
+ | otherwise = LocMultiLine file l0 l1 c0 c1
+
+-- | Construct a source location that does not specify a region. The
+-- argument can be used to give some hint as to why there is no location
+-- available. (E.g., \"File not found\").
+mkNoLoc :: String -> Location
+mkNoLoc msg = LocNone msg
+
+-- | Test whether a location is valid, i.e., not constructed with 'mkNoLoc'.
+isValidLoc :: Location -> Bool
+isValidLoc (LocNone _) = False
+isValidLoc _ = True
+
+noLocError :: String -> a
+noLocError f = error $ f ++ ": argument must not be a noLoc"
+
+-- | Return the start column. Only defined on valid locations.
+locStartCol :: Location -> Int
+locStartCol l@LocPoint{} = locCol l
+locStartCol LocNone{} = noLocError "locStartCol"
+locStartCol l = locSCol l
+
+-- | Return the end column. Only defined on valid locations.
+locEndCol :: Location -> Int
+locEndCol l@LocPoint{} = locCol l
+locEndCol LocNone{} = noLocError "locEndCol"
+locEndCol l = locECol l
+
+-- | Return the start line. Only defined on valid locations.
+locStartLine :: Location -> Int
+locStartLine l@LocMultiLine{} = locSLine l
+locStartLine LocNone{} = noLocError "locStartLine"
+locStartLine l = locLine l
+
+-- | Return the end line. Only defined on valid locations.
+locEndLine :: Location -> Int
+locEndLine l@LocMultiLine{} = locELine l
+locEndLine LocNone{} = noLocError "locEndLine"
+locEndLine l = locLine l
+
+{-# INLINE viewLoc #-}
+-- | View on a (valid) location.
+--
+-- It holds the property:
+--
+-- > prop_viewLoc_mkLoc s l0 c0 l1 c1 =
+-- > viewLoc (mkLocation s l0 c0 l1 c1) == (s, l0, c0, l1, c1)
+--
+viewLoc :: Location
+ -> (LocSource, Int, Int, Int, Int)
+ -- ^ source, start line, start column, end line, end column.
+viewLoc l = (locSource l, locStartLine l, locStartCol l,
+ locEndLine l, locEndCol l)
+
+-- | Comparison function for two 'Location's.
+cmpLoc :: Location -> Location -> Ordering
+cmpLoc LocNone{} _ = LT
+cmpLoc _ LocNone{} = GT
+cmpLoc l1 l2 =
+ (f1 `compare` f2) `thenCmp`
+ (sl1 `compare` sl2) `thenCmp`
+ (sc1 `compare` sc2) `thenCmp`
+ (el1 `compare` el2) `thenCmp`
+ (ec1 `compare` ec2)
+ where
+ (f1, sl1, sc1, el1, ec1) = viewLoc l1
+ (f2, sl2, sc2, el2, ec2) = viewLoc l2
+
+-- | Lexicographic composition two orderings. Compare using the first
+-- ordering, use the second to break ties.
+thenCmp :: Ordering -> Ordering -> Ordering
+thenCmp EQ x = x
+thenCmp x _ = x
+{-# INLINE thenCmp #-}
+
267 src/Scion/Types/Session.hs
View
@@ -0,0 +1,267 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, DeriveDataTypeable,
+ MultiParamTypeClasses #-}
+module Scion.Types.Session where
+
+import Scion.Utils.Convert
+import Scion.Types.Note
+
+import Paths_scion as Info ( version, getBinDir )
+
+import Control.Applicative
+import Control.Exception ( Exception, throwIO )
+import Data.Binary
+import Data.List ( intersperse, intercalate )
+import Data.Monoid
+import qualified Data.MultiSet as MS
+import Data.String ( IsString(fromString) )
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Time.Clock ( UTCTime, NominalDiffTime )
+import Data.Time.Format ( formatTime )
+import Data.Typeable ( Typeable )
+import qualified Distribution.ModuleName as DM
+import System.Directory ( findExecutable, doesFileExist )
+import System.FilePath ( (</>) )
+import System.IO ( Handle )
+import System.Locale ( defaultTimeLocale )
+import System.Process ( ProcessHandle, runInteractiveProcess )
+import Foreign.C.Types ( CTime )
+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+
+newtype SessionId = SessionId Int
+ deriving (Eq, Ord, Enum)
+
+instance Show SessionId where
+ show (SessionId sid) = "sid" ++ show sid
+
+firstSessionId :: SessionId
+firstSessionId = SessionId 1
+
+data Component = Library | Executable String
+ deriving (Eq,Ord,Show)
+instance Binary Component where
+ put Library = putWord8 1
+ put (Executable s) = putWord8 2 >> put s
+ get = do tag <- getWord8
+ case tag of
+ 1 -> return Library
+ 2 -> Executable <$> get
+
+-- | A @WorkerHandle@ contains the state and data structures for
+-- communicating with a worker process.
+data WorkerHandle = WorkerHandle
+ { workerStdin :: Handle
+ , workerStdout :: Handle
+ , workerStderr :: Handle
+ , workerProcess :: ProcessHandle
+ , workerFlags :: [String]
+ }
+
+instance Show WorkerHandle where
+ show w =
+ "<worker in:" ++ show (workerStdin w) ++ " out:"
+ ++ show (workerStdout w) ++ ">"
+
+-- | A @SessionConfig@ describes how a session is to be initialised.
+--
+-- In particular, GHC needs to know about the root modules and static
+-- and dynamic flags.
+data SessionConfig =
+ -- | A single file and command line flags.
+ FileConfig
+ { sc_fileName :: FilePath
+ , sc_flags :: [String]
+ -- ^ Command line flags that would be passed to GHC.
+ }
+ |
+ -- | A configuration based on a @.cabal@ file.
+ CabalConfig
+ { sc_name :: String
+ -- ^ A name for this configuration. This is presented to the
+ -- user, e.g., \"release\", or \"testing\".
+ , sc_cabalFile :: FilePath
+ -- ^ The @.cabal@ file describing the project. This file must
+ -- be located in the root path of the project.
+ , sc_component :: Component
+ -- ^ The library (@Nothing@) or an executable (@Just exeName@).
+ , sc_configFlags :: [String]
+ -- ^ Flags that would be passed to @cabal configure@.
+ }
+ |
+ -- | A configuration with no files.
+ EmptyConfig
+ { sc_flags :: [String] }
+ deriving (Show)
+
+-- | The @SessionState@ contains the cached part of a worker's state.
+data SessionState = SessionState
+ { sessionConfig :: SessionConfig
+ , sessionConfigTimeStamp :: TimeStamp
+ -- ^ The timestamp of the session config.
+ --
+ -- For a 'FileConfig' this is the modification date of the file;
+ -- for a 'CabalConfig' it is the modification date of the @.cabal@
+ -- file.
+ , sessionWorker :: WorkerHandle
+ , sessionOutputDir :: FilePath
+ -- ^ Use this directory for storing any stuff on disk. Due to
+ -- garbage collection we cannot easily take advantage of virtual
+ -- memory. Instead we write most things to disk but rely on I\/O
+ -- caches to speed things up.
+ , sessionModuleGraph :: [ModuleSummary]
+ , sessionLastCompilation :: CompilationResult
+ } deriving (Show)
+
+instance Binary SessionConfig where
+ put (FileConfig f fs) =
+ putWord8 1 >> put f >> put fs
+ put (CabalConfig nm fp comp flags) =
+ putWord8 2 >> put nm >> put fp >> put comp >> put flags
+ put (EmptyConfig fs) =
+ putWord8 3 >> put fs
+ get = do tag <- getWord8
+ case tag of
+ 1 -> FileConfig <$> get <*> get
+ 2 -> CabalConfig <$> get <*> get <*> get <*> get
+ 3 -> EmptyConfig <$> get
+
+
+-- | The concept of \"a point in time\" that we use throughout Scion.
+newtype TimeStamp = TimeStamp { timeStampUTCTime :: UTCTime }
+ deriving (Eq, Ord)
+
+instance Convert CTime TimeStamp where
+ convert epoch =
+ TimeStamp . posixSecondsToUTCTime . realToFrac $ epoch
+
+instance Convert UTCTime TimeStamp where
+ convert = TimeStamp
+
+instance Show TimeStamp where
+ show (TimeStamp t) =
+ formatTime defaultTimeLocale "%Y-%m-%d-%T" t
+
+-- | Function that starts a worker. The arguments are:
+--
+-- 1. The working directory of the worker.
+--
+-- 2. The command line arguments to initialise the GHC API.
+--
+-- The results are the same as for 'System.Process.runInteractiveProcess'.
+type WorkerStarter =
+ FilePath -> [String] -> IO (Handle, Handle, Handle, ProcessHandle)
+
+defaultWorkerStarter :: String -> WorkerStarter
+defaultWorkerStarter workername homedir args = do
+ worker <- do
+ bindir <- Info.getBinDir
+ has_inplace <- doesFileExist (bindir </> workername)
+ if has_inplace then return (bindir </> workername)
+ else do
+ mb_worker <- findExecutable workername
+ case mb_worker of
+ Nothing ->
+ throwIO $ CannotStartWorker $
+ "Executable \"" ++ workername ++ "\" does not exist"
+ Just w -> return w
+ runInteractiveProcess worker (homedir:args) Nothing Nothing
+
+data CannotStartWorker = CannotStartWorker String
+ deriving (Show, Typeable)
+
+instance Exception CannotStartWorker
+
+-- | Scion's own concept of a module name. (Convertible to and from
+-- GHC's and Cabal's versions.)
+newtype ModuleName = ModuleName T.Text
+ deriving (Eq, Ord)
+
+instance IsString ModuleName where
+ fromString = ModuleName . fromString
+
+instance Show ModuleName where
+ show (ModuleName n) = T.unpack n
+
+instance Binary ModuleName where
+ put (ModuleName mn) = put (T.encodeUtf8 mn)
+ get = ModuleName . T.decodeUtf8 <$> get
+
+instance Convert DM.ModuleName ModuleName where
+ convert m = fromString (intercalate "." (DM.components m))
+
+-- | A summary of a module.
+--
+-- This contains top-level information such as module name and
+-- dependencies.
+data ModuleSummary = ModuleSummary
+ { ms_module :: ModuleName
+ , ms_fileType :: HsFileType
+ , ms_imports :: [ModuleName]
+ , ms_location :: FilePath
+ } deriving Eq
+
+instance Show ModuleSummary where
+ show ms =
+ "<summary:" ++ show (ms_module 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
+
+data HsFileType
+ = HaskellFile
+ | HaskellBootFile
+ deriving (Eq, Ord, Show, Enum)
+
+instance Binary HsFileType where
+ put ft = putWord8 (fromIntegral (fromEnum ft))
+ get = toEnum . fromIntegral <$> getWord8
+
+-- -------------------------------------------------------------------
+
+data CompilationResult = CompilationResult {
+ compilationSucceeded :: Bool,
+ compilationNotes :: MS.MultiSet Note,
+ compilationTime :: NominalDiffTime
+ } deriving Show
+
+instance Monoid CompilationResult where
+ mempty = CompilationResult True mempty 0
+ mappend r1 r2 =
+ CompilationResult
+ { compilationSucceeded =
+ compilationSucceeded r1 && compilationSucceeded r2
+ , compilationNotes =
+ compilationNotes r1 `MS.union` compilationNotes r2
+ , compilationTime = compilationTime r1 + compilationTime r2
+ }
+
+instance Binary CompilationResult where
+ put (CompilationResult ok notes time) =
+ put ok >> put (MS.toAscList notes) >> putNominalDiffTime time
+ get = CompilationResult <$> get
+ <*> (MS.fromAscList <$> get)
+ <*> getNominalDiffTime
+
+putNominalDiffTime :: NominalDiffTime -> Put
+putNominalDiffTime t = put (toRational t)
+
+getNominalDiffTime :: Get NominalDiffTime
+getNominalDiffTime = fromRational <$> get
+
+data Target
+ = ModuleTarget ModuleName
+ | FileTarget FilePath
+ | CabalTarget FilePath
+ deriving (Eq, Ord, Show)
+
+instance Binary Target where
+ put (ModuleTarget mn) = putWord8 1 >> put mn
+ put (FileTarget fp) = putWord8 2 >> put fp
+ put (CabalTarget fp) = putWord8 3 >> put fp
+ get = do tag <- getWord8
+ case tag of
+ 1 -> ModuleTarget <$> get
+ 2 -> FileTarget <$> get
+ 3 -> CabalTarget <$> get
69 src/Scion/Types/Worker.hs
View
@@ -0,0 +1,69 @@
+-- | The types used by the worker (which talks to the GHC API.)
+module Scion.Types.Worker
+ ( module Scion.Types.Worker
+ , MonadIO(..), ExceptionMonad(..) )
+where
+
+import Scion.Types.Note ( Note )
+
+import Control.Applicative
+import Data.IORef
+import System.IO
+import Distribution.Simple.LocalBuildInfo
+import GHC ( Ghc, GhcMonad(..) )
+import HscTypes ( WarnLogMonad(..) )
+import MonadUtils ( MonadIO, liftIO )
+import Exception ( ExceptionMonad(..) )
+
+newtype Worker a
+ = Worker { unWorker :: IORef WorkerState -> Ghc a }
+
+data WorkerState = WorkerState
+ { workerLBI :: Maybe LocalBuildInfo
+ , workerLogHandle :: Maybe Handle
+ , workerLogLevel :: Int
+ , workerNewNotes :: IORef [Note]
+ }
+
+mkWorkerState :: IORef [Note] -> IO (IORef WorkerState)
+mkWorkerState r = newIORef $ WorkerState
+ { workerLBI = Nothing
+ , workerLogHandle = Nothing
+ , workerLogLevel = 0
+ , workerNewNotes = r}
+
+instance Functor Worker where
+ fmap f (Worker g) = Worker $ \r -> fmap f (g r)
+
+instance Applicative Worker where
+ pure x = Worker $ \_ -> return x
+ Worker af <*> Worker ax =
+ Worker $ \r -> do f <- af r; x <- ax r; return (f x)
+
+instance Monad Worker where
+ return x = pure x
+ Worker f >>= k = Worker $ \r -> do
+ a <- f r
+ unWorker (k a) r
+
+instance MonadIO Worker where
+ liftIO io = Worker $ \_ -> liftIO io
+
+instance ExceptionMonad Worker where
+ gcatch (Worker act) handler =
+ Worker $ \r -> act r `gcatch` (\e -> unWorker (handler e) r)
+ gblock (Worker act) = Worker $ \r -> gblock (act r)
+ gunblock (Worker act) = Worker $ \r -> gunblock (act r)
+
+instance WarnLogMonad Worker where
+ setWarnings ws = Worker $ \_ -> setWarnings ws
+ getWarnings = Worker $ \_ -> getWarnings
+
+instance GhcMonad Worker where
+ getSession = Worker (\_ -> getSession)
+ setSession s = Worker (\_ -> setSession s)
+
+getAndClearNewNotes :: Worker [Note]
+getAndClearNewNotes = Worker $ \r -> liftIO $ do
+ nn <- workerNewNotes <$> readIORef r
+ atomicModifyIORef nn $ \ns -> ([], ns)
12 src/Scion/Utils/Convert.hs
View
@@ -0,0 +1,12 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Scion.Utils.Convert where
+
+-- | A type class representing things we can convert from and to.
+class Convert from to where
+ convert :: from -> to
+
+instance Convert Int Integer where
+ convert = fromIntegral
+
+instance Convert Integer Int where
+ convert = fromInteger
127 src/Scion/Utils/IO.hs
View
@@ -0,0 +1,127 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Scion.Utils.IO where
+
+import Data.Binary
+import System.IO
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import Control.Applicative
+import Data.Binary
+import Data.Binary.Get ( getWord32le, runGet )
+import Data.Binary.Put ( putWord32le, runPut )
+import Network.Socket hiding (send, sendTo, recv, recvFrom)
+import Network.Socket.ByteString
+import Control.Exception ( handle )
+import GHC.IO.Handle ( hDuplicate, hDuplicateTo )
+import Control.Monad ( when )
+import Data.Maybe ( isJust )
+
+-- | Read a message from the Handle
+recvMessageFromHandle :: Binary a => Handle -> IO (Maybe a)
+recvMessageFromHandle inp =
+ recvMessage (hRecv inp chunkSize)
+
+-- | Read a message from the socket.
+recvMessageFromSocket :: Binary a => Socket -> IO (Maybe a)
+recvMessageFromSocket sock =
+ recvMessage (recv sock chunkSize)
+
+-- | Reads and decodes a message using the given function to retrieve
+-- a chunk.
+--
+-- A message is prefixed with its length (encoded as a 32 bit little
+-- endian value). This is needed because "Data.Binary" does not
+-- provide an iteratee interface (it cannot parse partial input).
+recvMessage :: Binary a =>
+ IO S.ByteString -- ^ Returns a chunk
+ -> IO (Maybe a)
+recvMessage get_chunk = do
+ chunk <- get_chunk
+ if S.length chunk < 4 then return Nothing else do
+ let (len_enc, rest) = S.splitAt 4 chunk
+ let len = runGet getWord32le (L.fromChunks [len_enc])
+ --putStrLn $ "Msg length: " ++ show len
+ Just . decode . L.fromChunks <$> get_chunks len rest
+ where
+ i2w = fromIntegral :: Int -> Word32
+ get_chunks len chunk
+ | S.null chunk =
+ die "socket closed while decoding message"
+ | len > chunk_len = do
+ chunk' <- get_chunk
+ (chunk:) <$> get_chunks (len - chunk_len) chunk'
+ | len == chunk_len =
+ return [chunk]
+ | otherwise =
+ die "input too long"
+ where
+ chunk_len = i2w (S.length chunk)
+
+ -- TODO: we might want to retry
+ _not_enough_input =
+ die "not enough input"
+
+-- | Send a message to the handle.
+sendMessageToHandle :: Binary a => Handle -> a -> IO ()
+sendMessageToHandle out message = do
+ sendMessage (L.hPut out) message
+ hFlush out
+
+sendMessageToSocket :: Binary a => Socket -> a -> IO ()
+sendMessageToSocket sock message =
+ sendMessage (sendMany sock . L.toChunks) message
+
+-- | Sends a message using the given function. The message is sent
+-- using a format readable by 'recvMessage'.
+sendMessage :: Binary a => (L.ByteString -> IO ()) -> a -> IO ()
+sendMessage send_str message_ = do
+ let output = encode message_
+ len_enc = runPut (putWord32le (fromIntegral (L.length output)))
+ --putStrLn $ "Sending: " ++ show (L.unpack len_enc ++ L.unpack output)
+ send_str (L.append len_enc output)
+
+chunkSize :: Int
+chunkSize = 4096
+
+-- | Receive a message from the given handle, blocks if no input is
+-- available.
+hRecv :: Handle
+ -> Int -- ^ Maximum size of returned bytestring.
+ -> IO S.ByteString
+hRecv h size = do
+ handle (\(_e :: IOError) -> do
+ --putStrLn $ "IO Error: " ++ show e
+ return S.empty) $ do
+ -- Note: hWaitForInput tries to decode its input, so we must make
+ -- sure the handle is in binary mode.
+ hWaitForInput h (-1)
+ S.hGetNonBlocking h size
+
+die :: String -> a
+die msg = error $ "FATAL: " ++ msg
+
+-- | Get exclusive access to the first handle's resource.
+--
+-- Subsequent writes to the first handle are redirected to the second
+-- handle. The returned handle is an exclusive handle to the resource
+-- initially held by the first handle.
+makeExclusive ::
+ Handle -- ^ The handle to the resource that we want exclusive
+ -- access to.
+ -> Handle -- ^ Anything written to the original handle will be
+ -- redirected to this one.
+ -> IO Handle -- ^ The exclusive handle.
+makeExclusive hexcl hredirect = do
+ hFlush hexcl
+ hFlush hredirect
+ hresult <- hDuplicate hexcl
+ hDuplicateTo hredirect hexcl
+ return hresult
+
+-- | Ensure that the handle is in binary mode.
+ensureBinaryMode :: Handle -> IO ()
+ensureBinaryMode h = do
+ enc <- hGetEncoding h
+ when (isJust enc) $
+ hSetBinaryMode h True
+
132 src/Scion/Worker/Commands.hs
View
@@ -0,0 +1,132 @@
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+module Scion.Worker.Commands where
+
+import Scion.Types.Compiler
+import Scion.Types.Worker
+import Scion.Types.Commands as C
+import Scion.Types.Session
+import Scion.Utils.Convert
+import Scion.Ghc
+
+import qualified GHC as Ghc
+import qualified DynFlags as Ghc
+import qualified HscTypes as Ghc
+import qualified ErrUtils as Ghc
+import Bag ( unionBags, emptyBag )
+
+import Control.Applicative
+import Data.List ( sort )
+import Data.Time.Clock
+import Data.IORef
+import Data.Monoid
+import Data.String
+import qualified Data.MultiSet as MS
+
+type KeepGoing = Bool
+
+
+handleRequest :: Command -> Worker (Answer, KeepGoing)
+handleRequest cmd = case cmd of
+ Ping ->
+ return (Pong, True)
+ SetConfig _ ->
+ return (C.Error "Can only set config once.", True)
+ Quit ->
+ return (Quitting, False)
+ Reload -> do
+ ans <- CompResult <$> load Ghc.LoadAllTargets
+ <*> moduleGraph
+ return (ans, True)
+ Extensions ->
+ return (AvailExtensions supportedLanguages, True)
+
+supportedLanguages :: [Extension]
+#if __GLASGOW_HASKELL__ >= 700
+supportedLanguages = sort $ map fromString Ghc.supportedLanguagesAndExtensions
+#else
+supportedLanguages = sort $ map fromString Ghc.supportedLanguages
+#endif
+
+-- -------------------------------------------------------------------
+
+-- | Run a computation and measure its run time.
+--
+-- Normally, measures the time until the action returns. The argument
+-- to the callback can be used to stop the timer before the callback
+-- returns. Sample usage:
+--
+-- > withMeasuredTime $ \stop_timer ->
+-- > callFooBar
+-- > if someCondition then stop_time else doSomeMoreWork
+--
+withMeasuredTime :: MonadIO m =>
+ (m () -> m a)
+ -> m (a, NominalDiffTime)
+withMeasuredTime kont = do
+ time <- liftIO $ newIORef . Left =<< getCurrentTime
+ a <- kont (stop_time time)
+ stop_time time
+ Right time_diff <- liftIO $ readIORef time
+ return (a, time_diff)
+ where
+ stop_time time = liftIO $ do
+ t <- readIORef time
+ case t of
+ Left start_time -> do
+ end_time <- getCurrentTime
+ writeIORef time (Right (diffUTCTime end_time start_time))
+ Right _time_diff -> return ()
+
+
+data Messages = Messages Ghc.WarningMessages Ghc.ErrorMessages
+
+instance Monoid Messages where
+ mempty = Messages emptyBag emptyBag
+ Messages ws1 es1 `mappend` Messages ws2 es2 =
+ Messages (ws1 `unionBags` ws2) (es1 `unionBags` es2)
+
+
+-- | Wrapper for 'Ghc.load'.
+load :: Ghc.LoadHowMuch -> Worker CompilationResult
+load how_much = do
+ --msgs <- liftIO $ newIORef (mempty :: Messages)
+ _ <- getAndClearNewNotes
+
+ (res, time_diff)
+ <- withMeasuredTime $ \stop_timer -> do
+ Ghc.load how_much --WithLogger (my_logger msgs) how_much
+ `gcatch` (\(e :: Ghc.SourceError) -> do
+ Ghc.printExceptionAndWarnings e
+ return Ghc.Failed
+ ) --handle_error msgs e)
+
+{-
+ base_dir <- liftIO $ getCurrentDirectory
+ Messages warns errs <- liftIO $ readIORef msgs
+ let notes = ghcMessagesToNotes base_dir (warns, errs)
+-}
+ new_notes <- getAndClearNewNotes
+ let notes = MS.fromList new_notes
+
+ let comp_rslt =
+ case res of
+ Ghc.Succeeded -> CompilationResult True notes time_diff
+ Ghc.Failed -> CompilationResult False notes time_diff
+
+ return comp_rslt
+
+ where
+ --my_logger :: IORef Messages -> Maybe Ghc.SourceError -> Worker ()
+ my_logger msgs err = do
+ let errs = case err of
+ Nothing -> emptyBag
+ Just exc -> Ghc.srcErrorMessages exc
+ warns <- Ghc.getWarnings
+ Ghc.clearWarnings
+ liftIO $ modifyIORef msgs (`mappend` Messages warns errs)
+-- return Ghc.Failed
+ return ()
+
+moduleGraph :: Worker [ModuleSummary]
+moduleGraph = do
+ map convert <$> Ghc.getModuleGraph
435 src/Scion/Worker/Main.hs
View
@@ -0,0 +1,435 @@
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+-- | This is the implementation of a worker.
+--
+module Scion.Worker.Main
+ ( workerMain, soloWorkerMain )
+where
+
+import Scion.Types.Note
+import Scion.Types.Worker
+import Scion.Types.Session
+import Scion.Utils.IO
+import Scion.Utils.Convert
+import Scion.Worker.Commands
+import Scion.Ghc
+
+import qualified GHC as Ghc
+import qualified HscTypes as Ghc
+import DynFlags as Ghc
+import GHC.Paths ( libdir )
+import qualified ErrUtils as Ghc
+import Outputable ( ppr, showSDoc, withPprStyle, SDoc )
+import qualified Outputable as O
+import Exception ( gcatch )
+
+import qualified Distribution.Simple.Configure as C
+import qualified Distribution.PackageDescription as C
+import qualified Distribution.PackageDescription.Parse as C
+import qualified Distribution.Verbosity as C
+import qualified Distribution.Text as C
+import qualified Distribution.Simple.Command as C
+import qualified Distribution.Simple.Setup as C
+import qualified Distribution.Simple.Program as C
+import qualified Distribution.Simple.LocalBuildInfo as C
+import qualified Data.MultiSet as MS
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as C
+import Data.Time.Clock
+import Data.List ( find )
+import Data.String ( fromString )
+import Control.Applicative
+import Control.Exception
+import Data.IORef
+import System.Environment
+import System.FilePath
+import System.IO
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Directory hiding ( getModificationTime )
+import System.PosixCompat.Files ( getFileStatus, modificationTime )
+
+------------------------------------------------------------------------
+--
+-- Compilation worker initialisation sequence:
+--
+-- 1. Server creates worker process with one argument: the working
+-- directory
+--
+-- 2. Worker starts up and sends the ASCII bytes for "READY"
+--
+-- 3. Server sends a SessionConfig.
+--
+-- 4. Worker configures a Cabal project if necessary, then starts up
+-- a GHC session and responds with the compilation result.
+--
+-- After that, the server sends commands and the worker responds.
+-- Some commands may cause the worker to tell the server to restart
+-- the worker. For example:
+--
+-- - The user edited the .cabal file and changed some of the static
+-- flags. Flags can only be set once per process.
+--
+-- - The package database has changed. It may be safe to just
+-- restart the session, but I'm not sure.
+--
+------------------------------------------------------------------------
+
+{-# NOINLINE logfile #-}
+logfile :: Handle
+logfile = unsafePerformIO $ do
+ path <- getAppUserDataDirectory "scion"
+ openFile (path </> "worker-log") AppendMode
+
+debugMsg :: MonadIO m => String -> m ()
+debugMsg msg =
+ liftIO (do hPutStrLn stderr msg >> hFlush stderr
+ hPutStrLn logfile msg >> hFlush logfile)
+
+workerMain :: Int -> IO ()
+workerMain n =
+ handle (\(e :: SomeException) -> debugMsg (show e)) $
+ workerMain' n
+
+workerMain' :: Int -> IO ()
+workerMain' n = do
+ -- 1. We will use stdin/stdout to communicate with the server.
+ -- stderr will be used for logging.
+ let inp = stdin
+ out <- makeExclusive stdout stderr
+ mapM_ ensureBinaryMode [inp, out]
+ hSetBuffering stderr LineBuffering
+ hSetBuffering stdout LineBuffering
+ hFlush stderr
+
+ hPutStrLn stdout "test"
+ debugMsg "=== Starting worker =============================="
+
+ -- The arguments are the working directory and GHC flags.
+ args <- getArgs
+ debugMsg $ "Args: " ++ show args
+ let worker_dir:_other_args = args
+ setCurrentDirectory worker_dir
+ debugMsg $ "Worker dir: " ++ worker_dir
+
+ debugMsg "Sending READY"
+
+ C.hPut out (C.pack "READY\n")
+ hFlush out
+
+ debugMsg "Receiving SessionConfig ..."
+
+ msg0 <- recvMessageFromHandle inp
+ case (msg0 :: Maybe SessionConfig) of
+ Just sess_conf -> do
+ debugMsg $ "OK: " ++ show sess_conf
+ --let sess_conf = FileConfig {sc_fileName = "tests/projects/file001.hs", sc_flags = []}
+ initWorker sess_conf debugMsg (main_loop inp out)
+ return ()
+ Nothing -> do
+ debugMsg "ERROR"
+ return ()
+
+main_loop :: Handle -> Handle
+ -> CompilationResult -> Worker ()
+main_loop inp out rslt0 = do
+-- initWorkerLogging debug
+ graph <- moduleGraph
+ liftIO $ sendMessageToHandle out (rslt0, graph)
+-- liftIO $ sendMessageToHandle out "STARTUP_OK"
+ loop
+ --cleanupWorker
+ where
+ loop = do
+ msg_ <- liftIO $ recvMessageFromHandle inp
+ case msg_ of
+ Nothing -> do
+ debugMsg $ "Could not decode message, exiting"
+ return ()
+ Just msg -> do
+ debugMsg $ "in: " ++ show msg
+ (ans, keep_going) <- handleRequest msg
+ debugMsg $ "out: " ++ show ans
+ liftIO $ sendMessageToHandle out ans
+ if keep_going then loop else return ()
+
+workerFail :: MonadIO m => String -> m a
+workerFail msg =
+ liftIO (hPutStrLn stderr msg >> hFlush stderr) >>
+ error msg
+
+-- | Return the build directory based on the path of the package.
+--
+-- TODO: Use global configuration file.
+scionDistDir :: FilePath -> FilePath
+scionDistDir f = f </> ".dist-scion"
+
+
+-- | Start up a worker for the given session config.
+initWorker :: SessionConfig
+ -> (String -> IO ())
+ -> (CompilationResult -> Worker a) -- ^ The continuation (the main worker loop).
+ -> IO a
+
+initWorker EmptyConfig{ sc_flags = args0 } debugMsg kont = do
+ let args1 = map (Ghc.mkGeneralLocated ("<config:no-location>")) args0
+ initGhcSession [] args1 debugMsg kont
+
+initWorker FileConfig{ sc_fileName = file0, sc_flags = args0 } debugMsg kont = do
+ let args1 = map (Ghc.mkGeneralLocated ("<config:" ++ file0 ++ ">")) args0
+ file <- (</> file0) <$> getCurrentDirectory
+ debugMsg "Calling initGhcSession"
+ initGhcSession [FileTarget file] args1 debugMsg kont
+
+initWorker conf@CabalConfig{} debugMsg kont = do
+ -- TODO: read or create local build info in order to get to the
+ -- command line arguments. Then do same stuff as below.
+ cabal_file <- (</> sc_cabalFile conf) <$> getCurrentDirectory
+ cf_exists <- doesFileExist cabal_file
+ if not cf_exists then workerFail $ "Cabal file not found: " ++ cabal_file
+ else do
+ (lbi, stamp) <- maybeConfigureCabal cabal_file (sc_configFlags conf)
+ (scionDistDir (dropFileName cabal_file))
+
+ let comp = sc_component conf
+ case getComponentInfo lbi comp of
+ Nothing -> workerFail $ "Component `" ++ show comp
+ ++ "' not found in " ++ cabal_file
+ Just (lib_or_exe, clbi, bi) -> do
+ let targets | Left lib <- lib_or_exe
+ = map (ModuleTarget . convert) (C.libModules lib)
+ args = [] -- TODO:
+
+ initGhcSession targets args debugMsg kont
+
+
+-- TODO: refine behaviour based on GHC's ghc/Main.hs
+initGhcSession :: [Target] -> [Ghc.Located String]
+ -> (String -> IO ())
+ -> (CompilationResult -> Worker a) -> IO a
+initGhcSession targets args1 debugMsg kont = do
+ -- TODO: check whether file exists
+ debugMsg $ "GHC Args: " ++ show (map Ghc.unLoc args1)
+
+ -- handles Ctrl-C and GHC panics and suchlike
+ Ghc.defaultErrorHandler Ghc.defaultDynFlags $ do
+
+ -- 1. Initialise all the static flags
+ debugMsg "Parsing static flags"
+ (args2, static_flag_warns) <- Ghc.parseStaticFlags args1
+ debugMsg $ "Static flag warnings: " ++
+ show (map (show . Ghc.unLoc) static_flag_warns)
+
+ Ghc.runGhc (Just libdir) $ do
+
+ -- 2. Now initialise the dynamic stuff
+ dflags0 <- Ghc.getSessionDynFlags
+
+ notes_ref <- liftIO $ newIORef []
+ base_dir <- liftIO $ getCurrentDirectory
+
+ let addNote :: NoteKind -> Ghc.SrcSpan -> SDoc -> IO ()
+ addNote nkind loc msg =
+ let note = Note { noteKind = nkind
+ , noteLoc = ghcSpanToLocation base_dir loc
+ , noteMessage = fromString (showSDoc msg) } in
+ atomicModifyIORef notes_ref $ \ns ->
+ (note : ns, ())
+
+
+ let msg_text loc sty msg =
+ showSDoc (O.hang (ppr loc) 8 (withPprStyle sty msg))
+
+ my_log_action severity loc sty msg = do
+ case severity of
+ --Ghc.SevOutput -> debugMsg $ "OUT: " ++ msg_text loc sty msg
+ Ghc.SevWarning -> do
+ debugMsg $ "WARN: " ++ msg_text loc sty msg
+ addNote WarningNote loc (withPprStyle sty msg)
+ Ghc.SevError -> do
+ debugMsg $ "ERR: " ++ msg_text loc sty msg
+ addNote ErrorNote loc (withPprStyle sty msg)
+ Ghc.SevInfo -> debugMsg $ "INFO: " ++ msg_text loc sty msg
+ Ghc.SevFatal -> debugMsg $ "FATAL: " ++ msg_text loc sty msg
+ _ -> debugMsg $ "OUT: " ++ msg_text loc sty msg
+ let dflags1 =
+ dflags0{ ghcMode = CompManager
+ , hscTarget = HscNothing
+ , ghcLink = LinkInMemory
+ , log_action = my_log_action
+ }
+
+ (dflags2, _fileargs, dyn_flag_warns)
+ <- Ghc.parseDynamicFlags dflags1 args2
+
+ let flag_warns = static_flag_warns ++ dyn_flag_warns
+ liftIO $ debugMsg $ "Flag warnings: " ++
+ show (map (show . Ghc.unLoc) flag_warns)
+
+ Ghc.defaultCleanupHandler dflags2 $ do
+
+ _ <- Ghc.setSessionDynFlags dflags2
+
+ let targets' = (map convert targets)
+ liftIO $ debugMsg $ "Setting targets: " ++ show targets
+ Ghc.setTargets targets'
+
+ r <- liftIO $ mkWorkerState notes_ref
+ unWorker (load Ghc.LoadAllTargets >>= kont) r
+
+-- | Configure Cabal project if necessary. It is necessary if:
+--
+-- - No local build config exists, or
+--
+-- - The Cabal file is newer than the build config, or
+--
+-- - Other local build config dependencies changed (e.g., compiler
+-- version, Cabal version, etc.)
+--
+maybeConfigureCabal ::
+ FilePath -- ^ The @.cabal@ file.
+ -> [String] -- ^ Arguments to @cabal configure@
+ -> FilePath -- ^ Build directory (e.g., @./dist/@)
+ -> IO (C.LocalBuildInfo, TimeStamp)
+maybeConfigureCabal cabal_file config_flags odir = do
+ lbi_or_err <- try $ C.getPersistBuildConfig odir
+ case lbi_or_err of
+ Left (_e :: IOException) -> conf
+ Right lbi -> do
+ is_old <- checkPersistBuildConfigOutdated odir cabal_file
+ if is_old then conf else do
+ t <- getModificationTime (C.localBuildInfoFile odir)
+ return (lbi, t)
+ where
+ conf = configureCabal cabal_file config_flags odir
+
+checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool
+-- #if MIN_VERSION_Cabal(1,10,0)
+-- checkPersistBuildConfigOutdated = C.checkPersistBuildConfigOutdated
+-- #else
+checkPersistBuildConfigOutdated distPref pkg_descr_file = do
+ t0 <- getModificationTime pkg_descr_file
+ t1 <- getModificationTime $ C.localBuildInfoFile distPref
+ return (t0 > t1)
+-- #endif
+
+-- TODO: Move into separate module. Scion.FileUtils maybe?
+getModificationTime :: FilePath -> IO TimeStamp
+getModificationTime file =
+ convert . modificationTime <$> getFileStatus file
+
+-- | Make sure the given Cabal project is configured.
+--
+-- TODO: handle failure
+configureCabal :: FilePath -- ^ The @.cabal@ file.
+ -> [String] -- ^ Arguments to @cabal configure@
+ -> FilePath
+ -> IO (C.LocalBuildInfo, TimeStamp)
+configureCabal cabal_file0 config_flags odir = do
+ dir0 <- getCurrentDirectory
+
+ -- 1. Make sure the .cabal file is an absolute path name.
+ let cabal_file = dir0 </> cabal_file0
+
+ -- 2. Cabal typically assumes to be in the same directory as the
+ -- .cabal file
+ setCurrentDirectory (dropFileName cabal_file)
+
+ -- 3. Convince Cabal to parse a @configure ...stuff..@ command line.
+ gen_pkg_descr <- C.readPackageDescription C.normal cabal_file
+ cf0 <- case C.commandsRun confCmd commands config_flags of
+ C.CommandReadyToGo (flags_, _args) -> return flags_
+ -- TODO: Better error messages.
+ _ -> throwIO $ userError "Could not parse config flags."
+
+ -- 4. Now we do Cabal's configuration step.
+ -- TODO: We should probably specify the version of GHC more tightly.
+ let conf_flags =
+ cf0{ C.configDistPref = C.toFlag odir }
+ lcl_build_info <- C.configure (gen_pkg_descr, C.emptyHookedBuildInfo)
+ conf_flags
+
+ -- 5. Always write the result
+ C.writePersistBuildConfig odir lcl_build_info
+
+ -- Create timestamp *after* writing the file. Thus if we later
+ -- check if the file is up to date using this timestamp, it is
+ -- considered up to date. (Can this happen?)
+ --
+ -- TODO: It may be more robust to get the timestamp from the file.
+ timestamp <- convert <$> getCurrentTime
+ -- 6. Revert back to the original directory
+ setCurrentDirectory dir0
+
+ return (lcl_build_info, timestamp)
+ where
+ confCmd :: C.CommandUI C.ConfigFlags
+ confCmd = C.configureCommand C.defaultProgramConfiguration
+
+ commands = [ confCmd `C.commandAddAction` \fs as -> (fs, as) ]
+
+
+getComponentInfo :: C.LocalBuildInfo -> Component
+ -> Maybe (Either C.Library C.Executable,
+ C.ComponentLocalBuildInfo,
+ C.BuildInfo)
+getComponentInfo lbi Library =
+ let lib = C.library (C.localPkgDescr lbi) in
+ (,,) <$> (Left <$> lib)
+ <*> C.libraryConfig lbi
+ <*> (C.libBuildInfo <$> lib)
+
+getComponentInfo lbi (Executable exename) =
+ (,,) <$> (Right <$> exe) <*> exe_clbi <*> exe_bi
+ where
+ exe_clbi =
+ snd <$> find ((==exename) . fst) (C.executableConfigs lbi)
+ exe = find ((==exename) . C.exeName)
+ (C.executables (C.localPkgDescr lbi))
+ exe_bi = C.buildInfo <$> exe
+
+
+-- -------------------------------------------------------------------
+
+soloWorkerMain :: IO ()
+soloWorkerMain = do
+ -- 1. We will use stdin/stdout to communicate with the server.
+ -- stderr will be used for logging.
+ let inp = stdin
+ --out <- makeExclusive stdout stderr
+ let out = stdout
+ mapM_ ensureBinaryMode [inp] --, out]
+ hSetBuffering stderr LineBuffering
+ hSetBuffering stdout LineBuffering
+ hFlush stderr
+
+ hPutStrLn stdout "test"
+ debugMsg "=== Starting worker =============================="
+
+ -- The arguments are the working directory and GHC flags.
+ let args = ["tests/projects/"]
+-- args <- getArgs
+ debugMsg $ "Args: " ++ show args
+ let worker_dir:_other_args = args
+ setCurrentDirectory worker_dir
+ debugMsg $ "Worker dir: " ++ worker_dir
+
+-- debugMsg "Sending READY"
+-- C.hPut out (C.pack "READY\n")
+-- hFlush out
+
+ debugMsg "Receiving SessionConfig ..."
+
+-- msg0 <- recvMessageFromHandle inp
+-- case (msg0 :: Maybe SessionConfig) of
+-- Just sess_conf -> do
+ let sess_conf = FileConfig {sc_fileName = "tests/projects/file001.hs", sc_flags = []}
+ debugMsg $ "OK: " ++ show sess_conf
+
+ initWorker sess_conf debugMsg (main_loop inp out)
+ return ()
+
+{-
+ Nothing -> do
+ debugMsg "ERROR"
+ return ()
+-}
13 src/Server.hs
View
@@ -0,0 +1,13 @@
+module Main where
+
+import Scion.Types.Monad
+import Scion.Types.Session
+import Scion.Session
+
+import qualified Data.MultiSet as MS
+
+main = runScion $ do
+ sid <- createSession (FileConfig "tests/projects/file001.hs" ["-Wall"])
+ ok <- ping sid
+ io . print . MS.size =<< sessionNotes sid
+ io (print ok)
35 test/TestSuite.hs
View
@@ -0,0 +1,35 @@
+module Main ( main ) where
+
+import Scion.Types.Monad
+import Scion.Types.Session
+import Scion.Session
+
+import Data.String
+import qualified Data.MultiSet as MS
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit
+import System.FilePath ( (</>) )
+
+main = defaultMain tests
+
+file_config001 p =
+ FileConfig (p </> "tests" </> "projects" </> "file001.hs") []
+
+file_config002 p =
+ FileConfig (p </> "tests" </> "projects" </> "file001.hs") ["-Wall"]
+
+tests =
+ [ testCase "ping" $ runScion $ do
+ withSession (file_config001 ".") $ \sid -> do
+ ok <- ping sid
+ io $ assertBool "Answer to ping must be pong." ok,
+ testCase "notes" $ runScion $ do
+ withSession (file_config002 ".") $ \sid -> do
+ notes <- sessionNotes sid
+ io $ MS.size notes @?= 2,
+ testCase "exts" $ runScion $ do
+ withSession (file_config001 ".") $ \sid -> do
+ exts <- supportedLanguagesAndExtensions
+ io $ assertBool "There should be some supported extensions." (length exts > 0)
+ ]
1  tests/projects/file001.hs
View
@@ -0,0 +1 @@
+main = print 42
Please sign in to comment.
Something went wrong with that request. Please try again.