hs-bindgen-1.0.0.0: src-internal/HsBindgen/Test/C.hs
module HsBindgen.Test.C (
genTestsC
) where
import HsBindgen.Backend.Category
import HsBindgen.Backend.Hs.AST qualified as Hs
import HsBindgen.Errors
import HsBindgen.IR.C qualified as C
{-------------------------------------------------------------------------------
Generation
-------------------------------------------------------------------------------}
-- | Generate C test header and source files
genTestsC ::
FilePath -- ^ C test header file path
-> FilePath -- ^ C test source file path
-> [C.RootDirective C.HashIncludeArg]
-- ^ Root directives (rendered verbatim)
-> ByCategory_ [Hs.Decl l] -- ^ Declarations
-> IO ()
genTestsC = throwPure_TODO 22 "generate test suite"
{-
genTestsC cTestHeaderPath cTestSourcePath lineLength cHeaderPath decls = do
writeFile cTestHeaderPath $ renderPretty ctx CTestHeader{..}
writeFile cTestSourcePath $ renderPretty ctx CTestSource{..}
where
ctx :: Context
ctx = mkContext lineLength
cTestHeaderFilename, cHeaderFilename :: FilePath
cTestHeaderFilename = FilePath.takeFileName cTestHeaderPath
cHeaderFilename = Posix.takeFileName $ getHashIncludeArg cHeaderPath
cFunPrefix :: CFunPrefix
cFunPrefix = getCFunPrefix cTestHeaderFilename
cTestHeaderIncludeGuard :: IncludeGuard
cTestHeaderIncludeGuard = getIncludeGuard cTestHeaderFilename
cTestHeaderUsrIncludes, cTestHeaderSysIncludes :: [IncludeFile]
cTestHeaderUsrIncludes = [cHeaderFilename]
cTestHeaderSysIncludes = ["stdbool.h", "stddef.h"]
cTestHeaderDecls :: [CTestDecl]
cTestHeaderDecls = concatMap (getTestHeaderDecls cFunPrefix) decls
cTestSourceUsrIncludes, cTestSourceSysIncludes :: [IncludeFile]
cTestSourceUsrIncludes = List.sort
["hs_bindgen_test_runtime.h" , cHeaderFilename , cTestHeaderFilename]
cTestSourceSysIncludes = ["stdalign.h", "stdbool.h", "stddef.h"]
cTestSourceDefns :: [CTestDefn]
cTestSourceDefns = concatMap (getTestSourceDefns cFunPrefix) decls
getTestHeaderDecls :: CFunPrefix -> Hs.Decl -> [CTestDecl]
getTestHeaderDecls cFunPrefix = \case
Hs.DeclDefineInstance instanceDecl -> case instanceDecl of
Hs.InstanceStorable Hs.Struct{..} _storableInstance ->
case getStructCTypeSpelling structOrigin of
Just cts ->
[ CTestSizeofDecl cFunPrefix structName
, CTestAlignofDecl cFunPrefix structName
, CTestGenseqhsDecl cFunPrefix structName cts
, CTestGenseqcDecl cFunPrefix structName cts
, CTestPerturbDecl cFunPrefix structName cts
]
Nothing -> []
_otherwise -> []
_otherwise -> []
getTestSourceDefns :: CFunPrefix -> Hs.Decl -> [CTestDefn]
getTestSourceDefns cFunPrefix = \case
Hs.DeclDefineInstance instanceDecl -> case instanceDecl of
Hs.InstanceStorable Hs.Struct{..} _storableInstance ->
case getStructCTypeSpelling structOrigin of
Just cts ->
let fieldPs = getFieldP <$> structFields
in [ CTestSizeofDefn cFunPrefix structName cts
, CTestAlignofDefn cFunPrefix structName cts
, CTestGenseqhsDefn cFunPrefix structName cts fieldPs
, CTestGenseqcDefn cFunPrefix structName cts fieldPs
, CTestPerturbDefn cFunPrefix structName cts fieldPs
]
Nothing -> []
_otherwise -> []
_otherwise -> []
getStructCTypeSpelling :: Hs.StructOrigin -> Maybe CTypeSpelling
getStructCTypeSpelling = \case
Hs.StructOriginStruct C.Struct{..} -> case structDeclPath of
C.DeclPathAnon ctxt ->
case ctxt of
C.DeclPathCtxtTypedef typedefName ->
Just $ T.unpack (C.getName typedefName)
_otherwise ->
Nothing
C.DeclPathName cName ->
Just $ "struct " ++ T.unpack (C.getName cName)
Hs.StructOriginEnum{} -> Nothing
getFieldP :: Hs.Field -> FieldP
getFieldP Hs.Field{..} = (cName, hsTypeName)
where
cName :: C.Name
cName = case fieldOrigin of
Hs.FieldOriginNone -> panicPure "unexpected FieldOriginNone in struct"
Hs.FieldOriginStructField cStructField -> C.fieldName cStructField
hsTypeName :: HsTypeName
hsTypeName = case fieldType of
Hs.HsPrimType hsPrimType -> case hsPrimType of
HsT.HsPrimCChar -> "CChar"
HsT.HsPrimCSChar -> "CSChar"
HsT.HsPrimCUChar -> "CUChar"
HsT.HsPrimCInt -> "CInt"
HsT.HsPrimCUInt -> "CUInt"
HsT.HsPrimCShort -> "CShort"
HsT.HsPrimCUShort -> "CUShort"
HsT.HsPrimCLong -> "CLong"
HsT.HsPrimCULong -> "CULong"
HsT.HsPrimCLLong -> "CLLong"
HsT.HsPrimCULLong -> "CULLong"
HsT.HsPrimCBool -> "CBool"
HsT.HsPrimCFloat -> "CFloat"
HsT.HsPrimCDouble -> "CDouble"
HsT.HsPrimCPtrDiff -> "CPtrdiff"
HsT.HsPrimCSize -> "CSize"
x -> throwPure_TODO 447 $ "not supported: " ++ show (typeOf x)
x -> throwPure_TODO 447 $ "not supported: " ++ show (typeOf x)
{-------------------------------------------------------------------------------
AST
-------------------------------------------------------------------------------}
type CTypeSpelling = String
type FieldP = (C.Name, HsTypeName)
type HsTypeName = String
type IncludeFile = String
type IncludeGuard = String
data CTestHeader = CTestHeader {
cTestHeaderIncludeGuard :: IncludeGuard
, cTestHeaderUsrIncludes :: [IncludeFile]
, cTestHeaderSysIncludes :: [IncludeFile]
, cTestHeaderDecls :: [CTestDecl]
}
data CTestDecl =
CTestSizeofDecl CFunPrefix (HsName NsTypeConstr)
| CTestAlignofDecl CFunPrefix (HsName NsTypeConstr)
| CTestGenseqhsDecl CFunPrefix (HsName NsTypeConstr) CTypeSpelling
| CTestGenseqcDecl CFunPrefix (HsName NsTypeConstr) CTypeSpelling
| CTestPerturbDecl CFunPrefix (HsName NsTypeConstr) CTypeSpelling
data CTestSource = CTestSource {
cTestSourceUsrIncludes :: [IncludeFile]
, cTestSourceSysIncludes :: [IncludeFile]
, cTestSourceDefns :: [CTestDefn]
}
data CTestDefn =
CTestSizeofDefn CFunPrefix (HsName NsTypeConstr) CTypeSpelling
| CTestAlignofDefn CFunPrefix (HsName NsTypeConstr) CTypeSpelling
| CTestGenseqhsDefn CFunPrefix (HsName NsTypeConstr) CTypeSpelling [FieldP]
| CTestGenseqcDefn CFunPrefix (HsName NsTypeConstr) CTypeSpelling [FieldP]
| CTestPerturbDefn CFunPrefix (HsName NsTypeConstr) CTypeSpelling [FieldP]
{-------------------------------------------------------------------------------
Pretty printing
-------------------------------------------------------------------------------}
instance Pretty CTestHeader where
pretty CTestHeader{..} = vsep $
vcat
[ "#ifndef" <+> string cTestHeaderIncludeGuard
, "#define" <+> string cTestHeaderIncludeGuard
]
: vcat ["#include \"" >< string inc >< "\"" | inc <- cTestHeaderUsrIncludes]
: vcat ["#include <" >< string inc >< ">" | inc <- cTestHeaderSysIncludes]
: map pretty cTestHeaderDecls
++ ["#endif //" <+> string cTestHeaderIncludeGuard]
instance Pretty CTestDecl where
pretty = \case
CTestSizeofDecl pfx name ->
prettyFun
(hcat ["size_t ", string pfx, "_sizeof_", prettyHsName name])
["void"]
";"
CTestAlignofDecl pfx name ->
prettyFun
(hcat ["size_t ", string pfx, "_alignof_", prettyHsName name])
["void"]
";"
CTestGenseqhsDecl pfx name cts ->
prettyFun
(hcat ["bool ", string pfx, "_genseqhs_", prettyHsName name])
[string cts <+> "const *const"]
";"
CTestGenseqcDecl pfx name cts ->
prettyFun
(hcat ["void ", string pfx, "_genseqc_", prettyHsName name])
[string cts <+> "*const"]
";"
CTestPerturbDecl pfx name cts ->
prettyFun
(hcat ["void ", string pfx, "_perturb_", prettyHsName name])
[ "long"
, string cts <+> "const *const"
, string cts <+> "*const"
]
";"
instance Pretty CTestSource where
pretty CTestSource{..} = vsep $
vcat ["#include \"" >< string inc >< "\"" | inc <- cTestSourceUsrIncludes]
: vcat ["#include <" >< string inc >< ">" | inc <- cTestSourceSysIncludes]
: map pretty cTestSourceDefns
instance Pretty CTestDefn where
pretty = \case
CTestSizeofDefn pfx name cts -> vcat
[ prettyFun
(hcat ["size_t ", string pfx, "_sizeof_", prettyHsName name])
["void"]
" {"
, nest 2 $ hcat ["return sizeof(", string cts, ");"]
, "}"
]
CTestAlignofDefn pfx name cts -> vcat
[ prettyFun
(hcat ["size_t ", string pfx, "_alignof_", prettyHsName name])
["void"]
" {"
, nest 2 $ hcat ["return alignof(", string cts, ");"]
, "}"
]
CTestGenseqhsDefn pfx name cts fieldPairs ->
let numFieldPairs = length fieldPairs
in vcat
[ prettyFun
(hcat ["bool ", string pfx, "_genseqhs_", prettyHsName name])
[string cts <+> "const *const source"]
" {"
, nest 2 $ "return" <+> fsep
[ hcat
[ "source->"
, prettyCName cField
, " == hsbg_genseq_"
, string hsFieldType
, "("
, showToCtxDoc idx
, ")"
, if idx == numFieldPairs
then ";"
else " &&"
]
| (idx, (cField, hsFieldType)) <- zip [1..] fieldPairs
]
, "}"
]
CTestGenseqcDefn pfx name cts fieldPairs -> vcat $
prettyFun
(hcat ["void ", string pfx, "_genseqc_", prettyHsName name])
[string cts <+> "*const target"]
" {"
: [ nest 2 $ hcat
[ "target->"
, prettyCName cField
, " = hsbg_genseq_"
, string hsFieldType
, "("
, showToCtxDoc @Int idx
, ");"
]
| (idx, (cField, hsFieldType)) <- zip [1..] fieldPairs
]
++ ["}"]
CTestPerturbDefn pfx name cts fieldPairs -> vcat $
prettyFun
(hcat ["void ", string pfx, "_perturb_", prettyHsName name])
[ "long size"
, string cts <+> "const *const source"
, string cts <+> "*const target"
]
" {"
: [ nest 2 $ hcat
[ "target->"
, prettyCName cField
, " = hsbg_perturb_"
, string hsFieldType
, "(size, source->"
, prettyCName cField
, ");"
]
| (cField, hsFieldType) <- fieldPairs
]
++ ["}"]
{-------------------------------------------------------------------------------
Auxiliary functions
-------------------------------------------------------------------------------}
getIncludeGuard ::
FilePath -- ^ C test header filename
-> String
getIncludeGuard = List.map aux
where
aux :: Char -> Char
aux c
| Char.isAlphaNum c = Char.toUpper c
| otherwise = '_'
prettyCName :: C.Name -> CtxDoc
prettyCName = string . T.unpack . C.getName
prettyFun ::
CtxDoc -- ^ Part before opening paren
-> [CtxDoc] -- ^ Parameters/arguments
-> CtxDoc -- ^ Part after closing paren
-> CtxDoc
prettyFun lDoc args rDoc = lDoc >< "(" >< fsep
[ if idx < numArgs then arg >< "," else arg >< ")" >< rDoc
| (idx, arg) <- zip [1..] args
]
where
numArgs :: Int
numArgs = length args
-}