Clang.hs

-- | Top-level call into @clang@, with @hs-bindgen@ specific features
module HsBindgen.Clang (
    -- * Top-level call into @clang@
    ClangSetup(..)
  , ClangInput(..)
  , defaultClangSetup
  , withClang
  , LibclangException(..)
  , withClang'
    -- * Trace messages
  , ClangMsg(..)
  , infoHelpMessage
  ) where

import Data.Text qualified as Text
import Text.SimplePrettyPrint ((><))
import Text.SimplePrettyPrint qualified as PP

import Clang.Args
import Clang.Enum.Bitfield
import Clang.Enum.Simple
import Clang.HighLevel qualified as HighLevel
import Clang.HighLevel.Types
import Clang.LowLevel.Core

import HsBindgen.Frontend.RootHeader qualified as RootHeader
import HsBindgen.Imports
import HsBindgen.Util.Tracer

{-------------------------------------------------------------------------------
  Top-level call into clang
-------------------------------------------------------------------------------}

data ClangSetup = ClangSetup{
      args        :: ClangArgs
    , diagnostics :: DisplayDiagnostics
    , input       :: ClangInput
    , flags       :: BitfieldEnum CXTranslationUnit_Flags
    }
  deriving stock (Show, Eq)

instance PrettyForTrace ClangSetup where
  prettyForTrace = PP.show

data ClangInput =
    ClangInputFile SourcePath
  | ClangInputMemory FilePath String
  deriving stock (Show, Eq)

defaultClangSetup :: ClangArgs -> ClangInput -> ClangSetup
defaultClangSetup args input = ClangSetup{
      args        = args
    , diagnostics = DontDisplayDiagnostics
    , input       = input
    , flags       = bitfieldEnum [CXTranslationUnit_DetailedPreprocessingRecord]
    }

-- | Call clang to parse with the specified t'ClangSetup'
--
-- All diagnostics are traced.
--
-- Exits with failure code 2 if any of them are errors.
--
-- The specified continuation is called only when there are no error
-- diagnostics.
withClang :: forall a.
     Tracer ClangMsg
  -> ClangSetup
  -> (CXTranslationUnit -> IO a)
  -> IO a
withClang tracer setup k = do
    mRes <- withClang' tracer setup $ \unit -> do
      anyIsError <- traceDiagnostics unit
      if anyIsError
        then throwIO $ LibclangException "Call to 'libclang' returned an error"
        else Just <$> k unit
    case mRes of
      Nothing  -> throwIO $ LibclangException "Call to 'libclang' failed"
      Just res -> pure res
  where
    traceDiagnostics :: CXTranslationUnit -> IO Bool
    traceDiagnostics unit =
        go False =<< HighLevel.clang_getDiagnostics unit Nothing
      where
        go :: Bool -> [Diagnostic] -> IO Bool
        go !anyIsError []     = pure anyIsError
        go !anyIsError (d:ds) = do
            traceWith (contramap ClangDiagnostic tracer) (withCallStack d)
            go (anyIsError || diagnosticIsError d) ds

data LibclangException = LibclangException String
  deriving stock (Show, Eq, Ord)

instance Exception LibclangException

-- | Call clang to parse with the specified t'ClangSetup'
--
-- Diagnostics are not traced, and /the specified continuation is called even if
-- there are error diagnostics/.
withClang' :: forall a.
     Tracer ClangMsg
  -> ClangSetup
  -> (CXTranslationUnit -> IO (Maybe a))
  -> IO (Maybe a)
withClang' tracer setup k = do
    traceWith tracer $ withCallStack $ ClangSetupMsg setup
    HighLevel.withIndex setup.diagnostics $ \index -> do
      let withUnit :: SourcePath -> [CXUnsavedFile] -> IO (Maybe a)
          withUnit path unsaved =
             HighLevel.withTranslationUnit2
               index
               (Just path)
               setup.args
               unsaved
               setup.flags
               onErrorCode
               k
      case setup.input of
        ClangInputFile path ->
          withUnit path []
        ClangInputMemory path contents -> do
          HighLevel.withUnsavedFile path contents $ \file  ->
            withUnit (SourcePath $ Text.pack path) [file]
  where
    onErrorCode :: SimpleEnum CXErrorCode -> IO (Maybe a)
    onErrorCode err = do
        traceWith tracer $ withCallStack $ ClangErrorCode err
        return Nothing

{-------------------------------------------------------------------------------
  Log messages
-------------------------------------------------------------------------------}

-- | Errors and warnings resulting from interaction with clang
data ClangMsg =
    ClangErrorCode (SimpleEnum CXErrorCode)
  | ClangDiagnostic Diagnostic
  | ClangSetupMsg ClangSetup
  | ClangInvokedWithoutOptions
  deriving stock (Show)

instance PrettyForTrace ClangMsg where
  prettyForTrace = \case
      ClangErrorCode  x -> "clang error " >< PP.show x
      ClangDiagnostic diag
        | RootHeader.isInRootHeader diag.diagnosticLocation -> PP.text $
            case getFileNotFound diag.diagnosticSpelling of
              Just header -> "unable to resolve #include <" <> header <> ">"
              Nothing     -> case getFileNotFoundQ diag.diagnosticSpelling of
                Just header ->
                  "unable to resolve #include <" <> header
                    <> "> (must specify header relative to directory in C include search path)"
                Nothing     ->
                  Text.stripStart $ Text.dropWhile (/= ' ') diag.diagnosticFormatted
        | otherwise -> PP.text diag.diagnosticFormatted
      ClangSetupMsg   x -> prettyForTrace x
      ClangInvokedWithoutOptions ->
        PP.cat $ map PP.text infoHelpMessage
    where
      getFileNotFound :: Text -> Maybe Text
      getFileNotFound =
        fmap (Text.dropWhile (== '\'')) . Text.stripSuffix "' file not found"

      getFileNotFoundQ :: Text -> Maybe Text
      getFileNotFoundQ =
          fmap (Text.dropWhile (== '\'') . Text.dropWhile (/= '\''))
        . Text.stripSuffix "' file not found with <angled> include; use \"quotes\" instead"

infoHelpMessage :: [Text]
infoHelpMessage =
  [ "This command provides a way to get output from libclang."
  , " For example, use --clang-option=-v to see version and include"
  , " search path information, taking into account any other Clang"
  , " options and environment variables."
  ]


instance IsTrace Level ClangMsg where
  getDefaultLogLevel = \case
      ClangErrorCode  _          -> Error
      ClangDiagnostic x          -> if diagnosticIsError x then Error else Warning
      ClangSetupMsg   _          -> Debug
      ClangInvokedWithoutOptions -> Notice
  getSource = \case
      ClangErrorCode  _          -> Libclang
      ClangDiagnostic _          -> Libclang
      ClangSetupMsg   _          -> HsBindgen
      ClangInvokedWithoutOptions -> Libclang
  getTraceId = const "clang"