diff --git a/hs-bindgen/examples/enums.h b/hs-bindgen/examples/enums.h new file mode 100644 index 00000000..8a080476 --- /dev/null +++ b/hs-bindgen/examples/enums.h @@ -0,0 +1,9 @@ +#ifndef ENUMS_H +#define ENUMS_H + +enum first { + FIRST1, + FIRST2 +}; + +#endif /* ENUMS_H */ diff --git a/hs-bindgen/examples/primitive_types.h b/hs-bindgen/examples/primitive_types.h new file mode 100644 index 00000000..dbfbabaa --- /dev/null +++ b/hs-bindgen/examples/primitive_types.h @@ -0,0 +1,40 @@ +struct primitive { + char c; + signed char sc; + unsigned char uc; + + short s; + short int si; + signed short ss; + signed short int ssi; + + unsigned short us; + unsigned short int usi; + + int i; + signed s2; + signed int si2; + + unsigned u; + unsigned int ui; + + long l; + long int li; + signed long sl; + signed long int sli; + + unsigned long ul; + unsigned long int uli; + + long long ll; + long long int lli; + signed long long sll; + signed long long int slli; + + unsigned long long ull; + unsigned long long int ulli; + + float f; + double d; + long double ld; +}; \ No newline at end of file diff --git a/hs-bindgen/fixtures/enums.dump.txt b/hs-bindgen/fixtures/enums.dump.txt new file mode 100644 index 00000000..afcd1598 --- /dev/null +++ b/hs-bindgen/fixtures/enums.dump.txt @@ -0,0 +1,3 @@ +"first" :: "Enum" + "FIRST1" :: "Int" + "FIRST2" :: "Int" diff --git a/hs-bindgen/fixtures/enums.th.txt b/hs-bindgen/fixtures/enums.th.txt new file mode 100644 index 00000000..e69de29b diff --git a/hs-bindgen/fixtures/enums.tree-diff.txt b/hs-bindgen/fixtures/enums.tree-diff.txt new file mode 100644 index 00000000..c4784bca --- /dev/null +++ b/hs-bindgen/fixtures/enums.tree-diff.txt @@ -0,0 +1 @@ +WrapCHeader (Header []) diff --git a/hs-bindgen/fixtures/primitive_types.dump.txt b/hs-bindgen/fixtures/primitive_types.dump.txt new file mode 100644 index 00000000..2c481fff --- /dev/null +++ b/hs-bindgen/fixtures/primitive_types.dump.txt @@ -0,0 +1,30 @@ +"primitive" :: "Record" + "c" :: "Char_S" + "sc" :: "SChar" + "uc" :: "UChar" + "s" :: "Short" + "si" :: "Short" + "ss" :: "Short" + "ssi" :: "Short" + "us" :: "UShort" + "usi" :: "UShort" + "i" :: "Int" + "s2" :: "Int" + "si2" :: "Int" + "u" :: "UInt" + "ui" :: "UInt" + "l" :: "Long" + "li" :: "Long" + "sl" :: "Long" + "sli" :: "Long" + "ul" :: "ULong" + "uli" :: "ULong" + "ll" :: "LongLong" + "lli" :: "LongLong" + "sll" :: "LongLong" + "slli" :: "LongLong" + "ull" :: "ULongLong" + "ulli" :: "ULongLong" + "f" :: "Float" + "d" :: "Double" + "ld" :: "LongDouble" diff --git a/hs-bindgen/fixtures/primitive_types.th.txt b/hs-bindgen/fixtures/primitive_types.th.txt new file mode 100644 index 00000000..e69de29b diff --git a/hs-bindgen/fixtures/primitive_types.tree-diff.txt b/hs-bindgen/fixtures/primitive_types.tree-diff.txt new file mode 100644 index 00000000..c7d275c2 --- /dev/null +++ b/hs-bindgen/fixtures/primitive_types.tree-diff.txt @@ -0,0 +1,24 @@ +WrapCHeader + (Header + [ + DeclStruct + Struct { + structTag = Just "primitive", + structSizeof = 176, + structAlignment = 16, + structFields = [ + StructField { + fieldName = "c", + fieldType = PrimChar}, + StructField { + fieldName = "i", + fieldType = PrimInt}, + StructField { + fieldName = "s2", + fieldType = PrimInt}, + StructField { + fieldName = "si2", + fieldType = PrimInt}, + StructField { + fieldName = "f", + fieldType = PrimFloat}]}]) diff --git a/hs-bindgen/fixtures/simple_structs.th.txt b/hs-bindgen/fixtures/simple_structs.th.txt new file mode 100644 index 00000000..e69de29b diff --git a/hs-bindgen/fixtures/simple_structs.tree-diff.txt b/hs-bindgen/fixtures/simple_structs.tree-diff.txt new file mode 100644 index 00000000..9e99cfd2 --- /dev/null +++ b/hs-bindgen/fixtures/simple_structs.tree-diff.txt @@ -0,0 +1,69 @@ +WrapCHeader + (Header + [ + DeclStruct + Struct { + structTag = Just "S1", + structSizeof = 8, + structAlignment = 4, + structFields = [ + StructField { + fieldName = "a", + fieldType = PrimInt}, + StructField { + fieldName = "b", + fieldType = PrimChar}]}, + DeclStruct + Struct { + structTag = Just "S2", + structSizeof = 12, + structAlignment = 4, + structFields = [ + StructField { + fieldName = "a", + fieldType = PrimChar}, + StructField { + fieldName = "b", + fieldType = PrimInt}, + StructField { + fieldName = "c", + fieldType = PrimFloat}]}, + DeclTypedef + Typedef { + typedefName = "S2_t", + typedefType = TypStruct + Struct { + structTag = Just "S2", + structSizeof = 12, + structAlignment = 4, + structFields = [ + StructField { + fieldName = "a", + fieldType = PrimChar}, + StructField { + fieldName = "b", + fieldType = PrimInt}, + StructField { + fieldName = "c", + fieldType = PrimFloat}]}}, + DeclStruct + Struct { + structTag = Nothing, + structSizeof = 1, + structAlignment = 1, + structFields = [ + StructField { + fieldName = "a", + fieldType = PrimChar}]}, + DeclTypedef + Typedef { + typedefName = "S3_t", + typedefType = TypStruct + Struct { + structTag = Nothing, + structSizeof = 1, + structAlignment = 1, + structFields = [ + StructField { + fieldName = "a", + fieldType = PrimChar}]}}]) diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal index 16f01c64..2d4ce34d 100644 --- a/hs-bindgen/hs-bindgen.cabal +++ b/hs-bindgen/hs-bindgen.cabal @@ -40,7 +40,7 @@ library exposed-modules: HsBindgen.Lib HsBindgen.TH - other-modules: + exposed-modules: HsBindgen.C.AST HsBindgen.C.Parser HsBindgen.Hs.Annotation @@ -89,6 +89,7 @@ test-suite golden type: exitcode-stdio-1.0 main-is: golden.hs hs-source-dirs: tests + other-modules: Orphans build-depends: -- Internal dependencies , hs-bindgen @@ -97,9 +98,11 @@ test-suite golden -- Inherited dependencies , containers , bytestring + , template-haskell build-depends: -- External dependencies , directory ^>=1.3.6.2 , filepath ^>=1.4.2.2 || ^>=1.5.2.0 , tasty ^>=1.5 , tasty-golden ^>=2.3.5 + , tree-diff ^>=0.3.1 diff --git a/hs-bindgen/src/HsBindgen/Lib.hs b/hs-bindgen/src/HsBindgen/Lib.hs index 40cf6fe1..00d4a29c 100644 --- a/hs-bindgen/src/HsBindgen/Lib.hs +++ b/hs-bindgen/src/HsBindgen/Lib.hs @@ -39,12 +39,14 @@ module HsBindgen.Lib ( -- * Logging , Tracer + , nullTracer , contramap , PrettyLogMsg(..) , mkTracerIO ) where import Data.Tree (Forest) +import GHC.Generics (Generic) import Language.Haskell.Exts qualified as Hs import Language.Haskell.Meta qualified as Meta import Language.Haskell.TH qualified as TH @@ -70,6 +72,7 @@ import HsBindgen.Util.Tracer newtype CHeader = WrapCHeader { unwrapCHeader :: C.Header } + deriving (Eq, Generic) newtype HsModule = WrapHsModule { unwrapHsModule :: Hs.Module Ann diff --git a/hs-bindgen/src/HsBindgen/Util/Tracer.hs b/hs-bindgen/src/HsBindgen/Util/Tracer.hs index 8a45efe9..629555d2 100644 --- a/hs-bindgen/src/HsBindgen/Util/Tracer.hs +++ b/hs-bindgen/src/HsBindgen/Util/Tracer.hs @@ -5,6 +5,7 @@ -- Indended for unqualified import. module HsBindgen.Util.Tracer ( Tracer -- opaque + , nullTracer , PrettyLogMsg(..) -- * Using the tracer , Level(..) @@ -42,6 +43,9 @@ traceWith t l a = Contra.traceWith (unwrap t) (l, a) Internal: general tracer construction -------------------------------------------------------------------------------} +nullTracer :: Monad m => Tracer m a +nullTracer = Wrap Contra.nullTracer + mkTracer :: forall m a. Monad m => (a -> m ()) -- ^ Output error @@ -96,4 +100,4 @@ mkTracerQ = -------------------------------------------------------------------------------} class PrettyLogMsg a where - prettyLogMsg :: a -> String \ No newline at end of file + prettyLogMsg :: a -> String diff --git a/hs-bindgen/tests/Orphans.hs b/hs-bindgen/tests/Orphans.hs new file mode 100644 index 00000000..a0a54c92 --- /dev/null +++ b/hs-bindgen/tests/Orphans.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Orphans where + +import Data.TreeDiff.Class (ToExpr) + +import HsBindgen.Lib +import HsBindgen.C.AST qualified as C + +instance ToExpr CHeader +instance ToExpr C.Header +instance ToExpr C.Decl +instance ToExpr C.Struct +instance ToExpr C.Typedef +instance ToExpr C.Typ +instance ToExpr C.PrimType +instance ToExpr C.StructField diff --git a/hs-bindgen/tests/golden.hs b/hs-bindgen/tests/golden.hs index f98e923d..2b48eeb2 100644 --- a/hs-bindgen/tests/golden.hs +++ b/hs-bindgen/tests/golden.hs @@ -6,6 +6,11 @@ import System.Directory (doesFileExist, setCurrentDirectory) import System.FilePath ((), (-<.>)) import Test.Tasty (defaultMain, testGroup) import Test.Tasty.Golden (goldenVsStringDiff) +import Test.Tasty.Golden.Advanced (goldenTest) +import Language.Haskell.TH.Ppr (ppr) +import Data.TreeDiff.Golden (ediffGolden) + +import Orphans () import HsBindgen.Clang.Util.Classification import HsBindgen.Lib @@ -14,16 +19,47 @@ main :: IO () main = do findPackageDirectory "hs-bindgen" defaultMain $ testGroup "golden" - [ goldenVsStringDiff "simple_structs" diff "fixtures/simple_structs.dump.txt" $ do - let fp = "examples/simple_structs.h" - args = [] - res <- getClangAST args fp - - return $ LBS8.pack $ unlines $ concatMap treeToLines res + [ golden "simple_structs" + , golden "enums" + , golden "primitive_types" ] where diff ref new = ["diff", "-u", ref, new] + golden name = testGroup name + [ goldenDump name + , goldenTreeDiff name + , goldenTH name + ] + + goldenDump name = goldenVsStringDiff "ast" diff ("fixtures" (name ++ ".dump.txt")) $ do + -- -<.> does weird stuff for filenames with multiple dots; + -- I usually simply avoid using it. + let fp = "examples" (name ++ ".h") + args = ["-target", "x86_64-pc-linux-gnu"] + + res <- getClangAST args fp + + return $ LBS8.pack $ unlines $ concatMap treeToLines res + + goldenTreeDiff name = ediffGolden goldenTest "treediff" ("fixtures" (name ++ ".tree-diff.txt")) $ do + let fp = "examples" (name ++ ".h") + args = ["-target", "x86_64-pc-linux-gnu"] + + header <- parseCHeader nullTracer args fp + return header + + goldenTH name = goldenVsStringDiff "th" diff ("fixtures" (name ++ ".th.txt")) $ do + -- -<.> does weird stuff for filenames with multiple dots; + -- I usually simply avoid using it. + let fp = "examples" (name ++ ".h") + args = ["-target", "x86_64-pc-linux-gnu"] + + header <- parseCHeader nullTracer args fp + let decls = genDecls header + + return $ LBS8.pack $ unlines $ map (show . ppr) decls + treeToLines :: Tree Element -> [String] treeToLines tree = go 0 tree [] where go :: Int -> Tree Element -> [String] -> [String]