Skip to content
This repository
Browse code

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

Add compatibility for GHC 7.2.x
  • Loading branch information...
commit b78e9e7579e34028b23ea9fe256654d978db6660 2 parents 98bc21b + 21052a1
Thomas Schilling authored December 21, 2011
3  scion.cabal
@@ -105,10 +105,11 @@ executable scion-server
105 105
   build-depends:
106 106
     scion,
107 107
     atto-lisp    >= 0.2     && < 0.3,
108  
-    attoparsec   >= 0.8.5.1 && < 0.9,
  108
+    attoparsec   >= 0.8.5.1 && < 0.10,
109 109
     base         >= 4.2     && < 4.5,
110 110
     bytestring   >= 0.9     && < 0.10,
111 111
     multiset     >= 0.1     && < 0.3,
112 112
     network      >= 2.3     && < 2.4,
113 113
     text         >= 0.11    && < 0.12,
114 114
     canonical-filepath == 1.0.*
  115
+  ghc-options: -fcontext-stack=30
10  src-execs/Server.hs
@@ -11,7 +11,7 @@ import Scion.Cabal
11 11
 import Scion.Session
12 12
 
13 13
 import Control.Applicative
14  
---import Control.Exception ( throwIO, handle, IOException )
  14
+import Control.Exception ( catch )
15 15
 import Data.AttoLisp ( FromLisp(..), ToLisp(..) )
16 16
 import Data.Bits ( shiftL, (.|.) )
17 17
 import Data.Maybe ( isNothing )
@@ -22,6 +22,7 @@ import Network ( listenOn, PortID(..) )
22 22
 import Network.Socket hiding (send, sendTo, recv, recvFrom)
23 23
 import Network.Socket.ByteString
24 24
 import Numeric ( showHex )
  25
+import Prelude hiding (catch)
25 26
 import System.IO
26 27
 import System.FilePath.Canonical
27 28
 import qualified Network.Socket.ByteString.Lazy as NL
@@ -29,7 +30,8 @@ import qualified Data.AttoLisp as L
29 30
 import qualified Data.Attoparsec as A
30 31
 import qualified Data.ByteString as B
31 32
 import qualified Data.ByteString.Lazy as BL
32  
-import qualified Data.ByteString.Char8 as S ( pack )
  33
+import qualified Data.ByteString.Char8 as S ( pack, putStrLn )
  34
+import qualified Data.ByteString.Lazy.Char8 as L ( putStrLn )
33 35
 import qualified Data.MultiSet as MS
34 36
 import qualified Data.Text as T
35 37
 
@@ -93,7 +95,7 @@ mainLoop sock Lisp = runScion $ do
93 95
        Just len -> do
94 96
          msg <- io $ recv sock len
95 97
          io $ putStr $ "==> [" ++ show len ++ "] "
96  
-         io $ B.putStrLn msg
  98
+         io $ S.putStrLn msg
97 99
          case parseRequest msg of
98 100
            Left err_msg -> do
99 101
              io $ putStrLn $ "ParseError: " ++ err_msg
@@ -123,7 +125,7 @@ sendResponse sock reqId resp =
123 125
   in do
124 126
     let len = (fromIntegral $ BL.length str)
125 127
     putStr $ "<== [" ++ show len ++ "] "
126  
-    BL.putStrLn str
  128
+    L.putStrLn str
127 129
     n <- send sock (encodeLen len)
128 130
     m <- NL.send sock str
129 131
     putStrLn $ " [Sent: " ++ show n ++ "+" ++ show m ++ "]"
1  src-execs/Worker.hs
@@ -2,5 +2,6 @@ module Main where
2 2
 
3 3
 import Scion.Worker.Main ( workerMain )
4 4
 
  5
+main :: IO ()
5 6
 main = workerMain 42
6 7
 --main = soloWorkerMain
12  src/Scion/Cabal.hs
@@ -20,11 +20,9 @@ import           Control.Monad ( when )
20 20
 import           Distribution.PackageDescription.Parse
21 21
 import           Distribution.Simple.Build ( initialBuildSteps )
22 22
 import           Distribution.Simple.Configure
23  
-import           Distribution.Simple.LocalBuildInfo hiding ( libdir )
24 23
 import qualified Distribution.PackageDescription as PD
25 24
 import qualified Distribution.PackageDescription.Parse as PD
26 25
 import qualified Distribution.PackageDescription.Configuration as PD
27  
-import           Distribution.Simple.PreProcess ( knownSuffixHandlers )
28 26
 import           Distribution.Simple.Program
29 27
 import           Distribution.Simple.Setup ( defaultConfigFlags,
30 28
                                              ConfigFlags(..), Flag(..) )
@@ -34,6 +32,13 @@ import           System.Directory
34 32
 import           System.Exit ( ExitCode(..) )
35 33
 import           System.FilePath ( dropFileName, takeBaseName )
36 34
 
  35
+#if __GLASGOW_HASKELL__ >= 702
  36
+import           Distribution.Simple.LocalBuildInfo hiding ( Component, libdir )
  37
+#else
  38
+import           Distribution.Simple.LocalBuildInfo hiding ( libdir )
  39
+import           Distribution.Simple.PreProcess ( knownSuffixHandlers )
  40
+#endif
  41
+
37 42
 -- | Something went wrong inside Cabal.
38 43
 data CabalException = CabalException String
39 44
   deriving (Typeable)
@@ -115,8 +120,11 @@ configureCabalProject conf@CabalConfig{} build_dir = do
115 120
                           config_flags
116 121
          writePersistBuildConfig build_dir lbi
117 122
          initialBuildSteps build_dir (localPkgDescr lbi) lbi V.normal
  123
+#if __GLASGOW_HASKELL__ < 702
118 124
                            knownSuffixHandlers
  125
+#endif
119 126
          return lbi
  127
+configureCabalProject _ _ = fail "configureCabalProject: invalid config type"
120 128
 
121 129
 availableComponents :: PD.PackageDescription -> [Component]
122 130
 availableComponents pd =
30  src/Scion/Ghc.hs
... ...
@@ -1,4 +1,5 @@
1 1
 {-# LANGUAGE CPP, MultiParamTypeClasses #-}
  2
+{-# OPTIONS_GHC -fno-warn-orphans #-}
2 3
 module Scion.Ghc
3 4
   ( -- * Converting from GHC error messages
4 5
     ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote,
@@ -33,6 +34,22 @@ import           System.FilePath.Canonical
33 34
 ghcSpanToLocation :: FilePath -- ^ Base directory
34 35
                   -> Ghc.SrcSpan
35 36
                   -> Location
  37
+#if __GLASGOW_HASKELL__ >= 702
  38
+ghcSpanToLocation baseDir sp@(Ghc.RealSrcSpan rsp)
  39
+  | Ghc.isGoodSrcSpan sp =
  40
+      mkLocation mkLocFile
  41
+                 (Ghc.srcSpanStartLine rsp)
  42
+                 (ghcColToScionCol $ Ghc.srcSpanStartCol rsp)
  43
+                 (Ghc.srcSpanEndLine rsp)
  44
+                 (ghcColToScionCol $ Ghc.srcSpanEndCol rsp)
  45
+ where
  46
+   mkLocFile =
  47
+       case Ghc.unpackFS (Ghc.srcSpanFile rsp) of
  48
+         s@('<':_) -> OtherSrc s
  49
+         p -> FileSrc $ mkAbsFilePath baseDir p
  50
+ghcSpanToLocation _baseDir sp =
  51
+  mkNoLoc (Ghc.showSDoc (Ghc.ppr sp))
  52
+#else
36 53
 ghcSpanToLocation baseDir sp
37 54
   | Ghc.isGoodSrcSpan sp =
38 55
       mkLocation mkLocFile
@@ -42,11 +59,12 @@ ghcSpanToLocation baseDir sp
42 59
                  (ghcColToScionCol $ Ghc.srcSpanEndCol sp)
43 60
   | otherwise =
44 61
       mkNoLoc (Ghc.showSDoc (Ghc.ppr sp))
45  
- where
46  
-   mkLocFile =
47  
-       case Ghc.unpackFS (Ghc.srcSpanFile sp) of
  62
+  where
  63
+    mkLocFile =
  64
+      case Ghc.unpackFS (Ghc.srcSpanFile sp) of
48 65
          s@('<':_) -> OtherSrc s
49 66
          p -> FileSrc $ mkAbsFilePath baseDir p
  67
+#endif
50 68
 
51 69
 ghcErrMsgToNote :: FilePath -> Ghc.ErrMsg -> Note
52 70
 ghcErrMsgToNote = ghcMsgToNote ErrorNote
@@ -92,6 +110,7 @@ fromGhcModSummary ms = do
92 110
     , ms_fileType = case Ghc.ms_hsc_src ms of
93 111
          Ghc.HsSrcFile -> HaskellFile
94 112
          Ghc.HsBootFile -> HaskellBootFile
  113
+         Ghc.ExtCoreFile -> ExternalCoreFile
95 114
     , ms_imports =
96 115
          map (convert . Ghc.unLoc
97 116
                 . Ghc.ideclName . Ghc.unLoc) (Ghc.ms_imps ms)
@@ -117,6 +136,11 @@ targetToGhcTarget (FileTarget path) =
117 136
              , Ghc.targetAllowObjCode = True
118 137
              , Ghc.targetContents = Nothing
119 138
              }
  139
+targetToGhcTarget (CabalTarget path) =
  140
+  Ghc.Target { Ghc.targetId = Ghc.TargetFile path Nothing
  141
+             , Ghc.targetAllowObjCode = False
  142
+             , Ghc.targetContents = Nothing
  143
+             }
120 144
 
121 145
 instance Convert ModuleName Ghc.ModuleName where
122 146
   convert (ModuleName s) = Ghc.mkModuleName (T.unpack s)
24  src/Scion/Session.hs
@@ -28,7 +28,6 @@ import Scion.Cabal ( CabalException )
28 28
 
29 29
 import           Control.Applicative
30 30
 import           Control.Concurrent
31  
-import           Control.Exception ( throwIO )
32 31
 import           Control.Monad ( when, unless, forever, filterM )
33 32
 import qualified Data.ByteString as S
34 33
 import qualified Data.ByteString.Lazy as L
@@ -36,20 +35,17 @@ import qualified Data.Map as M
36 35
 import           Data.Char ( ord )
37 36
 import           Data.Maybe
38 37
 import           Data.Time.Clock ( getCurrentTime )
39  
-import           Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
40 38
 import           System.Directory ( doesFileExist, getTemporaryDirectory,
41 39
                                     removeDirectoryRecursive )
42 40
 import           System.Exit ( ExitCode(..) )
43 41
 import           System.FilePath ( dropFileName, (</>), takeFileName,
44  
-                                   makeRelative, takeDirectory )
  42
+                                   takeDirectory )
45 43
 import           System.FilePath.Canonical
46 44
 import           System.IO
47 45
 import           System.IO.Temp ( createTempDirectory )
48 46
 import           System.PosixCompat.Files ( getFileStatus, modificationTime )
49 47
 import           System.Process ( getProcessExitCode, terminateProcess )
50 48
 
51  
-import Debug.Trace
52  
-
53 49
 -- -------------------------------------------------------------------
54 50
 
55 51
 -- | Throw a 'ScionException' if the file does not exist.
@@ -187,14 +183,15 @@ supportedLanguagesAndExtensions = do
187 183
         wh <- sessionWorker <$> getSessionState sid
188 184
         (ans, _) <- io $ callWorker wh Extensions
189 185
         case ans of
190  
-          AvailExtensions exts -> do
191  
-            setExtensions exts
192  
-            return exts
  186
+          AvailExtensions exts' -> do
  187
+            setExtensions exts'
  188
+            return exts'
  189
+          _ -> fail "supportedLanguagesAndExtensions: invalid answer"
193 190
 
194 191
 -- | Notify the worker that a file has changed.  The worker will then
195 192
 -- update its internal state.
196 193
 fileModified :: SessionId -> FilePath -> ScionM ()
197  
-fileModified sid path = do
  194
+fileModified sid _path = do
198 195
   -- TODO: check whether file is actually part of module graph
199 196
   -- TODO: properly merge compilation results
200 197
   st <- getSessionState sid
@@ -205,6 +202,7 @@ fileModified sid path = do
205 202
       modifySessionState sid $ \ss ->
206 203
         (ss{ sessionModuleGraph = graph
207 204
            , sessionLastCompilation = rslt }, ())
  205
+    _ -> fail "fileModified: invalid answer"
208 206
 
209 207
 
210 208
 
@@ -230,7 +228,7 @@ setTargets sid _targets = do
230 228
 
231 229
 sessionTargets :: SessionConfig -> [Target]
232 230
 sessionTargets FileConfig{ sc_fileName = f} = [FileTarget f]
233  
-sessionTargets CabalConfig{} = [] 
  231
+sessionTargets _ = []
234 232
 
235 233
 -- -------------------------------------------------------------------
236 234
 
@@ -249,7 +247,7 @@ startWorker start_worker homedir conf = do
249 247
      \(inp, out, err, proc) -> do
250 248
        hSetBinaryMode inp True
251 249
        hSetBinaryMode out True
252  
-       if verb >= deafening then forkIO (printFromHandle err) else return undefined
  250
+       _ <- if verb >= deafening then forkIO (printFromHandle err) else return undefined
253 251
        -- Wait for worker to start up.
254 252
        wait_for_READY out
255 253
 
@@ -286,7 +284,7 @@ startWorker start_worker homedir conf = do
286 284
    printFromHandle hdl =
287 285
      handle (\(_e :: IOError) -> return ()) $ do
288 286
        forever $ do
289  
-         hWaitForInput hdl (-1)
  287
+         _ <- hWaitForInput hdl (-1)
290 288
          s <- S.hGetNonBlocking hdl 256
291 289
          hPutStr stderr (show hdl ++ ": ")
292 290
          S.hPutStr stderr s
@@ -349,7 +347,7 @@ collectLines h act = do
349 347
  where
350 348
    loop var =
351 349
      handle (\(_e :: IOError) -> return ()) $ do
352  
-       hWaitForInput h (-1)
  350
+       _ <- hWaitForInput h (-1)
353 351
        modifyMVar_ var $ \cs -> do
354 352
          chunk <- S.hGetNonBlocking h (2*4096)
355 353
          return (chunk:cs)
2  src/Scion/Types/Commands.hs
@@ -39,6 +39,7 @@ instance Binary Command where
39 39
       3 -> pure Quit
40 40
       4 -> pure Reload
41 41
       5 -> pure Extensions
  42
+      _ -> fail "Binary Command get: tag error"
42 43
 
43 44
 instance Binary Answer where
44 45
   put Pong             = putWord16le 1
@@ -55,3 +56,4 @@ instance Binary Answer where
55 56
       3 -> Error <$> get
56 57
       4 -> pure Quitting
57 58
       5 -> AvailExtensions <$> get
  59
+      _ -> fail "Binary Answer get: tag error"
1  src/Scion/Types/Compiler.hs
@@ -3,7 +3,6 @@ module Scion.Types.Compiler where
3 3
 import           Control.Applicative
4 4
 import           Data.Binary
5 5
 import           Data.Binary.Get()
6  
-import           Data.Binary.Put
7 6
 import           Data.String ( IsString(fromString) )
8 7
 import qualified Data.Text as T
9 8
 import qualified Data.Text.Encoding as T
3  src/Scion/Types/Monad.hs
@@ -13,10 +13,7 @@ import           Scion.Types.Core
13 13
 import           Control.Applicative
14 14
 import           Control.Monad ( when )
15 15
 import qualified Data.Map as M
16  
-import qualified Data.Text as T
17 16
 import           Data.IORef
18  
-import           MonadUtils -- from GHC
19  
-import           Exception  -- from GHC
20 17
 import           System.IO ( hFlush, stdout )
21 18
 
22 19
 -- * The Scion Monad and Session State
2  src/Scion/Types/Note.hs
@@ -120,6 +120,7 @@ instance Binary Location where
120 120
     case tag of
121 121
       1 -> LocNone <$> get
122 122
       2 -> mkLocation <$> get <*> get <*> get <*> get <*> get
  123
+      _ -> fail "Binary Location get: tag error"
123 124
 
124 125
 -- | The \"source\" of a location.
125 126
 data LocSource
@@ -137,6 +138,7 @@ instance Binary LocSource where
137 138
            case tag of
138 139
              1 -> FileSrc <$> get
139 140
              2 -> OtherSrc <$> get
  141
+             _ -> fail "Binary LocSource get: tag error"
140 142
 
141 143
 instance Ord Location where compare = cmpLoc
142 144
 
5  src/Scion/Types/Session.hs
... ...
@@ -1,5 +1,6 @@
1 1
 {-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, DeriveDataTypeable,
2 2
              MultiParamTypeClasses #-}
  3
+{-# OPTIONS_GHC -fno-warn-orphans #-}
3 4
 module Scion.Types.Session
4 5
   ( module Scion.Types.Session
5 6
   , module Scion.Types.Core
@@ -57,6 +58,7 @@ instance Binary Component where
57 58
            case tag of
58 59
              1 -> return Library
59 60
              2 -> Executable <$> get
  61
+             _ -> fail "Binary Component get: tag error"
60 62
 
61 63
 -- | A @WorkerHandle@ contains the state and data structures for
62 64
 -- communicating with a worker process.
@@ -152,6 +154,7 @@ instance Binary SessionConfig where
152 154
              1 -> FileConfig <$> get <*> get
153 155
              2 -> CabalConfig <$> get <*> get <*> get <*> get <*> get
154 156
              3 -> EmptyConfig <$> get
  157
+             _ -> fail "Binary SessionConfig get: tag error"
155 158
 
156 159
 
157 160
 -- | The concept of \"a point in time\" that we use throughout Scion.
@@ -249,6 +252,7 @@ instance Binary CanonicalFilePath where
249 252
 data HsFileType 
250 253
   = HaskellFile
251 254
   | HaskellBootFile
  255
+  | ExternalCoreFile
252 256
   deriving (Eq, Ord, Show, Enum)
253 257
 
254 258
 instance Binary HsFileType where
@@ -302,3 +306,4 @@ instance Binary Target where
302 306
              1 -> ModuleTarget <$> get
303 307
              2 -> FileTarget <$> get
304 308
              3 -> CabalTarget <$> get
  309
+             _ -> fail "Binary Target get: tag error"
5  src/Scion/Types/Worker.hs
... ...
@@ -1,3 +1,4 @@
  1
+{-# LANGUAGE CPP #-}
1 2
 -- | The types used by the worker (which talks to the GHC API.)
2 3
 module Scion.Types.Worker
3 4
   ( module Scion.Types.Worker
@@ -14,9 +15,11 @@ import Data.IORef
14 15
 import System.IO
15 16
 import Distribution.Simple.LocalBuildInfo
16 17
 import GHC       ( Ghc, GhcMonad(..) )
  18
+#if __GLASGOW_HASKELL__ < 702
17 19
 import HscTypes  ( WarnLogMonad(..) )
18 20
 import MonadUtils ( MonadIO, liftIO )
19 21
 import Exception ( ExceptionMonad(..) )
  22
+#endif
20 23
 
21 24
 newtype Worker a
22 25
   = Worker { unWorker :: IORef WorkerState -> Ghc a }
@@ -58,9 +61,11 @@ instance ExceptionMonad Worker where
58 61
   gblock (Worker act) = Worker $ \r -> gblock (act r)
59 62
   gunblock (Worker act) = Worker $ \r -> gunblock (act r)
60 63
 
  64
+#if __GLASGOW_HASKELL__ < 702
61 65
 instance WarnLogMonad Worker where
62 66
   setWarnings ws = Worker $ \_ -> setWarnings ws
63 67
   getWarnings = Worker $ \_ -> getWarnings
  68
+#endif
64 69
 
65 70
 instance GhcMonad Worker where
66 71
   getSession = Worker (\_ -> getSession)
3  src/Scion/Utils/IO.hs
@@ -6,7 +6,6 @@ import System.IO
6 6
 import qualified Data.ByteString      as S
7 7
 import qualified Data.ByteString.Lazy as L
8 8
 import Control.Applicative
9  
-import Data.Binary
10 9
 import Data.Binary.Get ( getWord32le, runGet )
11 10
 import Data.Binary.Put ( putWord32le, runPut )
12 11
 import Network.Socket hiding (send, sendTo, recv, recvFrom)
@@ -94,7 +93,7 @@ hRecv h size = do
94 93
             return S.empty) $ do
95 94
     -- Note: hWaitForInput tries to decode its input, so we must make
96 95
     -- sure the handle is in binary mode.
97  
-    hWaitForInput h (-1)
  96
+    _ <- hWaitForInput h (-1)
98 97
     S.hGetNonBlocking h size
99 98
 
100 99
 die :: String -> a
16  src/Scion/Worker/Commands.hs
@@ -95,7 +95,11 @@ load how_much = do
95 95
     <- withMeasuredTime $ \_stop_timer -> do
96 96
          Ghc.load how_much --WithLogger (my_logger msgs) how_much
97 97
            `gcatch` (\(e :: Ghc.SourceError) -> do
  98
+#if __GLASGOW_HASKELL__ >= 702
  99
+                      Ghc.printException e
  100
+#else
98 101
                       Ghc.printExceptionAndWarnings e
  102
+#endif
99 103
                       return Ghc.Failed
100 104
                     ) --handle_error msgs e)
101 105
 
@@ -114,18 +118,6 @@ load how_much = do
114 118
 
115 119
   return comp_rslt
116 120
 
117  
- where
118  
-   --my_logger :: IORef Messages -> Maybe Ghc.SourceError -> Worker ()
119  
-   my_logger msgs err = do
120  
-     let errs = case err of
121  
-           Nothing -> emptyBag
122  
-           Just exc -> Ghc.srcErrorMessages exc
123  
-     warns <- Ghc.getWarnings
124  
-     Ghc.clearWarnings
125  
-     liftIO $ modifyIORef msgs (`mappend` Messages warns errs)
126  
---     return Ghc.Failed
127  
-     return ()
128  
-
129 121
 moduleGraph :: Worker [ModuleSummary]
130 122
 moduleGraph = do
131 123
   mapM fromGhcModSummary =<< Ghc.getModuleGraph
13  src/Scion/Worker/Main.hs
@@ -22,7 +22,6 @@ import qualified Outputable as O
22 22
 import qualified Distribution.Compiler as C
23 23
 import qualified Distribution.Simple.Configure as C
24 24
 import qualified Distribution.Simple.Build as C
25  
-import qualified Distribution.Simple.PreProcess as C
26 25
 import qualified Distribution.PackageDescription as C
27 26
 import qualified Distribution.PackageDescription.Parse as C
28 27
 import qualified Distribution.Verbosity as C
@@ -48,6 +47,10 @@ import System.Directory hiding ( getModificationTime )
48 47
 import System.PosixCompat.Files ( getFileStatus, modificationTime )
49 48
 import System.FilePath.Canonical
50 49
 
  50
+#if __GLASGOW_HASKELL__ < 702
  51
+import qualified Distribution.Simple.PreProcess as C ( knownSuffixHandlers )
  52
+#endif
  53
+
51 54
 ------------------------------------------------------------------------
52 55
 --
53 56
 -- Compilation worker initialisation sequence:
@@ -225,7 +228,11 @@ initGhcSession targets args1 _debugMsg kont = do
225 228
   debugMsg $ "GHC Args: " ++ show (map Ghc.unLoc args1)
226 229
 
227 230
   -- handles Ctrl-C and GHC panics and suchlike
  231
+#if __GLASGOW_HASKELL__ >= 702
  232
+  Ghc.defaultErrorHandler Ghc.defaultLogAction $ do
  233
+#else
228 234
   Ghc.defaultErrorHandler Ghc.defaultDynFlags $ do
  235
+#endif
229 236
 
230 237
     -- 1. Initialise all the static flags
231 238
     debugMsg "Parsing static flags"
@@ -381,7 +388,11 @@ configureCabal cabal_file0 config_flags odir = do
381 388
   C.writePersistBuildConfig odir lcl_build_info
382 389
 
383 390
   C.initialBuildSteps odir (C.localPkgDescr lcl_build_info) lcl_build_info
  391
+#if __GLASGOW_HASKELL__ >= 702
  392
+                      C.normal
  393
+#else
384 394
                       C.normal C.knownSuffixHandlers
  395
+#endif
385 396
 
386 397
   -- Create timestamp *after* writing the file.  Thus if we later
387 398
   -- check if the file is up to date using this timestamp, it is

0 notes on commit b78e9e7

Please sign in to comment.
Something went wrong with that request. Please try again.