Skip to content

Loading…

Add compatibility for GHC 7.2.x #12

Merged
merged 7 commits into from

3 participants

@maoe

I made Scion compatible for GHC 7.2.x. The summary is below:

  • Supported the new GHC API.
  • Added fail to the pattern matches which are non exhaustive.
  • Added -fcontext-stack=30 flag so that the bug-fixed atto-lisp can be compiled.
@hvr

...are you planning on implementing support for GHC-7.4.x as well in the near future?

@maoe

Sorry for late reply. Nice work!

@nominolo
Owner

OK, thanks guys. Scion is currently blocked on a proper make system which is why I was holding off on these.

I started my own called cake, but since Neil rewrote his original shake as an open source project I'm going to join forces with Neil and make sure that shake has all the features Scion may need from it (most importantly robustness).

That, however, is going to take a few months to finish, so I'm going to just merge both of your pull requests (and hope they work).

@nominolo nominolo merged commit b78e9e7 into nominolo:master
@hvr
hvr commented

(and hope they work)

@nominolo fyi, they do work, except that I just noticed that with GHC-7.4.0 the cpu usage for the scion processes goes up to 100% (but apart from that it seems to work fine w/ GHC-7.4.0)

@nominolo
Owner

Well, 100% CPU sounds bad. Can you file a bug and description for how to reproduce?

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Oct 25, 2011
  1. @maoe
Commits on Nov 19, 2011
  1. @maoe

    Eliminate warnings on GHC 7.2

    maoe committed
  2. @maoe

    Add -fcontext-stack=30 flag to scion-server

    maoe committed
    This flag will be needed by upcoming atto-lisp.
Commits on Nov 20, 2011
  1. @maoe
  2. @maoe

    Small cleanup

    maoe committed
  3. @maoe

    Relax dependency on attoparsec

    maoe committed
  4. @maoe

    Fix typos

    maoe committed
View
3 scion.cabal
@@ -105,10 +105,11 @@ executable scion-server
build-depends:
scion,
atto-lisp >= 0.2 && < 0.3,
- attoparsec >= 0.8.5.1 && < 0.9,
+ attoparsec >= 0.8.5.1 && < 0.10,
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,
canonical-filepath == 1.0.*
+ ghc-options: -fcontext-stack=30
View
10 src-execs/Server.hs
@@ -11,7 +11,7 @@ import Scion.Cabal
import Scion.Session
import Control.Applicative
---import Control.Exception ( throwIO, handle, IOException )
+import Control.Exception ( catch )
import Data.AttoLisp ( FromLisp(..), ToLisp(..) )
import Data.Bits ( shiftL, (.|.) )
import Data.Maybe ( isNothing )
@@ -22,6 +22,7 @@ import Network ( listenOn, PortID(..) )
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import Numeric ( showHex )
+import Prelude hiding (catch)
import System.IO
import System.FilePath.Canonical
import qualified Network.Socket.ByteString.Lazy as NL
@@ -29,7 +30,8 @@ import qualified Data.AttoLisp as L
import qualified Data.Attoparsec as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Char8 as S ( pack )
+import qualified Data.ByteString.Char8 as S ( pack, putStrLn )
+import qualified Data.ByteString.Lazy.Char8 as L ( putStrLn )
import qualified Data.MultiSet as MS
import qualified Data.Text as T
@@ -93,7 +95,7 @@ mainLoop sock Lisp = runScion $ do
Just len -> do
msg <- io $ recv sock len
io $ putStr $ "==> [" ++ show len ++ "] "
- io $ B.putStrLn msg
+ io $ S.putStrLn msg
case parseRequest msg of
Left err_msg -> do
io $ putStrLn $ "ParseError: " ++ err_msg
@@ -123,7 +125,7 @@ sendResponse sock reqId resp =
in do
let len = (fromIntegral $ BL.length str)
putStr $ "<== [" ++ show len ++ "] "
- BL.putStrLn str
+ L.putStrLn str
n <- send sock (encodeLen len)
m <- NL.send sock str
putStrLn $ " [Sent: " ++ show n ++ "+" ++ show m ++ "]"
View
1 src-execs/Worker.hs
@@ -2,5 +2,6 @@ module Main where
import Scion.Worker.Main ( workerMain )
+main :: IO ()
main = workerMain 42
--main = soloWorkerMain
View
12 src/Scion/Cabal.hs
@@ -20,11 +20,9 @@ import Control.Monad ( when )
import Distribution.PackageDescription.Parse
import Distribution.Simple.Build ( initialBuildSteps )
import Distribution.Simple.Configure
-import Distribution.Simple.LocalBuildInfo hiding ( libdir )
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Parse as PD
import qualified Distribution.PackageDescription.Configuration as PD
-import Distribution.Simple.PreProcess ( knownSuffixHandlers )
import Distribution.Simple.Program
import Distribution.Simple.Setup ( defaultConfigFlags,
ConfigFlags(..), Flag(..) )
@@ -34,6 +32,13 @@ import System.Directory
import System.Exit ( ExitCode(..) )
import System.FilePath ( dropFileName, takeBaseName )
+#if __GLASGOW_HASKELL__ >= 702
+import Distribution.Simple.LocalBuildInfo hiding ( Component, libdir )
+#else
+import Distribution.Simple.LocalBuildInfo hiding ( libdir )
+import Distribution.Simple.PreProcess ( knownSuffixHandlers )
+#endif
+
-- | Something went wrong inside Cabal.
data CabalException = CabalException String
deriving (Typeable)
@@ -115,8 +120,11 @@ configureCabalProject conf@CabalConfig{} build_dir = do
config_flags
writePersistBuildConfig build_dir lbi
initialBuildSteps build_dir (localPkgDescr lbi) lbi V.normal
+#if __GLASGOW_HASKELL__ < 702
knownSuffixHandlers
+#endif
return lbi
+configureCabalProject _ _ = fail "configureCabalProject: invalid config type"
availableComponents :: PD.PackageDescription -> [Component]
availableComponents pd =
View
30 src/Scion/Ghc.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Scion.Ghc
( -- * Converting from GHC error messages
ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote,
@@ -33,6 +34,22 @@ import System.FilePath.Canonical
ghcSpanToLocation :: FilePath -- ^ Base directory
-> Ghc.SrcSpan
-> Location
+#if __GLASGOW_HASKELL__ >= 702
+ghcSpanToLocation baseDir sp@(Ghc.RealSrcSpan rsp)
+ | Ghc.isGoodSrcSpan sp =
+ mkLocation mkLocFile
+ (Ghc.srcSpanStartLine rsp)
+ (ghcColToScionCol $ Ghc.srcSpanStartCol rsp)
+ (Ghc.srcSpanEndLine rsp)
+ (ghcColToScionCol $ Ghc.srcSpanEndCol rsp)
+ where
+ mkLocFile =
+ case Ghc.unpackFS (Ghc.srcSpanFile rsp) of
+ s@('<':_) -> OtherSrc s
+ p -> FileSrc $ mkAbsFilePath baseDir p
+ghcSpanToLocation _baseDir sp =
+ mkNoLoc (Ghc.showSDoc (Ghc.ppr sp))
+#else
ghcSpanToLocation baseDir sp
| Ghc.isGoodSrcSpan sp =
mkLocation mkLocFile
@@ -42,11 +59,12 @@ ghcSpanToLocation baseDir sp
(ghcColToScionCol $ Ghc.srcSpanEndCol sp)
| otherwise =
mkNoLoc (Ghc.showSDoc (Ghc.ppr sp))
- where
- mkLocFile =
- case Ghc.unpackFS (Ghc.srcSpanFile sp) of
+ where
+ mkLocFile =
+ case Ghc.unpackFS (Ghc.srcSpanFile sp) of
s@('<':_) -> OtherSrc s
p -> FileSrc $ mkAbsFilePath baseDir p
+#endif
ghcErrMsgToNote :: FilePath -> Ghc.ErrMsg -> Note
ghcErrMsgToNote = ghcMsgToNote ErrorNote
@@ -92,6 +110,7 @@ fromGhcModSummary ms = do
, ms_fileType = case Ghc.ms_hsc_src ms of
Ghc.HsSrcFile -> HaskellFile
Ghc.HsBootFile -> HaskellBootFile
+ Ghc.ExtCoreFile -> ExternalCoreFile
, ms_imports =
map (convert . Ghc.unLoc
. Ghc.ideclName . Ghc.unLoc) (Ghc.ms_imps ms)
@@ -117,6 +136,11 @@ targetToGhcTarget (FileTarget path) =
, Ghc.targetAllowObjCode = True
, Ghc.targetContents = Nothing
}
+targetToGhcTarget (CabalTarget path) =
+ Ghc.Target { Ghc.targetId = Ghc.TargetFile path Nothing
+ , Ghc.targetAllowObjCode = False
+ , Ghc.targetContents = Nothing
+ }
instance Convert ModuleName Ghc.ModuleName where
convert (ModuleName s) = Ghc.mkModuleName (T.unpack s)
View
24 src/Scion/Session.hs
@@ -28,7 +28,6 @@ import Scion.Cabal ( CabalException )
import Control.Applicative
import Control.Concurrent
-import Control.Exception ( throwIO )
import Control.Monad ( when, unless, forever, filterM )
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
@@ -36,20 +35,17 @@ 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 )
import System.Exit ( ExitCode(..) )
import System.FilePath ( dropFileName, (</>), takeFileName,
- makeRelative, takeDirectory )
+ 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.
@@ -187,14 +183,15 @@ supportedLanguagesAndExtensions = do
wh <- sessionWorker <$> getSessionState sid
(ans, _) <- io $ callWorker wh Extensions
case ans of
- AvailExtensions exts -> do
- setExtensions exts
- return exts
+ AvailExtensions exts' -> do
+ setExtensions exts'
+ return exts'
+ _ -> fail "supportedLanguagesAndExtensions: invalid answer"
-- | Notify the worker that a file has changed. The worker will then
-- update its internal state.
fileModified :: SessionId -> FilePath -> ScionM ()
-fileModified sid path = do
+fileModified sid _path = do
-- TODO: check whether file is actually part of module graph
-- TODO: properly merge compilation results
st <- getSessionState sid
@@ -205,6 +202,7 @@ fileModified sid path = do
modifySessionState sid $ \ss ->
(ss{ sessionModuleGraph = graph
, sessionLastCompilation = rslt }, ())
+ _ -> fail "fileModified: invalid answer"
@@ -230,7 +228,7 @@ setTargets sid _targets = do
sessionTargets :: SessionConfig -> [Target]
sessionTargets FileConfig{ sc_fileName = f} = [FileTarget f]
-sessionTargets CabalConfig{} = []
+sessionTargets _ = []
-- -------------------------------------------------------------------
@@ -249,7 +247,7 @@ startWorker start_worker homedir conf = do
\(inp, out, err, proc) -> do
hSetBinaryMode inp True
hSetBinaryMode out True
- if verb >= deafening then forkIO (printFromHandle err) else return undefined
+ _ <- if verb >= deafening then forkIO (printFromHandle err) else return undefined
-- Wait for worker to start up.
wait_for_READY out
@@ -286,7 +284,7 @@ startWorker start_worker homedir conf = do
printFromHandle hdl =
handle (\(_e :: IOError) -> return ()) $ do
forever $ do
- hWaitForInput hdl (-1)
+ _ <- hWaitForInput hdl (-1)
s <- S.hGetNonBlocking hdl 256
hPutStr stderr (show hdl ++ ": ")
S.hPutStr stderr s
@@ -349,7 +347,7 @@ collectLines h act = do
where
loop var =
handle (\(_e :: IOError) -> return ()) $ do
- hWaitForInput h (-1)
+ _ <- hWaitForInput h (-1)
modifyMVar_ var $ \cs -> do
chunk <- S.hGetNonBlocking h (2*4096)
return (chunk:cs)
View
2 src/Scion/Types/Commands.hs
@@ -39,6 +39,7 @@ instance Binary Command where
3 -> pure Quit
4 -> pure Reload
5 -> pure Extensions
+ _ -> fail "Binary Command get: tag error"
instance Binary Answer where
put Pong = putWord16le 1
@@ -55,3 +56,4 @@ instance Binary Answer where
3 -> Error <$> get
4 -> pure Quitting
5 -> AvailExtensions <$> get
+ _ -> fail "Binary Answer get: tag error"
View
1 src/Scion/Types/Compiler.hs
@@ -3,7 +3,6 @@ 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
View
3 src/Scion/Types/Monad.hs
@@ -13,10 +13,7 @@ import Scion.Types.Core
import Control.Applicative
import Control.Monad ( when )
import qualified Data.Map as M
-import qualified Data.Text as T
import Data.IORef
-import MonadUtils -- from GHC
-import Exception -- from GHC
import System.IO ( hFlush, stdout )
-- * The Scion Monad and Session State
View
2 src/Scion/Types/Note.hs
@@ -120,6 +120,7 @@ instance Binary Location where
case tag of
1 -> LocNone <$> get
2 -> mkLocation <$> get <*> get <*> get <*> get <*> get
+ _ -> fail "Binary Location get: tag error"
-- | The \"source\" of a location.
data LocSource
@@ -137,6 +138,7 @@ instance Binary LocSource where
case tag of
1 -> FileSrc <$> get
2 -> OtherSrc <$> get
+ _ -> fail "Binary LocSource get: tag error"
instance Ord Location where compare = cmpLoc
View
5 src/Scion/Types/Session.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, DeriveDataTypeable,
MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Scion.Types.Session
( module Scion.Types.Session
, module Scion.Types.Core
@@ -57,6 +58,7 @@ instance Binary Component where
case tag of
1 -> return Library
2 -> Executable <$> get
+ _ -> fail "Binary Component get: tag error"
-- | A @WorkerHandle@ contains the state and data structures for
-- communicating with a worker process.
@@ -152,6 +154,7 @@ instance Binary SessionConfig where
1 -> FileConfig <$> get <*> get
2 -> CabalConfig <$> get <*> get <*> get <*> get <*> get
3 -> EmptyConfig <$> get
+ _ -> fail "Binary SessionConfig get: tag error"
-- | The concept of \"a point in time\" that we use throughout Scion.
@@ -249,6 +252,7 @@ instance Binary CanonicalFilePath where
data HsFileType
= HaskellFile
| HaskellBootFile
+ | ExternalCoreFile
deriving (Eq, Ord, Show, Enum)
instance Binary HsFileType where
@@ -302,3 +306,4 @@ instance Binary Target where
1 -> ModuleTarget <$> get
2 -> FileTarget <$> get
3 -> CabalTarget <$> get
+ _ -> fail "Binary Target get: tag error"
View
5 src/Scion/Types/Worker.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-- | The types used by the worker (which talks to the GHC API.)
module Scion.Types.Worker
( module Scion.Types.Worker
@@ -14,9 +15,11 @@ import Data.IORef
import System.IO
import Distribution.Simple.LocalBuildInfo
import GHC ( Ghc, GhcMonad(..) )
+#if __GLASGOW_HASKELL__ < 702
import HscTypes ( WarnLogMonad(..) )
import MonadUtils ( MonadIO, liftIO )
import Exception ( ExceptionMonad(..) )
+#endif
newtype Worker a
= Worker { unWorker :: IORef WorkerState -> Ghc a }
@@ -58,9 +61,11 @@ instance ExceptionMonad Worker where
gblock (Worker act) = Worker $ \r -> gblock (act r)
gunblock (Worker act) = Worker $ \r -> gunblock (act r)
+#if __GLASGOW_HASKELL__ < 702
instance WarnLogMonad Worker where
setWarnings ws = Worker $ \_ -> setWarnings ws
getWarnings = Worker $ \_ -> getWarnings
+#endif
instance GhcMonad Worker where
getSession = Worker (\_ -> getSession)
View
3 src/Scion/Utils/IO.hs
@@ -6,7 +6,6 @@ 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)
@@ -94,7 +93,7 @@ hRecv h size = do
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)
+ _ <- hWaitForInput h (-1)
S.hGetNonBlocking h size
die :: String -> a
View
16 src/Scion/Worker/Commands.hs
@@ -95,7 +95,11 @@ load how_much = do
<- withMeasuredTime $ \_stop_timer -> do
Ghc.load how_much --WithLogger (my_logger msgs) how_much
`gcatch` (\(e :: Ghc.SourceError) -> do
+#if __GLASGOW_HASKELL__ >= 702
+ Ghc.printException e
+#else
Ghc.printExceptionAndWarnings e
+#endif
return Ghc.Failed
) --handle_error msgs e)
@@ -114,18 +118,6 @@ load how_much = do
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
mapM fromGhcModSummary =<< Ghc.getModuleGraph
View
13 src/Scion/Worker/Main.hs
@@ -22,7 +22,6 @@ import qualified Outputable as O
import qualified Distribution.Compiler as C
import qualified Distribution.Simple.Configure as C
import qualified Distribution.Simple.Build as C
-import qualified Distribution.Simple.PreProcess as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.PackageDescription.Parse as C
import qualified Distribution.Verbosity as C
@@ -48,6 +47,10 @@ import System.Directory hiding ( getModificationTime )
import System.PosixCompat.Files ( getFileStatus, modificationTime )
import System.FilePath.Canonical
+#if __GLASGOW_HASKELL__ < 702
+import qualified Distribution.Simple.PreProcess as C ( knownSuffixHandlers )
+#endif
+
------------------------------------------------------------------------
--
-- Compilation worker initialisation sequence:
@@ -225,7 +228,11 @@ initGhcSession targets args1 _debugMsg kont = do
debugMsg $ "GHC Args: " ++ show (map Ghc.unLoc args1)
-- handles Ctrl-C and GHC panics and suchlike
+#if __GLASGOW_HASKELL__ >= 702
+ Ghc.defaultErrorHandler Ghc.defaultLogAction $ do
+#else
Ghc.defaultErrorHandler Ghc.defaultDynFlags $ do
+#endif
-- 1. Initialise all the static flags
debugMsg "Parsing static flags"
@@ -381,7 +388,11 @@ configureCabal cabal_file0 config_flags odir = do
C.writePersistBuildConfig odir lcl_build_info
C.initialBuildSteps odir (C.localPkgDescr lcl_build_info) lcl_build_info
+#if __GLASGOW_HASKELL__ >= 702
+ C.normal
+#else
C.normal C.knownSuffixHandlers
+#endif
-- Create timestamp *after* writing the file. Thus if we later
-- check if the file is up to date using this timestamp, it is
Something went wrong with that request. Please try again.