ghc-mod/Language/Haskell/GhcMod/ErrMsg.hs

{-# LANGUAGE BangPatterns #-}

module Language.Haskell.GhcMod.ErrMsg (
    LogReader
  , setLogger
  , handleErrMsg
  ) where

import Bag
import Control.Applicative
import Data.IORef
import Data.Maybe
import DynFlags
import ErrUtils
import GHC
import HscTypes
import qualified Language.Haskell.GhcMod.Gap as Gap
import Outputable
import System.FilePath (normalise)

----------------------------------------------------------------

type LogReader = IO [String]

----------------------------------------------------------------

setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
setLogger False df = return (newdf, undefined)
  where
    newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
setLogger True  df = do
    ref <- newIORef [] :: IO (IORef [String])
    let newdf = Gap.setLogAction df $ appendLog ref
    return (newdf, reverse <$> readIORef ref)
  where
    appendLog ref _ sev src _ msg = do
        let !l = ppMsg src sev df msg
        modifyIORef ref (\ls -> l : ls)

----------------------------------------------------------------

handleErrMsg :: SourceError -> Ghc [String]
handleErrMsg err = do
    dflag <- getSessionDynFlags
    return . errBagToStrList dflag . srcErrorMessages $ err

errBagToStrList :: DynFlags -> Bag ErrMsg -> [String]
errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList

----------------------------------------------------------------

ppErrMsg :: DynFlags -> ErrMsg -> String
ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext
   where
     spn = head (errMsgSpans err)
     msg = errMsgShortDoc err
     ext = showMsg dflag (errMsgExtraInfo err)

ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String
ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
  where
    cts  = showMsg dflag msg
    defaultPrefix
      | dopt Opt_D_dump_splices dflag = ""
      | otherwise                     = "Dummy:0:0:"
    prefix = fromMaybe defaultPrefix $ do
        (line,col,_,_) <- Gap.getSrcSpan spn
        file <- normalise <$> Gap.getSrcFile spn
        let severityCaption = Gap.showSeverityCaption sev
        return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption

----------------------------------------------------------------

showMsg :: DynFlags -> SDoc -> String
showMsg dflag sdoc = map toNull $ Gap.showUnqualifiedPage dflag sdoc
  where
    toNull '\n' = '\0'
    toNull x = x