hs-bindgen-1.0.0.0: src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs
-- | Fold declarations
module HsBindgen.Frontend.Pass.Parse.Decl (topLevelDecl) where
import Control.Exception (Exception (..), SomeException)
import Control.Monad ((>=>))
import Data.Either (partitionEithers)
import Data.List qualified as List
import Data.Text qualified as Text
import Foreign.C (CInt)
import Clang.Enum.Simple
import Clang.HighLevel qualified as HighLevel
import Clang.HighLevel.Types
import Clang.LowLevel.Core
import HsBindgen.Runtime.Macro qualified as Runtime.Macro
import HsBindgen.Errors
import HsBindgen.Frontend.Analysis.IncludeGraph qualified as IncludeGraph
import HsBindgen.Frontend.Pass.Parse.Builtin
import HsBindgen.Frontend.Pass.Parse.Context
import HsBindgen.Frontend.Pass.Parse.Decl.Field
import HsBindgen.Frontend.Pass.Parse.Decl.Macro
import HsBindgen.Frontend.Pass.Parse.Decl.Members
import HsBindgen.Frontend.Pass.Parse.IsPass
import HsBindgen.Frontend.Pass.Parse.Monad.Decl
import HsBindgen.Frontend.Pass.Parse.Msg
import HsBindgen.Frontend.Pass.Parse.Result
import HsBindgen.Frontend.Pass.Parse.Type
import HsBindgen.Imports
import HsBindgen.IR.C qualified as C
import HsBindgen.IR.Pass
import HsBindgen.Language.C qualified as C
import HsBindgen.Macro.Error (MacroParseError)
import HsBindgen.Macro.Interface qualified as Macro
import HsBindgen.Macro.Syntax (splitMacro)
{-------------------------------------------------------------------------------
Top-level
-------------------------------------------------------------------------------}
-- | Top-level declaration
--
-- We only attach an exception handler for top-level declarations: if something
-- goes wrong with a nested declaration, we want to skip the entire outer
-- declaration.
topLevelDecl ::
Macro.Lang l
-> Fold ParseDecl (CXSourceLocation, [ParseResult l Parse])
topLevelDecl macroLang =
foldWithHandler handleParseExceptions (parseDeclTopLevel macroLang)
where
handleParseExceptions ::
CXCursor
-> SomeException
-> ParseDecl (HandlerResult (Maybe (CXSourceLocation, [ParseResult l Parse])))
handleParseExceptions curr err
| Just e <- fromException @(ExceptionInCtx DelayedParseMsg) err = do
loc <- clang_getCursorLocation curr
HandlerResult . Just . (loc,) <$> parseFailNoInfo e.ctx e.exception curr
| otherwise = return HandlerRethrow
{-------------------------------------------------------------------------------
Functions for each kind of declaration
-------------------------------------------------------------------------------}
type Parser l = CXCursor -> ParseDecl (Next ParseDecl [ParseResult l Parse])
-- | Parse declarations with available parse context
parseDeclNested ::
Macro.Lang l
-> [C.EnclosingRef Parse]
-> ParseCtx
-> Parser l
parseDeclNested macroLang enclosing ctx =
parseDecl' macroLang enclosing (Just ctx)
-- | Parse a top level declaration (parse context not yet available)
parseDeclTopLevel ::
Macro.Lang l
-> CXCursor
-> ParseDecl (Next ParseDecl (CXSourceLocation, [ParseResult l Parse]))
parseDeclTopLevel macroLang curr = do
-- By getting and attaching the location to all parse results, we
-- potentially get the location twice. We could store the 'CXSourceLocation'
-- next to all parse results and use it to retrieve the single location
-- stored in the 'DeclInfo'.
loc <- clang_getCursorLocation curr
nextDecls <- parseDecl' macroLang [] Nothing curr
-- Note the subtle difference between `foldContinue` and
-- `foldContinueWith []`: the 'Functor' instance of 'Next' drops values on
-- `Continue Nothing`, so a parser using `foldContinue` contributes no entry
-- to the result list here, whereas `foldContinueWith []` contributes an
-- empty entry (with location attached).
pure $ (loc,) <$> nextDecls
-- | Auxiliary function; use 'parseDeclNested' or 'parseDeclTopLevel'
parseDecl' ::
(HasCallStack)
=> Macro.Lang l
-> [C.EnclosingRef Parse]
-> Maybe ParseCtx
-> Parser l
parseDecl' macroLang enclosing mCtx = withCursorKindNoCtx $ \case
-- Ordinary kinds that we parse
Right CXCursor_FunctionDecl -> parseDeclWith enclosing (push C.NameKindOrdinary NotRequiredForScoping) (functionDecl macroLang)
Right CXCursor_VarDecl -> parseDeclWith enclosing (push C.NameKindOrdinary NotRequiredForScoping) (varDecl macroLang)
Right CXCursor_TypedefDecl -> parseDeclWith enclosing (push C.NameKindOrdinary RequiredForScoping) typedefDecl
Right CXCursor_MacroDefinition -> parseDeclWith enclosing (push C.NameKindMacro NotRequiredForScoping) (macroDefinition macroLang)
-- Tagged kinds that we parse
Right CXCursor_StructDecl -> parseDeclWith enclosing (push (C.NameKindTagged C.TagKindStruct) NotRequiredForScoping) (structDecl macroLang)
Right CXCursor_UnionDecl -> parseDeclWith enclosing (push (C.NameKindTagged C.TagKindUnion) NotRequiredForScoping) (unionDecl macroLang)
Right CXCursor_EnumDecl -> parseDeclWith enclosing (push (C.NameKindTagged C.TagKindEnum) NotRequiredForScoping) enumDecl
-- Process macro expansions independent of any selection predicates
Right CXCursor_MacroExpansion -> macroExpansion
-- Kinds that we skip over
Right CXCursor_AlignedAttr -> \_curr -> foldContinue
Right CXCursor_InclusionDirective -> \_curr -> foldContinue
Right CXCursor_PackedAttr -> \_curr -> foldContinue
Right CXCursor_UnexposedAttr -> \_curr -> foldContinue
Right CXCursor_UnexposedDecl -> \_curr -> foldContinue
-- @visibility@ attributes. The visibility itself the value could be
-- obtained using 'getCursorVisibility'.
Right CXCursor_VisibilityAttr -> \_curr -> foldContinue
-- Windows @__declspec(dllimport)@ / @__declspec(dllexport)@ attributes.
-- These do not affect the generated Haskell bindings: foreign imports
-- are resolved by the linker regardless of the DLL annotation.
Right CXCursor_DLLImport -> \_curr -> foldContinue
Right CXCursor_DLLExport -> \_curr -> foldContinue
-- C11 @_Static_assert@ declarations (e.g. SDL's
-- @SDL_COMPILE_TIME_ASSERT@): compile-time checks that declare
-- nothing bindable.
Right CXCursor_StaticAssert -> \_curr -> foldContinue
-- Report error for declarations we don't recognize
eKind -> case mCtx of
Nothing ->
-- Without a 'ParseCtx', we cannot attach a possible error to the
-- declaration, and so we must panic.
unavoidablePanicUnrecognizedKind eKind
Just ctx ->
failUnrecognizedKind ctx eKind >=> foldContinueWith
where
push :: C.NameKind -> RequiredForScoping -> ParseCtx
push kind scoping =
let ctx = DeclCtx kind scoping
in case mCtx of
Nothing -> mkCtx ctx
Just ctxOld -> pushCtx ctx ctxOld
-- We use a custom 'withCursorKind' function here, because the parse context
-- is not always available.
withCursorKindNoCtx :: (Either CInt CXCursorKind -> Parser l) -> Parser l
withCursorKindNoCtx k = \curr -> do
mKind <- fromSimpleEnum <$> clang_getCursorKind curr
k mKind curr
-- Unavoidably panic (!) on an unrecognized cursor kind
--
-- Only use this function if there is no way to assemble a 'HsBindgen.Frontend.Pass.Parse.Result.ParseResult'.
--
-- See 'failUnrecognizedKind'.
unavoidablePanicUnrecognizedKind ::
MonadIO m => Either CInt CXCursorKind -> CXCursor -> m b
unavoidablePanicUnrecognizedKind eKind curr = do
loc <- HighLevel.clang_getCursorLocation' curr
case eKind of
Left i ->
panicIO $ concat [
"Unrecognized CXCursorKind "
, show i
, " at "
, show loc
]
Right kind -> do
spelling <- clang_getCursorKindSpelling (simpleEnum kind)
panicIO $ concat [
"Unknown cursor of kind "
, show kind
, " ("
, Text.unpack spelling
, ") at "
, show loc
]
-- | Parse declaration
--
-- NOTE: We skip all built-ins. The only built-ins that can even /have/ an
-- associated declaration at all are macros, and those configure the compiler
-- rather than belong to the API.
parseDeclWith ::
forall l.
[C.EnclosingRef Parse]
-> ParseCtx
-> ([C.EnclosingRef Parse] -> ParseCtx -> C.DeclInfo Parse -> Parser l)
-> Parser l
parseDeclWith enclosing ctx parser curr = do
source <- getCursorSource curr
case source of
SourceBuiltin -> foldContinue
SourceDecl declLoc -> withDeclInfo enclosing ctx declLoc parseExplicitDecl curr
where
parseExplicitDecl :: C.DeclInfo Parse -> Parser l
parseExplicitDecl info = \_curr ->
if | C.Unavailable <- info.availability ->
foldContinueWith [
parseUnavailable info
]
| otherwise ->
parser enclosing ctx info curr
-- | Macros
macroDefinition ::
forall l. HasCallStack
=> Macro.Lang l
-> [C.EnclosingRef Parse]
-> ParseCtx
-> C.DeclInfo Parse -> Parser l
macroDefinition macroLang _enclosing ctx info = \curr -> do
tokens <- getMacroTokens curr
case getMacroName info.id of
Nothing -> do
failures <- parseFail ctx info.id info.loc ParseMacroDefinitionNoMacroName
foldContinueWith failures
Just macroName -> do
let split = splitMacro tokens
recordMacroDefinition macroName split
emptyMacros <- getEmptyMacros
foldContinueWith [mkResult emptyMacros split]
where
mkResult ::
EmptyMacros
-> Either MacroParseError (Runtime.Macro.Raw (Token SourcePath TokenSpelling))
-> ParseResult l Parse
mkResult emptyMacros split =
case parseMacro emptyMacros split of
Right parsed -> parseSucceed C.Decl{
info = info
, kind = C.DeclMacro parsed
, ann = NoAnn
}
Left msg -> ParseResult{
id = info.id
, loc = info.loc
, classification = ParseResultFailure msg
}
-- A macro with an empty replacement list (e.g., @#define FOO@) only reaches
-- the macro language when the user asks for it.
parseMacro ::
EmptyMacros
-> Either MacroParseError (Runtime.Macro.Raw (Token SourcePath TokenSpelling))
-> Either DelayedParseMsg (Macro.Unresolved l)
parseMacro emptyMacros split = do
macro <- first ParseMacroErrorParse split
case emptyMacros of
DoNotParseEmptyMacros | null macro.body ->
Left $ ParseMacroEmpty info.id (toList macro)
_otherwise ->
first ParseMacroErrorParse $ macroLang.parse macro
getMacroTokens :: CXCursor -> ParseDecl [Token SourcePath TokenSpelling]
getMacroTokens curr' = do
unit' <- getTranslationUnit
HighLevel.clang_tokenize unit' =<< clang_getCursorExtent curr'
getMacroName :: C.PrelimDeclId -> Maybe Text
getMacroName = \case
C.PrelimDeclIdNamed declName -> Just declName.text
C.PrelimDeclIdUnnamed{} -> Nothing
-- | Parse an struct declaration
--
-- Visibility attributes are ignored on structs, since as far as we can tell
-- they do not affect the Haskell bindings.
structDecl ::
Macro.Lang l
-> [C.EnclosingRef Parse]
-> ParseCtx
-> C.DeclInfo Parse
-> Parser l
structDecl macroLang enclosing ctx info = \curr -> do
classification <- HighLevel.classifyDeclaration curr
case classification of
Definition -> do
ty <- clang_getCursorType curr
sizeof <- clang_Type_getSizeOf ty
alignment <- clang_Type_getAlignOf ty
isAnon <- clang_Cursor_isAnonymousRecordDecl curr
let mkStruct :: [C.Field Parse] -> C.Decl l Parse
mkStruct allFields = C.Decl {
info = info
, ann = NoAnn
, kind = C.DeclStruct C.Struct{
sizeof = fromIntegral sizeof
, alignment = fromIntegral alignment
, fields = mapMaybe removePaddingFields regularFields
, flam = maybe C.NoFlam (`C.Flam` NoAnn) mFlam
, ann = IsAnon isAnon
}
}
where
(regularFields, mFlam) = partitionFields allFields
enclosing' :: [C.EnclosingRef Parse]
enclosing' = C.EnclosingRef info.id : enclosing
-- Recursively parse all members of the struct. These members include
-- field declarations and nested struct/union declarations.
parseMembersWith ty ctx (parseDeclNested macroLang enclosing') $ \membersResult ->
-- The parse results of nested struct/union declarations are returned
-- regardless of the parse status of field declarations.
--
-- NOTE: the parse results *must* be returned here. The
-- 'withImplicitFields' algorithm relies on it.
(membersResult.declMembers ++) <$>
-- If we failed to parse any of the field declarations, then we will
-- not return a struct object, because it will have missing fields
-- that are therefore inaccessible in Haskell.
case membersResult.fieldMembers of
Left failMsg ->
parseFail ctx info.id info.loc failMsg
Right fields ->
pure [parseSucceed (mkStruct fields)]
DefinitionUnavailable ->
let decl :: C.Decl l Parse
decl = C.Decl{
info = info
, kind = C.DeclOpaque Nothing
, ann = NoAnn
}
in foldContinueWith [parseSucceed decl]
DefinitionElsewhere _ ->
foldContinue
where
-- Split off FLAM, if any
partitionFields ::
[C.Field Parse]
-> ([C.Field Parse], Maybe (C.RegularField Parse))
partitionFields = go []
where
go ::
[C.Field Parse]
-> [C.Field Parse]
-> ([C.Field Parse], Maybe (C.RegularField Parse))
go acc [] = (reverse acc, Nothing)
go acc (f:fs) = case f of
-- only a regular field can be FLAM
C.FieldRegular f'
| C.TypeIncompleteArray ty <- f'.typ ->
let f'' = f' & #typ .~ ty
in (reverse acc ++ fs, Just f'')
_otherwise ->
go (f:acc) fs
-- | Parse a union declaration
--
-- Visibility attributes are ignored on unions, since as far as we can tell they
-- do not affect the Haskell bindings.
unionDecl ::
Macro.Lang l
-> [C.EnclosingRef Parse]
-> ParseCtx
-> C.DeclInfo Parse
-> Parser l
unionDecl macroLang enclosing ctx info = \curr -> do
classification <- HighLevel.classifyDeclaration curr
case classification of
Definition -> do
ty <- clang_getCursorType curr
sizeof <- clang_Type_getSizeOf ty
alignment <- clang_Type_getAlignOf ty
isAnon <- clang_Cursor_isAnonymousRecordDecl curr
let mkUnion :: [C.Field Parse] -> C.Decl l Parse
mkUnion fields = C.Decl{
info = info
, ann = NoAnn
, kind = C.DeclUnion C.Union{
sizeof = fromIntegral sizeof
, alignment = fromIntegral alignment
, fields = mapMaybe removePaddingFields fields
, ann = IsAnon isAnon
}
}
enclosing' :: [C.EnclosingRef Parse]
enclosing' = C.EnclosingRef info.id : enclosing
-- Recursively parse all members of the union. These members include
-- field declarations and nested struct/union declarations.
parseMembersWith ty ctx (parseDeclNested macroLang enclosing') $ \membersResult ->
-- The parse results of nested struct/union declarations are returned
-- regardless of the parse status of field declarations.
--
-- NOTE: the parse results *must* be returned here. The
-- 'withImplicitFields' algorithm relies on it.
(membersResult.declMembers ++) <$>
-- If we failed to parse any of the field declarations, then we will
-- not return a union object, because it will have missing fields
-- that are therefore inaccessible in Haskell.
case membersResult.fieldMembers of
Left failMsg ->
parseFail ctx info.id info.loc failMsg
Right fields ->
pure [parseSucceed (mkUnion fields)]
DefinitionUnavailable -> do
let decl :: C.Decl l Parse
decl = C.Decl{
info = info
, kind = C.DeclOpaque Nothing
, ann = NoAnn
}
foldContinueWith [parseSucceed decl]
DefinitionElsewhere _ ->
foldContinue
where
-- An unnamed bit-field is used to specify padding, using a specified
-- padding width or zero to instruct the compiler to not pack any more
-- fields into the current storage unit. This predicate is used to filter
-- out such bit-fields.
removePaddingFields :: C.Field Parse -> Maybe (C.Field Parse)
removePaddingFields = \case
C.FieldRegular field ->
if Text.null field.info.name.text && isJust field.width
then Nothing
else Just (C.FieldRegular field)
C.FieldImplicit field ->
-- implicit fields don't have a bit-width
Just (C.FieldImplicit field)
typedefDecl ::
forall l.
[C.EnclosingRef Parse]
-> ParseCtx
-> C.DeclInfo Parse
-> Parser l
typedefDecl _enclosing ctx info = \curr -> do
typedefType <-
fromCXType ctx =<< clang_getTypedefDeclUnderlyingType curr
declKind <-
case typedefType of
C.TypeVoid ->
-- We regard
--
-- > typedef void foo
--
-- as the declaration of an opaque type.
return (C.DeclOpaque Nothing)
_otherwise -> do
typedefAnn <- getReparseInfo curr
return $ C.DeclTypedef C.Typedef{
typ = typedefType
, ann = typedefAnn
}
let decl :: C.Decl l Parse
decl = C.Decl{
info = info
, kind = declKind
, ann = NoAnn
}
foldContinueWith [parseSucceed decl]
macroExpansion :: Parser l
macroExpansion = \curr -> do
(range, tokens) <- getTokens curr
case getMacroName tokens of
-- TODO <https://github.com/well-typed/hs-bindgen/issues/1554>
--
-- Attach failed macroName message to declaration.
Nothing -> traceImmediateGlobal ParseMacroExpansionNoMacroName
Just macroName -> recordMacroExpansionAt macroName range tokens
foldContinue
where
getTokens ::
CXCursor
-> ParseDecl (Range (MultiLoc RealPath), [Token SourcePath TokenSpelling])
getTokens curr' = do
unit' <- getTranslationUnit
range <- HighLevel.clang_getCursorExtent curr'
tokens <- HighLevel.clang_tokenize unit' =<< clang_getCursorExtent curr'
pure (range, tokens)
getMacroName :: [Token SourcePath TokenSpelling] -> Maybe Text
getMacroName [] = Nothing
-- The spelling of function macros includes the function parameters. For
-- example, when expanding
--
-- #define ID(X) (X)
-- void foo(int ID(z));
--
-- the pretty printed tokens at expansion location are "ID ( z )" instead of
-- just the macro name "ID". We believe that in `hs-bindgen` it is enough to
-- identify macros by their first token only, because the name of macro
-- functions in `hs-bindgen` also corresponds to this first token. That is,
-- in `hs-bindgen`,
--
-- #define ID
-- #define ID(X) (X)
--
-- are conflicting (macro) declarations.
getMacroName (x:_) =
let macroName = getTokenSpelling $ tokenSpelling x
in if Text.null macroName; then
Nothing
else
Just macroName
-- | Parse an enum declaration
--
-- Visibility attributes are ignored on enums, since as far as we can tell they
-- do not affect the Haskell bindings.
enumDecl ::
[C.EnclosingRef Parse]
-> ParseCtx
-> C.DeclInfo Parse
-> Parser l
enumDecl _enclosing ctx info = \curr -> do
classification <- HighLevel.classifyDeclaration curr
case classification of
Definition -> do
ty <- clang_getCursorType curr
sizeof <- clang_Type_getSizeOf ty
alignment <- clang_Type_getAlignOf ty
ety <- fromCXType ctx =<< clang_getEnumDeclIntegerType curr
-- The underlying type of a C enum is always an integer type, so
-- clang_getEnumDeclIntegerType only returns TypePrim (e.g. unsigned
-- int) or TypeTypedef wrapping one (e.g. uint8_t). The fallback to
-- Signed is conservative and should be unreachable in practice.
--
let enumSign :: C.PrimSign
enumSign = go ety
where
go (C.TypePrim pt) = C.primTypeSign pt
go (C.TypeTypedef ref) = go ref.underlying
go _ = C.Signed
let parseConstant ::
Fold ParseDecl (Either DelayedParseMsg (C.EnumConstant Parse))
parseConstant = simpleFold $ \curr' -> do
mKind <- fromSimpleEnum <$> clang_getCursorKind curr'
case mKind of
Right CXCursor_EnumConstantDecl ->
fmap Right <$> enumConstantDecl enumSign curr'
Right CXCursor_PackedAttr ->
foldContinue
-- @visibility@ attributes. The visibility itself the value can be
-- obtained using 'getCursorVisibility'.
Right CXCursor_VisibilityAttr -> foldContinue
-- Windows @__declspec(dllimport)@ / @__declspec(dllexport)@.
-- These don't affect the generated Haskell bindings.
Right CXCursor_DLLImport -> foldContinue
Right CXCursor_DLLExport -> foldContinue
unexpectedKind -> foldContinueWith
(Left $ ParseUnexpectedCursorKind unexpectedKind)
let mkEnum ::
[Either DelayedParseMsg (C.EnumConstant Parse)]
-> ParseDecl [ParseResult l Parse]
mkEnum eConstants = case partitionEithers eConstants of
([], constants) -> pure $ (:[]) $ parseSucceed $ C.Decl{
info = info
, ann = NoAnn
, kind = C.DeclEnum C.Enum{
typ = ety
, sizeof = fromIntegral sizeof
, alignment = fromIntegral alignment
, constants = constants
, ann = NoAnn
}
}
-- If there are errors, report the first one.
(msg:_, _) -> parseFail ctx info.id info.loc msg
foldRecurseWith parseConstant mkEnum
DefinitionUnavailable -> do
let decl :: C.Decl l Parse
decl = C.Decl{
info = info
, kind = C.DeclOpaque Nothing
, ann = NoAnn
}
foldContinueWith [parseSucceed decl]
DefinitionElsewhere _ ->
foldContinue
enumConstantDecl ::
C.PrimSign
-> CXCursor
-> ParseDecl (Next ParseDecl (C.EnumConstant Parse))
enumConstantDecl sign = \curr -> do
enumConstantInfo <- getFieldInfo curr
enumConstantValue <- case sign of
C.Unsigned -> toInteger <$> clang_getEnumConstantDeclUnsignedValue curr
C.Signed -> toInteger <$> clang_getEnumConstantDeclValue curr
foldContinueWith C.EnumConstant {
info = enumConstantInfo
, value = enumConstantValue
}
functionDecl ::
forall l.
Macro.Lang l
-> [C.EnclosingRef Parse]
-> ParseCtx
-> C.DeclInfo Parse
-> Parser l
functionDecl macroLang enclosing ctx info =
withCursorVisibility ctx info $ \visibility ->
withCursorLinkage ctx info $ \linkage ->
aux visibility linkage
where
aux :: Visibility -> Linkage -> Parser l
aux visibility linkage curr = do
declCls <- HighLevel.classifyDeclaration curr
typ <- fromCXType ctx =<< clang_getCursorType curr
guardTypeFunction curr typ >>= \case
Left rs -> foldContinueWith rs
Right (functionArgs, functionRes) -> do
functionAnn <- getReparseInfo curr
let mkDecl :: C.FunctionPurity -> C.Decl l Parse
mkDecl purity = C.Decl{
info = info
, ann = NoAnn
, kind = C.DeclFunction C.Function {
args = functionArgs
, res = functionRes
, attrs = C.FunctionAttributes purity
, ann = functionAnn
}
}
case declCls of
-- The header contains a definition elsewhere, but it is not the
-- declaration that the cursor is currently pointing to. Skip this
-- declaration.
DefinitionElsewhere _->
foldContinue
_ -> foldRecurseWith nestedDecl $ \nestedDecls -> do
let declsAndAttrs = concat nestedDecls
(parseRs, attrs) = partitionEithers declsAndAttrs
(fails, decls) = partitionEithers $
map getParseResultEitherDecl parseRs
purity = C.decideFunctionPurity attrs
(unnamedDecls, otherDecls) = partitionUnnamedDecls decls
-- This declaration may act as a definition.
let isDefn = declCls == Definition
(fails ++) <$>
if not (null unnamedDecls) then do
parseFail ctx info.id info.loc ParseUnsupportedUnnamedInSignature
else
let nonPublicVisibility = [
ParseNonPublicVisibility
| visibilityCanCauseErrors visibility linkage isDefn
]
potentialDuplicate = [
ParsePotentialDuplicateSymbol (visibility == PublicVisibility)
| isDefn && linkage == ExternalLinkage
]
msgs = nonPublicVisibility ++ potentialDuplicate
funDeclResult = parseSucceedWith msgs (mkDecl purity)
in pure $ map parseSucceed otherDecls ++ [funDeclResult]
guardTypeFunction ::
CXCursor
-> C.Type Parse
-> ParseDecl (
Either
[ParseResult l Parse]
([C.FunctionArg Parse], C.Type Parse)
)
guardTypeFunction curr ty =
case ty of
C.TypeFun args res -> do
args' <- forM (zip args [0 :: Int ..]) $ \(argCType, i) -> do
argCursor <- clang_Cursor_getArgument curr i
argName <- clang_getCursorDisplayName argCursor
let mbArgName =
if Text.null argName
then Nothing
else Just (C.ScopedName argName)
return C.FunctionArg{
name = mbArgName
, typ = argCType.typ
, ann = argCType.ann
}
pure $ Right (args', res)
C.TypeTypedef{} ->
Left <$>
(parseFail ctx info.id info.loc ParseFunctionOfTypeTypedef)
otherType ->
Left <$>
(parseFail ctx info.id info.loc $
ParseExpectedFunctionType $ show otherType)
-- Look for (unsupported) declarations inside function parameters, and for
-- function attributes. Function attributes are returned separately, so that
-- we can pair them with the parent function.
nestedDecl :: Fold ParseDecl [Either (ParseResult l Parse) C.FunctionPurity]
nestedDecl = simpleFold $ \curr -> do
kind <- fromSimpleEnum <$> clang_getCursorKind curr
let enclosing' :: [C.EnclosingRef Parse]
enclosing' = C.EnclosingRef info.id : enclosing
case kind of
-- 'ParmDecl' sometimes appear in nested in the AST
Right CXCursor_ParmDecl ->
foldRecurseWith nestedDecl (return . concat)
-- Nested declarations
Right CXCursor_StructDecl -> fmap (fmap Left) <$> parseDeclNested macroLang enclosing' ctx curr
Right CXCursor_UnionDecl -> fmap (fmap Left) <$> parseDeclNested macroLang enclosing' ctx curr
-- Harmless
Right CXCursor_TypeRef -> foldContinue
Right CXCursor_IntegerLiteral -> foldContinue
Right CXCursor_UnexposedAttr -> foldContinue
-- @const@ and @pure@ function attributes.
Right CXCursor_ConstAttr -> foldContinueWith $ [Right C.HaskellPureFunction]
Right CXCursor_PureAttr -> foldContinueWith $ [Right C.CPureFunction]
-- @visibility@ attributes. The visibility itself the value is
-- obtained using 'getCursorVisibility'.
Right CXCursor_VisibilityAttr -> foldContinue
-- Windows @__declspec(dllimport)@ / @__declspec(dllexport)@
-- attributes. These do not affect the generated Haskell bindings.
Right CXCursor_DLLImport -> foldContinue
Right CXCursor_DLLExport -> foldContinue
-- Attributes we (probably?) want to ignore
Right CXCursor_WarnUnusedResultAttr -> foldContinue
-- Function body
Right CXCursor_CompoundStmt -> foldContinue
-- We are not interested in assembler labels.
Right CXCursor_AsmLabelAttr -> foldContinue
-- Fail on anything else. We could instead use 'foldContinue' here,
-- but this is safer.
otherKind -> do
failures <-
parseFail ctx info.id info.loc
(ParseUnexpectedCursorKind otherKind)
foldContinueWith $ map Left failures
-- | Global variable declaration
varDecl ::
forall l.
Macro.Lang l
-> [C.EnclosingRef Parse]
-> ParseCtx
-> C.DeclInfo Parse
-> Parser l
varDecl macroLang enclosing ctx info = do
withCursorVisibility ctx info $ \visibility ->
withCursorLinkage ctx info $ \linkage ->
aux visibility linkage
where
aux :: Visibility -> Linkage -> Parser l
aux visibility linkage curr = do
declCls <- HighLevel.classifyDeclaration curr
typ <- fromCXType ctx =<< clang_getCursorType curr
cls <- classifyVarDecl curr
let mkDecl :: C.DeclKind l Parse -> C.Decl l Parse
mkDecl kind = C.Decl{
info = info
, kind = kind
, ann = NoAnn
}
case declCls of
-- The header contains a definition elsewhere, but it is not the
-- declaration that the cursor is currently pointing to. Skip this
-- declaration.
DefinitionElsewhere _->
foldContinue
_ -> foldRecurseWith nestedDecl $ \nestedRs -> do
let
(fails, nestedDecls) = partitionEithers $
map getParseResultEitherDecl $
concat nestedRs
(unnamedDecls, otherDecls) = partitionUnnamedDecls nestedDecls
-- This declaration may act as a definition even if it has no
-- initialiser.
isTentative <- HighLevel.classifyTentativeDefinition curr
let isDefn = declCls == Definition
|| (isTentative && declCls == DefinitionUnavailable)
(fails ++) <$>
let nonPublicVisibility = [
ParseNonPublicVisibility
| visibilityCanCauseErrors visibility linkage isDefn
]
potentialDuplicate = [
ParsePotentialDuplicateSymbol (visibility == PublicVisibility)
| isDefn && linkage == ExternalLinkage
]
msgs = nonPublicVisibility ++ potentialDuplicate
in case cls of
VarGlobal IsExtern
| not (null unnamedDecls) -> do
parseFail ctx info.id info.loc ParseUnsupportedUnnamedInExtern
VarGlobal _ -> do
globalAnn <- getReparseInfo curr
pure $ (map parseSucceed (unnamedDecls ++ otherDecls) ++) $
singleton $ parseSucceedWith msgs $
mkDecl $ C.DeclGlobal C.Global{
typ = typ
, ann = globalAnn
}
VarThreadLocal ->
parseFail ctx info.id info.loc ParseUnsupportedTLS
VarUnsupported storage ->
parseFail ctx info.id info.loc $ ParseUnknownStorageClass storage
-- Look for nested declarations inside the global variable type
nestedDecl :: Fold ParseDecl [ParseResult l Parse]
nestedDecl =
let enclosing' = C.EnclosingRef info.id : enclosing
in simpleFold $ withCursorKind ctx $ \case
-- Reference to previously declared type can safely be skipped
CXCursor_TypeRef -> skip
-- Nested /new/ declarations
CXCursor_StructDecl -> parseDeclNested macroLang enclosing' ctx
CXCursor_UnionDecl -> parseDeclNested macroLang enclosing' ctx
CXCursor_EnumDecl -> parseDeclNested macroLang enclosing' ctx
-- Initializers
--
-- It's a bit annoying that we have to explicitly enumerate them, but
-- a catch-all may result in us ignoring nodes that we shouldn't.
--
-- The order here roughly matches the order of 'CXCursor'.
-- <https://clang.llvm.org/doxygen/group__CINDEX.html#gaaccc432245b4cd9f2d470913f9ef0013>
CXCursor_IntegerLiteral -> skip
CXCursor_FloatingLiteral -> skip
CXCursor_ImaginaryLiteral -> skip
CXCursor_StringLiteral -> skip
CXCursor_ParenExpr -> skip
CXCursor_UnaryOperator -> skip
CXCursor_BinaryOperator -> skip
CXCursor_ConditionalOperator -> skip
CXCursor_CStyleCastExpr -> skip
CXCursor_InitListExpr -> skip
CXCursor_CXXBoolLiteralExpr -> skip -- Since C23
-- Some initializers are \"unexposed\".
--
-- Not sure exactly when clang decides to expose an expression and
-- when it does not, but it seems it does this when constructing
-- /pointers/ to values, such as
--
-- > char* x = "hi"; // CXCursor_StringLiteral?
-- > int* y = (int []){2, 4, 6}; // CXCursor_CompoundLiteralExpr?
--
-- String literals /are/ exposed when declaring an array:
--
-- > char z = "hi";
--
-- The only other example I'm currently aware of is characters
-- ('CXCursor_CharacterLiteral').
CXCursor_UnexposedExpr -> skip
CXCursor_DeclRefExpr -> skip
-- @visibility@ attributes, where the value is obtained using
-- @clang_getCursorVisibility@.
CXCursor_VisibilityAttr -> skip
-- Windows @__declspec(dllimport)@ / @__declspec(dllexport)@
-- attributes. These do not affect the generated Haskell bindings.
CXCursor_DLLImport -> skip
CXCursor_DLLExport -> skip
-- We are not interested in assembler labels.
CXCursor_AsmLabelAttr -> skip
-- Function types
CXCursor_ParmDecl -> skip
-- Fail on anything we don't recognize
otherKind -> \_curr -> do
failures <-
parseFail ctx info.id info.loc
(ParseUnexpectedCursorKind $ Right otherKind)
foldContinueWith failures
skip :: MonadIO m => b -> m (Next m a)
skip = const foldContinue
{-------------------------------------------------------------------------------
Utility: dispatching based on the cursor kind
-------------------------------------------------------------------------------}
-- | Fail safely due to an unrecognized cursor kind
--
-- Assemble a parse failure
failUnrecognizedKind ::
ParseCtx
-> Either CInt CXCursorKind
-> CXCursor
-> ParseDecl [ParseResult l Parse]
failUnrecognizedKind ctx eKind curr =
let msg = ParseUnexpectedCursorKind eKind
in parseFailNoInfo ctx msg curr
-- | Obtain cursor kind and run continuation
--
-- Only run continuation if the cursor kind can be obtain, otherwise fail with a
-- 'HsBindgen.Frontend.Pass.Parse.Msg.DelayedParseMsg'.
withCursorKind ::
ParseCtx
-> (CXCursorKind -> Parser l)
-> Parser l
withCursorKind ctx k = \curr -> do
mKind <- fromSimpleEnum <$> clang_getCursorKind curr
case mKind of
Right kind -> k kind curr
Left i -> failUnrecognizedKind ctx (Left i) curr >>= foldContinueWith
{-------------------------------------------------------------------------------
Info that we collect for all declarations
-------------------------------------------------------------------------------}
-- | Parse with declaration info
--
-- The continuation is only called when the declaration info can be determined.
withDeclInfo ::
[C.EnclosingRef Parse]
-> ParseCtx
-> SingleLoc C.DeclPath
-> (C.DeclInfo Parse -> Parser l)
-> Parser l
withDeclInfo enclosing ctx declLoc k = \curr -> do
declId <- C.prelimDeclIdAtCursor curr ctx.inner.kind
(withOrigin ctx declId declLoc $ \origin ->
withAvailability ctx declId declLoc $ \availability curr' -> do
let info :: C.DeclInfo Parse
info = C.DeclInfo{
loc = declLoc
, id = declId
-- We initialize the source-order index to 'Nothing', and
-- populate it when consolidating macros with non-macros in
-- "HsBindgen.Frontend.Pass.Parse".
, sourceOrderIndex = Nothing
, origin = origin
, availability = availability
, comment = ()
, enclosing = enclosing
}
k info curr') curr
-- | Continue with availability
--
-- The continuation is only called when the availability can be determined.
withAvailability ::
ParseCtx
-> C.PrelimDeclId
-> SingleLoc C.DeclPath
-> (C.Availability -> Parser l)
-> Parser l
withAvailability ctx declId declLoc k = \curr -> do
sAvailability <- clang_getCursorAvailability curr
let mAvailability :: Maybe C.Availability
mAvailability = fmap toAvailability $ fromSimple $ sAvailability
case mAvailability of
Nothing -> do
failures <-
parseFail ctx declId declLoc $
ParseUnknownCursorAvailability sAvailability
foldContinueWith failures
Just availability -> k availability curr
where
fromSimple :: IsSimpleEnum a => SimpleEnum a -> Maybe a
fromSimple x = either (const Nothing) Just $ fromSimpleEnum x
toAvailability :: CXAvailabilityKind -> C.Availability
toAvailability = \case
CXAvailability_Available -> C.Available
CXAvailability_Deprecated -> C.Deprecated
CXAvailability_NotAvailable -> C.Unavailable
CXAvailability_NotAccessible -> C.Unavailable
-- | Continue with the origin of a declaration
--
-- The continuation is only called when the origin can be determined.
withOrigin ::
ParseCtx
-> C.PrelimDeclId
-> SingleLoc C.DeclPath
-> (C.DeclOrigin -> Parser l)
-> Parser l
withOrigin ctx declId declLoc k = case declLoc.singleLocPath of
C.OnCommandLine -> k C.FromCommandLine
C.InRootHeader -> k C.FromRootDirective
C.InHeader realPath ->
withHeaderInfo ctx declId declLoc realPath (k . C.FromHeader)
-- | Continue with header information
--
-- The continuation is only called when the header information can be determined.
withHeaderInfo ::
ParseCtx
-> C.PrelimDeclId
-> SingleLoc C.DeclPath
-> RealPath
-> (C.HeaderInfo -> Parser l)
-> Parser l
withHeaderInfo ctx declId declLoc realPath k = \curr -> do
eRes <- evalGetMainHeadersAndInclude realPath
case eRes of
Left err -> do
failures <- parseFail ctx declId declLoc err
foldContinueWith failures
Right res ->
k (uncurry aux res) curr
where
aux :: NonEmpty C.HashIncludeArg -> IncludeGraph.Include -> C.HeaderInfo
aux mainHeaders include = C.HeaderInfo{
mainHeaders = mainHeaders
, includeArg = IncludeGraph.getIncludeArg include
, includeMacroArg = IncludeGraph.getIncludeMacroArg include
}
-- | The linkage of a linker symbol determines whether or not a linker symbol is
-- visible to the linker outside the translation unit it is defined in.
--
-- See the section on Visibility in the manual for more details.
data Linkage =
InternalLinkage
| NoLinkage
| ExternalLinkage
deriving stock (Show, Eq, Generic)
-- | Retrieve the linkage of the entity that the cursor is currently pointing
-- to.
--
-- Only call continuation if linkage can be retrieved.
withCursorLinkage ::
ParseCtx
-> C.DeclInfo Parse
-> (Linkage -> Parser l)
-> Parser l
withCursorLinkage ctx info k = \curr -> do
simpleLinkage <- clang_getCursorLinkage curr
case fromSimpleLinkage simpleLinkage of
Left err -> parseFail ctx info.id info.loc err >>= foldContinueWith
Right l -> k l curr
where
fromSimpleLinkage ::
SimpleEnum CXLinkageKind
-> Either DelayedParseMsg Linkage
fromSimpleLinkage simpleLinkage =
case fromSimpleEnum simpleLinkage of
Right linkage' -> case linkage' of
CXLinkage_Invalid ->
Left ParseInvalidLinkage
CXLinkage_NoLinkage ->
Right NoLinkage
CXLinkage_Internal ->
Right InternalLinkage
CXLinkage_UniqueExternal ->
Left $ ParseUnsupportedLinkage "C++ specific" linkage'
CXLinkage_External ->
Right ExternalLinkage
Left x -> do
Left $ ParseUnexpectedLinkage (Left x)
-- | The visibility of a linker symbol determines whether or not a linker symbol
-- is visible to the linker outside of the shared object that it is defined in.
--
-- See the section on Visibility in the manual for more details.
data Visibility =
PublicVisibility
| NonPublicVisibility
deriving stock (Show, Eq, Generic)
-- | Retrieve the visibility of the entity that the cursor is currently pointing
-- to.
--
-- Only call continuation if cursor visibility can be retrieved.
withCursorVisibility ::
ParseCtx
-> C.DeclInfo Parse
-> (Visibility -> Parser l)
-> Parser l
withCursorVisibility ctx info k = \curr -> do
simpleVisibility <- clang_getCursorVisibility curr
case fromSimpleVisibility simpleVisibility of
Left err -> parseFail ctx info.id info.loc err >>= foldContinueWith
Right v -> k v curr
where
fromSimpleVisibility ::
SimpleEnum CXVisibilityKind
-> Either DelayedParseMsg Visibility
fromSimpleVisibility simpleVisibility =
case fromSimpleEnum simpleVisibility of
-- See https://clang.llvm.org/doxygen/group__CINDEX__CURSOR__MANIP.html#gaf92fafb489ab66529aceab51818994cb
Right vis' -> case vis' of
-- Despite the name, /default/ always means public.
CXVisibility_Default ->
Right PublicVisibility
CXVisibility_Hidden ->
Right NonPublicVisibility
-- This visibility is rarely useful in practice. For binding generation,
-- we treat it as non-public visibility.
CXVisibility_Protected ->
Right NonPublicVisibility
CXVisibility_Invalid ->
Left $ ParseInvalidVisibility
Left x ->
Left $ ParseUnexpectedVisibility (Left x)
{-------------------------------------------------------------------------------
Internal auxiliary
-------------------------------------------------------------------------------}
-- | Partition declarations into named and unnamed
--
-- We are only interested in the name of the declaration /itself/; if a named
-- declaration /contains/ unnamed declarations, that's perfectly fine.
partitionUnnamedDecls ::
[C.Decl l Parse]
-> ([C.Decl l Parse], [C.Decl l Parse])
partitionUnnamedDecls =
List.partition $ \decl -> declIdIsUnnamed decl.info.id
where
declIdIsUnnamed :: C.PrelimDeclId -> Bool
declIdIsUnnamed C.PrelimDeclIdUnnamed{} = True
declIdIsUnnamed _otherwise = False
-- | Whether a global variable has @extern@ storage class
--
-- This is only used locally during parsing to reject extern declarations with
-- unnamed types; it is not propagated into the AST.
data IsExtern = IsExtern | IsNotExtern
deriving stock (Show)
data VarClassification =
-- | Global variable (mutable or const)
--
-- > extern int simpleGlobal;
-- > extern const int globalConstant;
-- > static const int staticConst = 123;
--
-- NOTE: @static@ can be useful to be able to specify the /value/ of the
-- constant in the header file (perhaps so that the compiler can inline it).
-- Without @const@, @static@ results in a mutable variable local to any C
-- file that includes the header, invisible to the C API. Arguably this does
-- not make much sense, but it does occur in real-world code (e.g. device
-- driver headers), so we accept it nonetheless.
--
-- TODO <https://github.com/well-typed/hs-bindgen/issues/829>
-- We could in principle expose the /value/ of the constant, if we know it.
VarGlobal IsExtern
-- | Thread local variables
--
-- We don't currently support thread-local variables.
-- <https://github.com/well-typed/hs-bindgen/issues/828>
--
-- This is a special case of 'VarUnsupported', for better error reporting.
| VarThreadLocal
-- | Unsupported storage class
| VarUnsupported (SimpleEnum CX_StorageClass)
deriving stock (Show)
classifyVarDecl :: MonadIO m => CXCursor -> m VarClassification
classifyVarDecl = \curr -> do
tls <- clang_getCursorTLSKind curr
case fromSimpleEnum tls of
Right CXTLS_None -> do
storage <- clang_Cursor_getStorageClass curr
case fromSimpleEnum storage of
Right CX_SC_Extern -> return $ VarGlobal IsExtern
Right CX_SC_None -> return $ VarGlobal IsNotExtern
Right CX_SC_Static -> return $ VarGlobal IsNotExtern
_otherwise -> return $ VarUnsupported storage
_otherwise ->
return VarThreadLocal
-- | Check if a function declaration or global variable declaration has a
-- problematic case of non-public visibility.
--
-- See the section on Visibility in the manual for more details.
visibilityCanCauseErrors ::
Visibility
-> Linkage
-> Bool
-- ^ Whether the declaration acts as a definition
--
-- Tentative definitions can also act as definitions if there are no full
-- definitions in scope.
-> Bool
visibilityCanCauseErrors NonPublicVisibility ExternalLinkage False = True
visibilityCanCauseErrors _ _ _ = False