ErrMsg module.

Cabal.hs

@@ -8,6 +8,7 @@ import Data.Attoparsec.Enumerator
 import Data.Enumerator (run, ($$))
 import Data.Enumerator.Binary (enumFile)
 import Data.List
+import ErrMsg
 import GHC
 import System.Directory
 import System.FilePath

Check.hs

@@ -3,6 +3,8 @@ module Check (checkSyntax) where
 import Cabal
 import Control.Applicative
 import CoreMonad
+import ErrMsg
+import Exception
 import GHC
 import Prelude hiding (catch)
 import Types
@@ -15,15 +17,12 @@ checkSyntax opt file = unlines <$> check opt file
 ----------------------------------------------------------------
 
 check :: Options -> String -> IO [String]
-check opt fileName = withGHC $ do
-    (file,readLog) <- initializeGHC opt fileName options True
-    setTargetFile file
-    load LoadAllTargets -- `gcatch` handleParseError ref xxx
-    liftIO readLog
+check opt fileName = withGHC $ checkIt `gcatch` handleErrMsg
   where
-    options = ["-Wall","-fno-warn-unused-do-bind"] ++ map ("-i" ++) (checkIncludes opt)
-    {-
-    handleParseError ref e = do
-        liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e
-        return Succeeded
-    -}
+    checkIt = do
+        (file,readLog) <- initializeGHC opt fileName options True
+        setTargetFile file
+        load LoadAllTargets
+        liftIO readLog
+    options = ["-Wall","-fno-warn-unused-do-bind"]
+           ++ map ("-i" ++) (checkIncludes opt)

ErrMsg.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE CPP #-}
+
+module ErrMsg (
+    LogReader
+  , setLogger
+  , handleErrMsg
+  ) where
+
+import Bag
+import Control.Applicative
+import Data.IORef
+import DynFlags
+import ErrUtils
+import FastString
+import GHC
+import HscTypes
+import Outputable
+import System.FilePath
+
+#if __GLASGOW_HASKELL__ < 702
+import Pretty
+#endif
+
+----------------------------------------------------------------
+
+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)
+
+----------------------------------------------------------------
+
+handleErrMsg :: SourceError -> Ghc [String]
+handleErrMsg = return . errBagToStrList . srcErrorMessages
+
+errBagToStrList :: Bag ErrMsg -> [String]
+errBagToStrList = map ppErrMsg . reverse . bagToList
+
+----------------------------------------------------------------
+
+ppErrMsg :: ErrMsg -> String
+ppErrMsg err = ppMsg spn msg ++ ext
+   where
+     spn = head (errMsgSpans err)
+     msg = errMsgShortDoc err
+     ext = showMsg (errMsgExtraInfo err)
+
+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"
+  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
+#if __GLASGOW_HASKELL__ >= 702
+showMsg d = map toNull $ renderWithStyle d style
+#else
+showMsg d = map toNull . Pretty.showDocWith PageMode $ d style
+#endif
+  where
+    toNull '\n' = '\0'
+    toNull x = x

Types.hs

@@ -1,20 +1,12 @@
-{-# LANGUAGE CPP #-}
-
 module Types where
 
-import Control.Applicative
 import Control.Monad
 import CoreMonad
-import Data.IORef
 import DynFlags
-import ErrUtils
+import ErrMsg
 import Exception
-import FastString
 import GHC
 import GHC.Paths (libdir)
-import Outputable
-import System.FilePath
-import Pretty
 
 ----------------------------------------------------------------
 
@@ -76,44 +68,6 @@ setPackageConfFlags
 
 ----------------------------------------------------------------
 
-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
-
-----------------------------------------------------------------
-
 setTargetFile :: (GhcMonad m) => String -> m ()
 setTargetFile file = do
     target <- guessTarget file Nothing

ghc-mod.cabal

@@ -23,7 +23,7 @@ Data-Files:             Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
                         ghc-flymake.el ghc-command.el ghc-info.el
 Executable ghc-mod
   Main-Is:              GHCMod.hs
-  Other-Modules:        List Browse Cabal Check Info Lang Lint Types
+  Other-Modules:        List Browse Cabal Check Info Lang Lint Types ErrMsg
   if impl(ghc >= 6.12)
     GHC-Options:        -Wall -fno-warn-unused-do-bind
   else