Permalink
Browse files

Merge pull request #12 from maoe/feature/ghc-7.2

Add compatibility for GHC 7.2.x
  • Loading branch information...
2 parents 98bc21b + 21052a1 commit b78e9e7579e34028b23ea9fe256654d978db6660 @nominolo committed Dec 21, 2011
View
@@ -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
@@ -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,14 +22,16 @@ 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
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
@@ -2,5 +2,6 @@ module Main where
import Scion.Worker.Main ( workerMain )
+main :: IO ()
main = workerMain 42
--main = soloWorkerMain
View
@@ -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
@@ -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
@@ -28,28 +28,24 @@ 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
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)
@@ -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"
@@ -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
@@ -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
@@ -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
@@ -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"
@@ -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
@@ -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
Oops, something went wrong.

0 comments on commit b78e9e7

Please sign in to comment.