Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

ErrMsg module.

  • Loading branch information...
commit 1790c5f327deb8dd49f54c043c6f4ed0c4f7acd8 1 parent dbdcf98
@kazu-yamamoto kazu-yamamoto authored
Showing with 98 additions and 59 deletions.
  1. +1 −0  Cabal.hs
  2. +10 −11 Check.hs
  3. +85 −0 ErrMsg.hs
  4. +1 −47 Types.hs
  5. +1 −1  ghc-mod.cabal
View
1  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
View
21 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)
View
85 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
View
48 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
View
2  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
Please sign in to comment.
Something went wrong with that request. Please try again.