hs-bindgen-1.0.0.0: clang-ast-dump/Main.hs

{-# LANGUAGE ApplicativeDo #-}

module Main (main) where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.Default (Default (def))
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Foreign.C.Types (CUInt)
import GHC.Generics (Generic)
import Options.Applicative qualified as OA
import System.Exit (exitFailure)

import Clang.Enum.Bitfield
import Clang.Enum.Simple
import Clang.HighLevel qualified as HighLevel
import Clang.HighLevel.Types hiding (FoldException (..))
import Clang.LowLevel.Core
import Clang.LowLevel.Doxygen
import Clang.Paths

import HsBindgen.Clang
import HsBindgen.Config.ClangArgs
import HsBindgen.IR.C qualified as C
import HsBindgen.Resolve (resolveHeaders)
import HsBindgen.TraceMsg
import HsBindgen.Util.Tracer

{-------------------------------------------------------------------------------
  Options
-------------------------------------------------------------------------------}

data Options = Options {
      builtin         :: Bool
    , comments        :: Bool
    , extents         :: Bool
    , file            :: C.HashIncludeArg
    , kind            :: Bool
    , includePath     :: [FilePath]
    , clangArgsInner  :: [String]
    , sameFile        :: Bool
    , typ             :: Bool
    }

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

data AstDumpException =
    HeaderNotFound
  | ClangError
  deriving stock (Show)

instance Exception AstDumpException where
  displayException HeaderNotFound = "header not found"
  displayException ClangError     = "clang error"

{-------------------------------------------------------------------------------
  Implementation
-------------------------------------------------------------------------------}

data DumpTrace =
    DumpTraceResolveHeader ResolveHeaderMsg
  | DumpTraceClang         ClangMsg
  deriving stock (Show, Generic)
  deriving anyclass (PrettyForTrace, IsTrace Level)

clangAstDump :: Options -> IO ()
clangAstDump opts = do
    putStrLn $ "## `" ++ opts.file.path ++ "`"
    putStrLn ""

    eitherRes <- withTracer tracerConf $ \tracer -> do
      let clangArgs     = clangArgsConfigToClangArgs cArgsConfig
          tracerResolve = contramap DumpTraceResolveHeader tracer
          tracerClang   = contramap DumpTraceClang         tracer
      src <- maybe (throwIO HeaderNotFound) return . Map.lookup opts.file
          =<< resolveHeaders tracerResolve clangArgs (Set.singleton opts.file)
      let setup :: ClangSetup
          setup = (defaultClangSetup clangArgs $ ClangInputFile (realPathToSourcePath src)) {
                flags = cOpts
              }

      maybe (throwIO ClangError) return <=< withClang tracerClang setup $ \unit -> Just <$> do
        rootCursor <- clang_getTranslationUnitCursor unit
        void . HighLevel.clang_visitChildren rootCursor $ simpleFold $ \cursor -> do
          loc <- clang_getPresumedLocation =<< clang_getCursorLocation cursor
          case loc of
            (file, _, _)
              | opts.sameFile && file /= getRealPathText src -> foldContinue
              | not opts.builtin && isBuiltIn file           -> foldContinue
              | otherwise                                    -> foldDecls opts cursor
    case eitherRes of
      Left  e  -> do
        print $ prettyForTrace e
        exitFailure
      Right _  -> pure ()
  where
    tracerConf :: TracerConfig Level DumpTrace
    tracerConf = def {
        verbosity = Verbosity Debug
      }

    cArgsConfig :: ClangArgsConfig FilePath
    cArgsConfig = def {
        extraIncludeDirs = opts.includePath
      , argsInner        = opts.clangArgsInner
      }

    cOpts :: BitfieldEnum CXTranslationUnit_Flags
    cOpts = bitfieldEnum [
        CXTranslationUnit_DetailedPreprocessingRecord
      , CXTranslationUnit_IncludeAttributedTypes
      , CXTranslationUnit_VisitImplicitAttributes
      ]

    isBuiltIn :: Text -> Bool
    isBuiltIn = (`elem` [T.pack "<built-in>", T.pack "<command line>"])


foldDecls :: Options -> CXCursor -> IO (Next IO ())
foldDecls opts = \cursor -> do
    traceU_ 0 =<< clang_getCursorDisplayName cursor

    dumpParents cursor
    when opts.extents $ dumpExtent cursor

    cursorKind <- clang_getCursorKind cursor
    traceU 1 "cursor kind" cursorKind
    isDecl <- clang_isDeclaration cursorKind
    when opts.kind $
      traceWhen 2 "declaration" id isDecl

    cursorType <- clang_getCursorType cursor

    isRecurse <- case fromSimpleEnum cursorKind of
      Right CXCursor_StructDecl -> do
        dumpType cursor cursorType isDecl
        pure True
      Right CXCursor_EnumDecl -> do
        dumpType cursor cursorType isDecl
        traceU 1 "integer type" =<< clang_getEnumDeclIntegerType cursor
        pure True
      Right CXCursor_FieldDecl -> do
        dumpType cursor cursorType isDecl
        traceU 1 "field offset" =<< clang_Cursor_getOffsetOfField cursor
        isBitField <- clang_Cursor_isBitField cursor
        when isBitField $
          traceU 1 "bit width" =<< clang_getFieldDeclBitWidth cursor
        pure False -- leaf
      Right CXCursor_EnumConstantDecl -> do
        dumpType cursor cursorType isDecl
        traceU 1 "integer value" =<< clang_getEnumConstantDeclValue cursor
        pure False -- leaf
      Right CXCursor_FunctionDecl -> do
        dumpType cursor cursorType isDecl
        numArgs <- clang_getNumArgTypes cursorType
        traceU 1 "args" numArgs
        forM_ [0 .. numArgs - 1] $ \i -> do
          argType <- clang_getArgType cursorType (fromIntegral i)
          traceO_ 2 i =<< clang_getTypeSpelling argType
        resultType <- clang_getResultType cursorType
        traceU 1 "result" =<< clang_getTypeSpelling resultType
        pure False
      Right CXCursor_VarDecl -> do
        traceU 1 "eval result" =<< HighLevel.clang_evaluate cursor
        pure False
      Right CXCursor_TypedefDecl -> do
        dumpType cursor cursorType isDecl
        traceU 1 "typedef name" =<< clang_getTypedefName cursorType
        -- Results in repeated information unless the `typedef` is a
        -- declaration.
        pure True
      Right CXCursor_MacroDefinition ->
        -- TODO: Not defined yet.
        pure True
      Right CXCursor_InclusionDirective ->
        pure False -- does not matter
      Right CXCursor_UnionDecl -> do
        dumpType cursor cursorType isDecl
        pure True
      Right CXCursor_LinkageSpec -> do
        -- NOTE: The linkage specification has no display name, and so the
        -- parents of the children are unknown, that is, the empty string "".
        pure True
      Right{} -> False <$ traceL 1 "CURSOR_KIND_NOT_IMPLEMENTED"
      Left n  -> False <$ traceU 1 "CURSOR_KIND_ENUM_OUT_OF_RANGE" n

    when (isDecl && opts.comments) $ do
      commentText <- clang_Cursor_getRawCommentText cursor
      unless (T.null commentText) $ do
        traceU 1 "comment" commentText
        traceU 2 "brief" =<< clang_Cursor_getBriefCommentText cursor
        dumpComment 2 Nothing =<< clang_Cursor_getParsedComment cursor

    if isRecurse
      then foldRecurse $ simpleFold (foldDecls opts)
      else foldContinue
  where
    dumpParents :: CXCursor -> IO ()
    dumpParents cursor = do
      semanticParent <- clang_getCursorSemanticParent cursor
      lexicalParent  <- clang_getCursorLexicalParent  cursor
      parentsEq      <- clang_equalCursors semanticParent lexicalParent
      if parentsEq
        then
          traceU 1 "parent"
            =<< clang_getCursorDisplayName semanticParent
        else do
          traceU 1 "semantic parent"
            =<< clang_getCursorDisplayName semanticParent
          traceU 1 "lexical parent"
            =<< clang_getCursorDisplayName lexicalParent

    dumpExtent :: CXCursor -> IO ()
    dumpExtent cursor = do
      extent <- clang_getCursorExtent cursor
      (file, startLine, startCol) <-
        clang_getPresumedLocation =<< clang_getRangeStart extent
      (_, endLine, endCol) <-
        clang_getPresumedLocation =<< clang_getRangeEnd extent
      traceU 1 "extent" (file, (startLine, startCol), (endLine, endCol))

    dumpType :: CXCursor -> CXType -> Bool -> IO ()
    dumpType cursor cursorType isDecl = do
      traceU 1 "cursor type" =<< clang_getTypeSpelling cursorType
      when opts.typ $ do
        let typeKind = cxtKind cursorType
        traceU 2 "kind" $ fromSimpleEnum typeKind
        traceU 3 "spelling" =<< clang_getTypeKindSpelling typeKind
        traceU 2 "canonical"
          =<< clang_getTypeSpelling =<< clang_getCanonicalType cursorType
        when isDecl $ do
          decl <- HighLevel.classifyDeclaration cursor
          case decl of
            Definition -> do
              traceU 2 "declaration type" ("Definition" :: String)
              traceU 2 "sizeof"
                =<< handleCallFailed (clang_Type_getSizeOf cursorType)
              traceU 2 "alignment"
                =<< handleCallFailed (clang_Type_getAlignOf cursorType)
            DefinitionElsewhere{} ->
              traceU 2 "declaration type" ("DefinitionElsewhere" :: String)
            DefinitionUnavailable ->
              traceU 2 "declaration type" ("DefinitionUnavailable" :: String)

dumpComment :: Int -> Maybe CUInt -> CXComment -> IO ()
dumpComment level mIdx comment = do
    commentKind <- clang_Comment_getKind comment
    maybe (traceU level) (traceO level) mIdx "kind" $ fromSimpleEnum commentKind
    traceWhen level1 "whitespace" id =<< clang_Comment_isWhitespace comment

    case fromSimpleEnum commentKind of
      Right CXComment_Null -> pure ()

      Right CXComment_Text ->
        traceU level1 "text" =<< clang_TextComment_getText comment

      Right CXComment_InlineCommand -> do
        traceU level1 "name"
          =<< clang_InlineCommandComment_getCommandName comment
        traceU level1 "render kind" . fromSimpleEnum
          =<< clang_InlineCommandComment_getRenderKind comment
        numArgs <- clang_InlineCommandComment_getNumArgs comment
        when (numArgs > 0) $ do
          traceU level1 "args" numArgs
          forM_ [0 .. numArgs - 1] $ \i ->
            traceO_ level2 i =<< clang_InlineCommandComment_getArgText comment i

      Right CXComment_HTMLStartTag -> do
        traceU level1 "name" =<< clang_HTMLTagComment_getTagName comment
        traceWhen level1 "self-closing" id
          =<< clang_HTMLStartTagComment_isSelfClosing comment
        numAttrs <- clang_HTMLStartTag_getNumAttrs comment
        when (numAttrs > 0) $ do
          traceU level1 "attributes" numAttrs
          forM_ [0 .. numAttrs - 1] $ \i -> do
            traceO_ level2 i =<< clang_HTMLStartTag_getAttrName comment i
            traceU level3 "value" =<< clang_HTMLStartTag_getAttrValue comment i

      Right CXComment_HTMLEndTag -> do
        traceU level1 "name" =<< clang_HTMLTagComment_getTagName comment

      Right CXComment_Paragraph -> pure ()

      Right CXComment_BlockCommand -> do
        traceU level1 "name" =<<
          clang_BlockCommandComment_getCommandName comment
        numArgs <- clang_BlockCommandComment_getNumArgs comment
        when (numArgs > 0) $ do
          traceU level1 "args" numArgs
          forM_ [0 .. numArgs - 1] $ \i ->
            traceO_ level2 i =<< clang_BlockCommandComment_getArgText comment i
        -- NOTE paragraph is also provided by children
        -- para <- clang_BlockCommandComment_getParagraph comment
        -- traceL level1 "paragraph"
        -- dumpComment level2 Nothing para

      Right CXComment_ParamCommand -> do
        traceU level1 "name" =<< clang_ParamCommandComment_getParamName comment
        traceU level1 "index"
          =<< clang_ParamCommandComment_getParamIndex comment
        traceUnless level2 "invalid" id
          =<< clang_ParamCommandComment_isParamIndexValid comment
        traceU level1 "direction" . fromSimpleEnum
          =<< clang_ParamCommandComment_getDirection comment
        traceU level2 "explicit"
          =<< clang_ParamCommandComment_isDirectionExplicit comment

      Right CXComment_TParamCommand -> do
        traceU level1 "name" =<< clang_TParamCommandComment_getParamName comment
        traceUnless level1 "position invalid" id
          =<< clang_TParamCommandComment_isParamPositionValid comment
        depth <- clang_TParamCommandComment_getDepth comment
        traceU level1 "depth" depth
        forM_ [0 .. depth] $ \i ->
          traceO level2 i "index"
            =<< clang_TParamCommandComment_getIndex comment i

      Right CXComment_VerbatimBlockCommand -> pure ()

      Right CXComment_VerbatimBlockLine ->
        traceU level1 "text" =<< clang_VerbatimBlockLineComment_getText comment

      Right CXComment_VerbatimLine ->
        traceU level1 "text" =<< clang_VerbatimLineComment_getText comment

      Right CXComment_FullComment -> do
        traceUnless level "HTML" T.null =<< clang_FullComment_getAsHTML comment
        traceUnless level "XML"  T.null =<< clang_FullComment_getAsXML  comment

      Left n -> traceU level1 "COMMENT_KIND_ENUM_OUT_OF_RANGE" n

    numChildren <- clang_Comment_getNumChildren comment
    when (numChildren > 0) $ do
      traceU level1 "children" numChildren
      forM_ [0 .. numChildren - 1] $ \i ->
        dumpComment level2 (Just i) =<< clang_Comment_getChild comment i
  where
    level1, level2, level3 :: Int
    level1 = level + 1
    level2 = level + 2
    level3 = level + 3

{-------------------------------------------------------------------------------
  Error handling
-------------------------------------------------------------------------------}

-- | Handle 'CallFailed' exceptions, returning the hint on error
handleCallFailed :: forall a m.
     MonadIO m
  => IO a
  -> m (Either String a)
handleCallFailed action = liftIO $ first getHint <$> try action
  where
    getHint :: CallFailed -> String
    getHint (CallFailed hint _backtrace) = hint

{-------------------------------------------------------------------------------
  Trace Functions
-------------------------------------------------------------------------------}

-- | Trace Markdown list item (internal)
--
-- This function is not meant to be used directly.  Use one of the below
-- functions instead.
trace' :: (Show a, MonadIO m)
  => Int           -- ^ indentation level, from 0
  -> Maybe Int     -- ^ index of ordered list
  -> Maybe String  -- ^ label
  -> Maybe a       -- ^ value
  -> m ()
trace' level mIndex mLabel mValue = liftIO . putStrLn $ concat
    [ replicate (level * 4) ' '
    , maybe "* " ((++ ". ") . show) mIndex
    , case (mLabel, mValue) of
        (Just label, Just value) -> label ++ ": " ++ show value
        (Just label, Nothing)    -> label
        (Nothing,    Just value) -> show value
        (Nothing,    Nothing)    -> ""
    ]

-- | Trace label (unordered)
traceL :: MonadIO m
  => Int     -- ^ indentation level, from 0
  -> String  -- ^ label
  -> m ()
traceL level label = trace' @() level Nothing (Just label) Nothing

-- | Trace value (unordered, no label)
traceU_ :: (Show a, MonadIO m)
  => Int  -- ^ indentation level, from 0
  -> a    -- ^ value
  -> m ()
traceU_ level value = trace' level Nothing Nothing (Just value)

-- | Trace value (unordered, with label)
traceU :: (Show a, MonadIO m)
  => Int     -- ^ indentation level, from 0
  -> String  -- ^ label
  -> a       -- ^ value
  -> m ()
traceU level label value = trace' level Nothing (Just label) (Just value)

-- | Trace value (ordered, no label)
traceO_ :: (Integral i, Show a, MonadIO m)
  => Int  -- ^ indentation level, from 0
  -> i    -- ^ index of ordered list
  -> a    -- ^ value
  -> m ()
traceO_ level index value =
    trace' level (Just $ fromIntegral index) Nothing (Just value)

-- | Trace value (ordered, with label)
traceO :: (Integral i, Show a, MonadIO m)
  => Int     -- ^ indentation level, from 0
  -> i       -- ^ index of ordered list
  -> String  -- ^ label
  -> a       -- ^ value
  -> m ()
traceO level index label value =
    trace' level (Just $ fromIntegral index) (Just label) (Just value)

-- | Trace value when predicate holds (unordered, with label)
traceWhen :: (Show a, MonadIO m)
  => Int          -- ^ indentation level, from 0
  -> String       -- ^ label
  -> (a -> Bool)  -- ^ predicate
  -> a            -- ^ value
  -> m ()
traceWhen level label p value = when (p value) $ traceU level label value

-- | Trace value when predicate does not hold (unordered, with label)
traceUnless :: (Show a, MonadIO m)
  => Int          -- ^ indentation level, from 0
  -> String       -- ^ label
  -> (a -> Bool)  -- ^ predicate
  -> a            -- ^ value
  -> m ()
traceUnless level label p value = unless (p value) $ traceU level label value

{-------------------------------------------------------------------------------
  CLI
-------------------------------------------------------------------------------}

main :: IO ()
main = clangAstDump . uncurry applyAll =<< OA.execParser pinfo
  where
    pinfo :: OA.ParserInfo (Bool, Options)
    pinfo = OA.info (OA.helper <*> parseOptions) $ mconcat
      [ OA.fullDesc
      , OA.progDesc "Clang AST dump"
      , OA.failureCode 2
      ]

    parseOptions :: OA.Parser (Bool, Options)
    parseOptions = do
      -- flags enabled by all flag
      optComments        <- mkFlag "comments"  "show comments"
      optExtents         <- mkFlag "extents"   "show extents"
      optKind            <- mkFlag "kind"      "show kind details"
      optType            <- mkFlag "type"      "show type details"
      -- all flag
      optAll             <- mkFlag "all"       "enable all above flags"
      -- other options/arguments
      optBuiltin         <- mkFlag "builtin"   "show builtin macros"
      optSameFile        <- mkFlag "same-file" "only show from specified file"
      optIncludePath     <- includeDirOptions
      optClangArgsInner  <- clangArgsInnerOption
      optFile            <- fileArgument

      pure (optAll, Options{
          builtin        = optBuiltin
        , comments       = optComments
        , extents        = optExtents
        , file           = optFile
        , kind           = optKind
        , includePath    = optIncludePath
        , clangArgsInner = optClangArgsInner
        , sameFile       = optSameFile
        , typ            = optType
        })

    includeDirOptions :: OA.Parser [FilePath]
    includeDirOptions = OA.many . OA.strOption $ mconcat
      [ OA.short 'I'
      , OA.metavar "DIR"
      , OA.help "Include search path directory"
      ]

    clangArgsInnerOption :: OA.Parser [String]
    clangArgsInnerOption = OA.many . OA.strOption $ mconcat [
        OA.long "clang-option"
      , OA.metavar "OPTION"
      , OA.help "Pass option to clang"
      ]

    fileArgument :: OA.Parser C.HashIncludeArg
    fileArgument = fmap C.HashIncludeArg . OA.strArgument $ mconcat
      [ OA.metavar "FILE"
      , OA.help "C (header) file to parse"
      ]

    mkFlag :: String -> String -> OA.Parser Bool
    mkFlag flag doc = OA.switch $ OA.long flag <> OA.help doc

    applyAll :: Bool -> Options -> Options
    applyAll False opts = opts
    applyAll True  opts = opts {
        comments = True
      , extents  = True
      , kind     = True
      , typ      = True
      }