Diagnostics.hs

module Clang.HighLevel.Diagnostics (
    Diagnostic(..)
  , FixIt(..)
  , clang_getDiagnostics
  , diagnosticIsError
  ) where

import Control.Exception
import Control.Monad.IO.Class
import Data.Text (Text)
import Data.Text qualified as Text
import Foreign.C

import Clang.Enum.Bitfield
import Clang.Enum.Simple
import Clang.HighLevel.SourceLoc (MultiLoc, Range)
import Clang.HighLevel.SourceLoc qualified as SourceLoc
import Clang.LowLevel.Core
import Clang.Paths (SourcePath)

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

data Diagnostic = Diagnostic {
      -- | Formatted by @libclang@ in a manner that is suitable for display
      diagnosticFormatted :: Text

      -- | Severity
    , diagnosticSeverity :: SimpleEnum CXDiagnosticSeverity

      -- | Source location (where Clang would print the caret @^@)
      --
      -- Uses 'SourcePath' rather than 'RealPath' because diagnostics may
      -- refer to root headers whose real path is not available.
    , diagnosticLocation  :: MultiLoc SourcePath

      -- | Text of the diagnostic
    , diagnosticSpelling  :: Text

      -- | The command line option that enabled this diagnostic
    , diagnosticOption :: Maybe Text

      -- | The @libclang@ option to disable this diagnostic
    , diagnosticDisabledBy :: Maybe Text

      -- | Diagnostic category
    , diagnosticCategory :: Int

      -- | Rendered category
    , diagnosticCategoryText :: Text

      -- | Source range associated with the diagnostic
      --
      -- A diagnostic's source ranges highlight important elements in the source
      -- code. On the command line, Clang displays source ranges by underlining
      -- them with @~@ characters.
    , diagnosticRanges :: [Range (MultiLoc SourcePath)]

      -- | Fix-it hints
    , diagnosticFixIts :: [FixIt]

      -- | Child diagnostics
    , diagnosticChildren  :: [Diagnostic]
    }
  deriving stock (Show, Eq)
  deriving anyclass (Exception)

-- | Suggestion to fix the code
--
-- Fix-its are described in terms of a source range whose contents should be
-- replaced by a string. This approach generalizes over three kinds of
-- operations: removal of source code (the range covers the code to be removed
-- and the replacement string is empty), replacement of source code (the range
-- covers the code to be replaced and the replacement string provides the new
-- code), and insertion (both the start and end of the range point at the
-- insertion location, and the replacement string provides the text to insert).
data FixIt = FixIt {
      -- | Replacement range
      --
      -- The replacement range is the source range whose contents will be
      -- replaced with the returned replacement string. Note that source ranges
      -- are half-open ranges [a, b), so the source code should be replaced from
      -- a and up to (but not including) b.
      fixItRange :: Range (MultiLoc SourcePath)

      -- | Text that should replace the source code
    , fixItReplacement :: Text
    }
  deriving stock (Show, Eq)

-- TODO <https://github.com/well-typed/libclang-bindings/issues/73>
--
-- Probably separate into Info/Warning/Error (issue #175).
diagnosticIsError :: Diagnostic -> Bool
diagnosticIsError diag =
    case fromSimpleEnum (diagnosticSeverity diag) of
      Right CXDiagnostic_Error -> True
      Right CXDiagnostic_Fatal -> True
      Left _unknownSeverity    -> True
      Right _otherwise         -> False

{-------------------------------------------------------------------------------
  Top-level
-------------------------------------------------------------------------------}

clang_getDiagnostics ::
     MonadIO m
  => CXTranslationUnit
  -> Maybe (BitfieldEnum CXDiagnosticDisplayOptions)
     -- ^ Display options for constructing 'diagnosticFormatted'
     --
     -- If 'Nothing', uses 'clang_defaultDiagnosticDisplayOptions'.
  -> m [Diagnostic]
clang_getDiagnostics unit mDisplayOptions = do
    displayOptions <- case mDisplayOptions of
                        Just displayOptions -> return displayOptions
                        Nothing -> clang_defaultDiagnosticDisplayOptions
    getAll unit clang_getNumDiagnostics $ getDiagnostic displayOptions

{-------------------------------------------------------------------------------
  Get all diagnostics
-------------------------------------------------------------------------------}

getDiagnostic ::
     MonadIO m
  => BitfieldEnum CXDiagnosticDisplayOptions
  -> CXTranslationUnit
  -> CUInt
  -> m Diagnostic
getDiagnostic displayOptions unit i = liftIO $
    bracket (clang_getDiagnostic unit i) clang_disposeDiagnostic $
      reify displayOptions

getDiagnosticInSet ::
     MonadIO m
  => BitfieldEnum CXDiagnosticDisplayOptions
  -> CXDiagnosticSet
  -> CUInt
  -> m Diagnostic
getDiagnosticInSet displayOptions set i = liftIO $
    bracket (clang_getDiagnosticInSet set i) clang_disposeDiagnostic $
      reify displayOptions

reify ::
     MonadIO m
  => BitfieldEnum CXDiagnosticDisplayOptions
  -> CXDiagnostic
  -> m Diagnostic
reify displayOptions diag = do
    diagnosticFormatted    <- clang_formatDiagnostic diag displayOptions
    diagnosticSeverity     <- clang_getDiagnosticSeverity diag
    diagnosticLocation     <- SourceLoc.clang_getDiagnosticLocation diag
    diagnosticSpelling     <- clang_getDiagnosticSpelling diag
    (mOption, mDisabledBy) <- clang_getDiagnosticOption diag
    diagnosticCategory     <- fromIntegral <$> clang_getDiagnosticCategory diag
    diagnosticCategoryText <- clang_getDiagnosticCategoryText diag
    diagnosticRanges       <- getAll diag clang_getDiagnosticNumRanges $
                                SourceLoc.clang_getDiagnosticRange
    diagnosticFixIts       <- getAll diag clang_getDiagnosticNumFixIts $
                                getDiagnosticFixIt
    diagnosticChildren     <- getChildDiagnostics displayOptions diag
    return $ Diagnostic {
          diagnosticFormatted
        , diagnosticSeverity
        , diagnosticLocation
        , diagnosticSpelling
        , diagnosticOption     = nonEmpty mOption
        , diagnosticDisabledBy = nonEmpty mDisabledBy
        , diagnosticCategory
        , diagnosticCategoryText
        , diagnosticRanges
        , diagnosticFixIts
        , diagnosticChildren
        }
  where
    nonEmpty :: Text -> Maybe Text
    nonEmpty bs
      | Text.null bs = Nothing
      | otherwise    = Just bs

getChildDiagnostics ::
     MonadIO m
  => BitfieldEnum CXDiagnosticDisplayOptions
  -> CXDiagnostic
  -> m [Diagnostic]
getChildDiagnostics displayOptions diag = do
    set <- clang_getChildDiagnostics diag
    getAll set clang_getNumDiagnosticsInSet $
      getDiagnosticInSet displayOptions

getDiagnosticFixIt ::
     MonadIO m
  => CXDiagnostic
  -> CUInt
  -> m FixIt
getDiagnosticFixIt diag i =
    uncurry FixIt <$> SourceLoc.clang_getDiagnosticFixIt diag i

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

getAll :: Monad m => a -> (a -> m CUInt) -> (a -> CUInt -> m b) -> m [b]
getAll x getCount getElem = do
    count <- getCount x
    if count == 0
      then return []
      else mapM (getElem x) [0 .. pred count]