Supporting GHC 7.2.1!

Cabal.hs

@@ -2,39 +2,40 @@
 module Cabal (initializeGHC) where
 
 import Control.Applicative hiding (many)
+import CoreMonad
 import Data.Attoparsec.Char8
 import Data.Attoparsec.Enumerator
 import Data.Enumerator (run, ($$))
 import Data.Enumerator.Binary (enumFile)
 import Data.List
 import GHC
-import qualified HscTypes as H
 import System.Directory
 import System.FilePath
 import Types
 
 ----------------------------------------------------------------
 
-initializeGHC :: Options -> FilePath -> [String] -> Ghc FilePath
-initializeGHC opt fileName ghcOptions = do
-    (owdir,mdirfile) <- getDirs
+initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
+initializeGHC opt fileName ghcOptions logging = do
+    (owdir,mdirfile) <- liftIO getDirs
     case mdirfile of
         Nothing -> do
-            initSession opt ghcOptions Nothing
-            return fileName
+            logReader <- initSession opt ghcOptions Nothing logging
+            return (fileName,logReader)
         Just (cdir,cfile) -> do
             midirs <- parseCabalFile cfile
             changeToCabalDirectory cdir
             let idirs = case midirs of
                     Nothing   -> [cdir,owdir]
                     Just dirs -> dirs ++ [owdir]
-            initSession opt ghcOptions (Just idirs)
-            return (ajustFileName fileName owdir cdir)
+                file = ajustFileName fileName owdir cdir
+            logReader <- initSession opt ghcOptions (Just idirs) logging
+            return (file,logReader)
 
 ----------------------------------------------------------------
 
 parseCabalFile :: FilePath -> Ghc (Maybe [String])
-parseCabalFile file = H.liftIO $ do
+parseCabalFile file = liftIO $ do
     res <- run (enumFile file $$ iterParser findTarget)
     case res of
         Right x -> return x
@@ -63,20 +64,20 @@ ajustFileName name olddir newdir
 
 changeToCabalDirectory :: FilePath -> Ghc ()
 changeToCabalDirectory dir = do
-    H.liftIO $ setCurrentDirectory dir
+    liftIO $ setCurrentDirectory dir
     workingDirectoryChanged
 
-getDirs :: Ghc (FilePath, Maybe (FilePath,FilePath))
+getDirs :: IO (FilePath, Maybe (FilePath,FilePath))
 getDirs = do
-    wdir <- H.liftIO $ getCurrentDirectory
+    wdir <- getCurrentDirectory
     mcabdir <- cabalDir wdir
     case mcabdir of
         Nothing -> return (wdir,Nothing)
         jdf     -> return (wdir,jdf)
 
-cabalDir :: FilePath -> Ghc (Maybe (FilePath,FilePath))
+cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))
 cabalDir dir = do
-    cnts <- H.liftIO $ getDirectoryContents dir
+    cnts <- getDirectoryContents dir
     case filter isCabal cnts of
         [] -> do
             let dir' = takeDirectory dir

Check.hs

@@ -1,18 +1,10 @@
 module Check (checkSyntax) where
 
-import Bag
 import Cabal
 import Control.Applicative
-import Data.IORef
-import ErrUtils
-import Exception
-import FastString
+import CoreMonad
 import GHC
-import HscTypes
-import Outputable hiding (showSDoc)
 import Prelude hiding (catch)
-import Pretty
-import System.FilePath
 import Types
 
 ----------------------------------------------------------------
@@ -24,49 +16,14 @@ checkSyntax opt file = unlines <$> check opt file
 
 check :: Options -> String -> IO [String]
 check opt fileName = withGHC $ do
-    file <- initializeGHC opt fileName options
+    (file,readLog) <- initializeGHC opt fileName options True
     setTargetFile file
-    ref <- newRef []
-    loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref
-    clearWarnings
-    readRef ref
+    load LoadAllTargets -- `gcatch` handleParseError ref xxx
+    liftIO readLog
   where
-    options = ["-Wall","-fno-warn-unused-do-bind"] ++ map ((++) "-i") (checkIncludes opt)
+    options = ["-Wall","-fno-warn-unused-do-bind"] ++ map ("-i" ++) (checkIncludes opt)
+    {-
     handleParseError ref e = do
         liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e
         return Succeeded
-    newRef  = liftIO . newIORef
-    readRef = liftIO . readIORef
-
-----------------------------------------------------------------
-
-refLogger :: IORef [String] -> WarnErrLogger
-refLogger ref Nothing =
-    (errBagToStrList <$> getWarnings) >>= liftIO . writeIORef ref
-refLogger ref (Just e) =
-    liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e
-
-errBagToStrList :: Bag ErrMsg -> [String]
-errBagToStrList = map showErrMsg . reverse . bagToList
-
-----------------------------------------------------------------
-
-showErrMsg :: ErrMsg -> String
-showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg ++ "\0" ++ ext
-   where
-     spn = head (errMsgSpans err)
-     file = takeFileName $ unpackFS (srcSpanFile spn)
-     line = show (srcSpanStartLine spn)
-     col  = show (srcSpanStartCol spn)
-     msg = showSDoc (errMsgShortDoc err)
-     ext = showSDoc (errMsgExtraInfo err)
-
-style :: PprStyle
-style = mkUserStyle neverQualify AllTheWay
-
-showSDoc :: SDoc -> String
---showSDoc d = map toNull . Pretty.showDocWith ZigZagMode $ d style
-showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style
-  where
-    toNull '\n' = '\0'
-    toNull x = x
+    -}

GHCMod.hs

@@ -62,7 +62,7 @@ argspec = [ Option "l" ["tolisp"]
             (NoArg (\opts -> opts{ useUserPackageConf = False }))
             "do not read the user package database"
           , Option "i" ["include"]
-            (ReqArg (\i opts -> opts{ checkIncludes = i : (checkIncludes opts)}) "include")
+            (ReqArg (\i opts -> opts{ checkIncludes = i : checkIncludes opts }) "include")
             "directory to include in search for modules"
           ]
 
@@ -105,7 +105,7 @@ main = flip catches handlers $ do
   where
     handlers = [Handler handler1, Handler handler2]
     handler1 :: ErrorCall -> IO ()
-    handler1 e = print e -- for debug
+    handler1 = print -- for debug
     handler2 :: GHCModError -> IO ()
     handler2 SafeList = printUsage
     handler2 (NoSuchCommand cmd) = do
@@ -117,7 +117,7 @@ main = flip catches handlers $ do
     handler2 (FileNotExist file) = do
         hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
         printUsage
-    printUsage = hPutStrLn stderr $ "\n" ++ usageInfo usage argspec
+    printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec
     withFile cmd file = do
         exist <- doesFileExist file
         if exist

Info.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Info where
 
 import Cabal
@@ -15,6 +17,10 @@ import StringBuffer
 import System.Time
 import Types
 
+#if __GLASGOW_HASKELL__ >= 702
+import CoreMonad
+#endif
+
 type Expression = String
 type ModuleString = String
 
@@ -68,19 +74,18 @@ pprInfo pefas (thing, fixity, insts)
 
 ----------------------------------------------------------------
 
-inModuleContext
-  :: Options -> FilePath -> ModuleString -> Ghc String -> IO String
+inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> IO String
 inModuleContext opt fileName modstr action = withGHC valid
   where
     valid = do
-        file <- initializeGHC opt fileName ["-w"]
+        (file,_) <- initializeGHC opt fileName ["-w"] False
         setTargetFile file
-        loadWithLogger (\_ -> return ()) LoadAllTargets
+        load LoadAllTargets
         mif setContextFromTarget action invalid
     invalid = do
-        initializeGHC opt fileName ["-w"]
+        initializeGHC opt fileName ["-w"] False
         setTargetBuffer
-        loadWithLogger defaultWarnErrLogger LoadAllTargets
+        load LoadAllTargets
         mif setContextFromTarget action (return errorMessage)
     setTargetBuffer = do
         modgraph <- depanal [mkModuleName modstr] True
@@ -88,7 +93,11 @@ inModuleContext opt fileName modstr action = withGHC valid
                       map ms_imps modgraph ++ map ms_srcimps modgraph
             moddef = "module " ++ sanitize modstr ++ " where"
             header = moddef : imports
+#if __GLASGOW_HASKELL__ >= 702
+            importsBuf = stringToStringBuffer . unlines $ header
+#else
         importsBuf <- liftIO . stringToStringBuffer . unlines $ header
+#endif
         clkTime <- liftIO getClockTime
         setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))]
     mif m t e = m >>= \ok -> if ok then t else e

Lint.hs

@@ -8,7 +8,7 @@ import Types
 lintSyntax :: Options -> String -> IO String
 lintSyntax opt file = pretty <$> lint opt file
   where
-    pretty = unlines . map (concat . intersperse "\0" . lines)
+    pretty = unlines . map (intercalate "\0" . lines)
 
 lint :: Options -> String -> IO [String]
 lint opt file = map show <$> hlint ([file, "--quiet"] ++ hlintOpts opt)

Types.hs

@@ -1,10 +1,20 @@
+{-# LANGUAGE CPP #-}
+
 module Types where
 
+import Control.Applicative
 import Control.Monad
+import CoreMonad
+import Data.IORef
 import DynFlags
+import ErrUtils
 import Exception
+import FastString
 import GHC
 import GHC.Paths (libdir)
+import Outputable
+import System.FilePath
+import Pretty
 
 ----------------------------------------------------------------
 
@@ -29,12 +39,14 @@ initSession0 :: Options -> Ghc [PackageId]
 initSession0 opt = getSessionDynFlags >>=
   setSessionDynFlags . setPackageConfFlags opt
 
-initSession :: Options -> [String] -> Maybe [FilePath] -> Ghc [PackageId]
-initSession opt cmdOpts midirs = do
+initSession :: Options -> [String] -> Maybe [FilePath] -> Bool -> Ghc LogReader
+initSession opt cmdOpts midirs logging = do
     dflags <- getSessionDynFlags
     let opts = map noLoc cmdOpts
     (dflags',_,_) <- parseDynamicFlags dflags opts
-    setSessionDynFlags $ setPackageConfFlags opt $ setFlags dflags' midirs
+    (dflags'',readLog) <- liftIO . setLogger logging . setPackageConfFlags opt . setFlags dflags' $ midirs
+    setSessionDynFlags dflags''
+    return readLog
 
 ----------------------------------------------------------------
 
@@ -57,9 +69,48 @@ setPackageConfFlags
   = flagset { extraPkgConfs = extra', flags = flags' }
   where
     extra' = confs ++ extra
-    flags' = if useUser
-        then origFlags
-        else filter (/=Opt_ReadUserPackageConf) origFlags
+    flags' = if useUser then
+                 origFlags
+             else
+                 filter (/=Opt_ReadUserPackageConf) origFlags
+
+----------------------------------------------------------------
+
+type LogReader = IO [String]
+
+setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
+setLogger False df = return (newdf, undefined)
+  where
+    newdf = df { log_action = \_ _ _ _ -> return () }
+setLogger True  df = do
+    ref <- newIORef [] :: IO (IORef [String])
+    let newdf = df { log_action = appendLog ref }
+    return (newdf, reverse <$> readIORef ref)
+  where
+    appendLog ref _ src _ msg = modifyIORef ref (\ls -> ppMsg src msg : ls)
+
+ppMsg :: SrcSpan -> Message -> String
+#if __GLASGOW_HASKELL__ >= 702
+ppMsg (UnhelpfulSpan _) _ = undefined
+ppMsg (RealSrcSpan src) msg
+#else
+ppMsg src msg
+#endif
+    = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ cts ++ "\0" -- xxx
+  where
+    file = takeFileName $ unpackFS (srcSpanFile src)
+    line = show (srcSpanStartLine src)
+    col  = show (srcSpanStartCol src)
+    cts  = showMsg msg
+
+style :: PprStyle
+style = mkUserStyle neverQualify AllTheWay
+
+showMsg :: SDoc -> String
+showMsg d = map toNull . Pretty.showDocWith PageMode $ d style
+  where
+    toNull '\n' = '\0'
+    toNull x = x
 
 ----------------------------------------------------------------