diff --git a/hs-bindgen/examples/golden/fun_attributes.h b/hs-bindgen/examples/golden/fun_attributes.h index 33aa232c5..3392db13b 100644 --- a/hs-bindgen/examples/golden/fun_attributes.h +++ b/hs-bindgen/examples/golden/fun_attributes.h @@ -43,7 +43,12 @@ int square (int) __attribute__ ((const)); // deprecated // deprecated (msg) -int old_fn () __attribute__ ((deprecated)); +int old_fn_deprecated () __attribute__ ((deprecated("Use new_function instead"))); + +// unavailable +// unavailable (msg) + +int old_fn_unavailable () __attribute__((unavailable("Use new_function instead"))); // format (archetype, string-index, first-to-check) diff --git a/hs-bindgen/fixtures/fun_attributes.hs b/hs-bindgen/fixtures/fun_attributes.hs index 08034f3d6..7c33aa7fb 100644 --- a/hs-bindgen/fixtures/fun_attributes.hs +++ b/hs-bindgen/fixtures/fun_attributes.hs @@ -1047,18 +1047,18 @@ ForeignImportDecl { foreignImportName = Name "@NsVar" - "old_fn", + "old_fn_deprecated", foreignImportParameters = [], foreignImportResultType = NormalResultType (HsIO (HsPrimType HsPrimCInt)), foreignImportOrigName = - "hs_bindgen_test_fun_attributes_1040c24c74db8069", + "hs_bindgen_test_fun_attributes_e9647b9c99c68776", foreignImportCallConv = CallConvUserlandCAPI UserlandCapiWrapper { capiWrapperDefinition = - "signed int hs_bindgen_test_fun_attributes_1040c24c74db8069 (void) { return old_fn(); }", + "signed int hs_bindgen_test_fun_attributes_e9647b9c99c68776 (void) { return old_fn_deprecated(); }", capiWrapperImport = "fun_attributes.h"}, foreignImportOrigin = Function @@ -1072,7 +1072,8 @@ foreignImportComment = Just Comment { commentTitle = Nothing, - commentOrigin = Just "old_fn", + commentOrigin = Just + "old_fn_deprecated", commentLocation = Just "fun_attributes.h:46:5", commentHeaderInfo = Just @@ -1170,7 +1171,7 @@ commentOrigin = Just "my_dgettext", commentLocation = Just - "fun_attributes.h:57:1", + "fun_attributes.h:62:1", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1249,7 +1250,7 @@ commentTitle = Nothing, commentOrigin = Just "fdopen", commentLocation = Just - "fun_attributes.h:68:9", + "fun_attributes.h:73:9", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1288,7 +1289,7 @@ commentTitle = Nothing, commentOrigin = Just "f2", commentLocation = Just - "fun_attributes.h:72:65", + "fun_attributes.h:77:65", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1398,7 +1399,7 @@ commentOrigin = Just "my_memcpy", commentLocation = Just - "fun_attributes.h:78:1", + "fun_attributes.h:83:1", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1437,7 +1438,7 @@ commentTitle = Nothing, commentOrigin = Just "fatal", commentLocation = Just - "fun_attributes.h:95:6", + "fun_attributes.h:100:6", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1490,7 +1491,7 @@ commentTitle = Nothing, commentOrigin = Just "hash", commentLocation = Just - "fun_attributes.h:103:5", + "fun_attributes.h:108:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1568,7 +1569,7 @@ commentTitle = Nothing, commentOrigin = Just "mymalloc", commentLocation = Just - "fun_attributes.h:108:1", + "fun_attributes.h:113:1", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1607,7 +1608,7 @@ commentTitle = Nothing, commentOrigin = Just "foobar", commentLocation = Just - "fun_attributes.h:112:13", + "fun_attributes.h:117:13", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1648,7 +1649,7 @@ commentOrigin = Just "core2_func", commentLocation = Just - "fun_attributes.h:119:5", + "fun_attributes.h:124:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1689,7 +1690,7 @@ commentOrigin = Just "sse3_func", commentLocation = Just - "fun_attributes.h:120:5", + "fun_attributes.h:125:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1728,7 +1729,7 @@ commentTitle = Nothing, commentOrigin = Just "f3", commentLocation = Just - "fun_attributes.h:124:49", + "fun_attributes.h:129:49", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1768,7 +1769,7 @@ commentTitle = Nothing, commentOrigin = Just "fn", commentLocation = Just - "fun_attributes.h:129:5", + "fun_attributes.h:134:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1808,7 +1809,7 @@ commentTitle = Nothing, commentOrigin = Just "y", commentLocation = Just - "fun_attributes.h:135:12", + "fun_attributes.h:140:12", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1848,7 +1849,7 @@ commentTitle = Nothing, commentOrigin = Just "x1", commentLocation = Just - "fun_attributes.h:138:12", + "fun_attributes.h:143:12", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -1888,7 +1889,7 @@ commentTitle = Nothing, commentOrigin = Just "x2", commentLocation = Just - "fun_attributes.h:141:12", + "fun_attributes.h:146:12", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2379,18 +2380,18 @@ ForeignImportDecl { foreignImportName = Name "@NsVar" - "old_fn", + "old_fn_deprecated", foreignImportParameters = [], foreignImportResultType = NormalResultType (HsIO (HsPrimType HsPrimCInt)), foreignImportOrigName = - "hs_bindgen_test_fun_attributes_febe1b1c3f69ce2f", + "hs_bindgen_test_fun_attributes_c48f18f4f06068eb", foreignImportCallConv = CallConvUserlandCAPI UserlandCapiWrapper { capiWrapperDefinition = - "signed int hs_bindgen_test_fun_attributes_febe1b1c3f69ce2f (void) { return old_fn(); }", + "signed int hs_bindgen_test_fun_attributes_c48f18f4f06068eb (void) { return old_fn_deprecated(); }", capiWrapperImport = "fun_attributes.h"}, foreignImportOrigin = Function @@ -2404,7 +2405,8 @@ foreignImportComment = Just Comment { commentTitle = Nothing, - commentOrigin = Just "old_fn", + commentOrigin = Just + "old_fn_deprecated", commentLocation = Just "fun_attributes.h:46:5", commentHeaderInfo = Just @@ -2502,7 +2504,7 @@ commentOrigin = Just "my_dgettext", commentLocation = Just - "fun_attributes.h:57:1", + "fun_attributes.h:62:1", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2581,7 +2583,7 @@ commentTitle = Nothing, commentOrigin = Just "fdopen", commentLocation = Just - "fun_attributes.h:68:9", + "fun_attributes.h:73:9", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2620,7 +2622,7 @@ commentTitle = Nothing, commentOrigin = Just "f2", commentLocation = Just - "fun_attributes.h:72:65", + "fun_attributes.h:77:65", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2730,7 +2732,7 @@ commentOrigin = Just "my_memcpy", commentLocation = Just - "fun_attributes.h:78:1", + "fun_attributes.h:83:1", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2769,7 +2771,7 @@ commentTitle = Nothing, commentOrigin = Just "fatal", commentLocation = Just - "fun_attributes.h:95:6", + "fun_attributes.h:100:6", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2822,7 +2824,7 @@ commentTitle = Nothing, commentOrigin = Just "hash", commentLocation = Just - "fun_attributes.h:103:5", + "fun_attributes.h:108:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2900,7 +2902,7 @@ commentTitle = Nothing, commentOrigin = Just "mymalloc", commentLocation = Just - "fun_attributes.h:108:1", + "fun_attributes.h:113:1", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2939,7 +2941,7 @@ commentTitle = Nothing, commentOrigin = Just "foobar", commentLocation = Just - "fun_attributes.h:112:13", + "fun_attributes.h:117:13", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -2980,7 +2982,7 @@ commentOrigin = Just "core2_func", commentLocation = Just - "fun_attributes.h:119:5", + "fun_attributes.h:124:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -3021,7 +3023,7 @@ commentOrigin = Just "sse3_func", commentLocation = Just - "fun_attributes.h:120:5", + "fun_attributes.h:125:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -3060,7 +3062,7 @@ commentTitle = Nothing, commentOrigin = Just "f3", commentLocation = Just - "fun_attributes.h:124:49", + "fun_attributes.h:129:49", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -3100,7 +3102,7 @@ commentTitle = Nothing, commentOrigin = Just "fn", commentLocation = Just - "fun_attributes.h:129:5", + "fun_attributes.h:134:5", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -3140,7 +3142,7 @@ commentTitle = Nothing, commentOrigin = Just "y", commentLocation = Just - "fun_attributes.h:135:12", + "fun_attributes.h:140:12", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -3180,7 +3182,7 @@ commentTitle = Nothing, commentOrigin = Just "x1", commentLocation = Just - "fun_attributes.h:138:12", + "fun_attributes.h:143:12", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -3220,7 +3222,7 @@ commentTitle = Nothing, commentOrigin = Just "x2", commentLocation = Just - "fun_attributes.h:141:12", + "fun_attributes.h:146:12", commentHeaderInfo = Just HeaderInfo { headerMainHeaders = NE.fromList @@ -3551,7 +3553,7 @@ ForeignImportDecl { foreignImportName = Name "@NsVar" - "hs_bindgen_test_fun_attributes_3add0261fa83e1dd", + "hs_bindgen_test_fun_attributes_17f68fdc3f464b20", foreignImportParameters = [], foreignImportResultType = NormalResultType @@ -3560,12 +3562,12 @@ (HsIO (HsPrimType HsPrimCInt)))), foreignImportOrigName = - "hs_bindgen_test_fun_attributes_3add0261fa83e1dd", + "hs_bindgen_test_fun_attributes_17f68fdc3f464b20", foreignImportCallConv = CallConvUserlandCAPI UserlandCapiWrapper { capiWrapperDefinition = - "/* get_old_fn_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_3add0261fa83e1dd (void)) (void) { return &old_fn; } ", + "/* get_old_fn_deprecated_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_17f68fdc3f464b20 (void)) (void) { return &old_fn_deprecated; } ", capiWrapperImport = "fun_attributes.h"}, foreignImportOrigin = Global diff --git a/hs-bindgen/fixtures/fun_attributes.pp.hs b/hs-bindgen/fixtures/fun_attributes.pp.hs index a9333e670..fc7bd8426 100644 --- a/hs-bindgen/fixtures/fun_attributes.pp.hs +++ b/hs-bindgen/fixtures/fun_attributes.pp.hs @@ -18,7 +18,7 @@ import Data.Bits (FiniteBits) import Data.Void (Void) import Prelude (Bounded, Enum, Eq, IO, Int, Integral, Num, Ord, Read, Real, Show, pure, return) -$(HsBindgen.Runtime.Prelude.addCSource "#include \nvoid hs_bindgen_test_fun_attributes_8de545512324157b (void) { __f1(); }\nvoid hs_bindgen_test_fun_attributes_a2f84d2570ef3892 (void) { f1(); }\nvoid *hs_bindgen_test_fun_attributes_cefda6b95395d829 (size_t arg1, size_t arg2) { return my_memalign(arg1, arg2); }\nvoid *hs_bindgen_test_fun_attributes_e25f06c3ebec2536 (size_t arg1, size_t arg2) { return my_calloc(arg1, arg2); }\nvoid *hs_bindgen_test_fun_attributes_51fa664668350a00 (void *arg1, size_t arg2) { return my_realloc(arg1, arg2); }\nvoid *hs_bindgen_test_fun_attributes_93a5d6b7d4e02c33 (size_t arg1) { return my_alloc1(arg1); }\nvoid *hs_bindgen_test_fun_attributes_c948fd867be322fa (size_t arg1) { return my_alloc2(arg1); }\nsigned int hs_bindgen_test_fun_attributes_55e5eb89e54abf83 (signed int arg1) { return square(arg1); }\nsigned int hs_bindgen_test_fun_attributes_1040c24c74db8069 (void) { return old_fn(); }\nchar *hs_bindgen_test_fun_attributes_023f7813e909f518 (char *arg1, char const *arg2) { return my_dgettext(arg1, arg2); }\nFILE *hs_bindgen_test_fun_attributes_e39bbd59f1c96c14 (signed int arg1, char const *arg2) { return fdopen(arg1, arg2); }\nvoid hs_bindgen_test_fun_attributes_1d043de05a457e90 (void) { f2(); }\nvoid *hs_bindgen_test_fun_attributes_4b3bfd2d72a2db5d (void *arg1, void const *arg2, size_t arg3) { return my_memcpy(arg1, arg2, arg3); }\nvoid hs_bindgen_test_fun_attributes_348fe595d62421cf (void) { fatal(); }\nsigned int hs_bindgen_test_fun_attributes_e30754e2591f701a (char *arg1) { return hash(arg1); }\nvoid *hs_bindgen_test_fun_attributes_f6f68a022a15937a (size_t arg1) { return mymalloc(arg1); }\nvoid hs_bindgen_test_fun_attributes_d1bf41da7ab64db1 (void) { foobar(); }\nsigned int hs_bindgen_test_fun_attributes_00405e83bcb9b271 (void) { return core2_func(); }\nsigned int hs_bindgen_test_fun_attributes_06e7d2f8bcf43684 (void) { return sse3_func(); }\nvoid hs_bindgen_test_fun_attributes_e23eff1955ebb459 (void) { f3(); }\nsigned int hs_bindgen_test_fun_attributes_ef0eea5f61ef9228 (void) { return fn(); }\nsigned int hs_bindgen_test_fun_attributes_b007466f7ff1cf28 (void) { return y(); }\nsigned int hs_bindgen_test_fun_attributes_8c9825e1b20a7ea1 (void) { return x1(); }\nsigned int hs_bindgen_test_fun_attributes_c80d61b7727dab77 (void) { return x2(); }\n/* get___f1_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_7003b306f73c174b (void)) (void) { return &__f1; } \n/* get_f1_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_5469bdc0395f86c1 (void)) (void) { return &f1; } \n/* get_my_memalign_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_b3c956e53724162c (void)) (size_t arg1, size_t arg2) { return &my_memalign; } \n/* get_my_calloc_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_733646ca96f39979 (void)) (size_t arg1, size_t arg2) { return &my_calloc; } \n/* get_my_realloc_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_94e8271f186110fd (void)) (void *arg1, size_t arg2) { return &my_realloc; } \n/* get_my_alloc1_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_48d9862d70f58e70 (void)) (size_t arg1) { return &my_alloc1; } \n/* get_my_alloc2_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_17a11fd10dc57357 (void)) (size_t arg1) { return &my_alloc2; } \n/* get_square_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_c41111f40a04cdc9 (void)) (signed int arg1) { return □ } \n/* get_old_fn_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_3add0261fa83e1dd (void)) (void) { return &old_fn; } \n/* get_my_dgettext_ptr */ __attribute__ ((const)) char *(*hs_bindgen_test_fun_attributes_a0be4f488601c252 (void)) (char *arg1, char const *arg2) { return &my_dgettext; } \n/* get_fdopen_ptr */ __attribute__ ((const)) FILE *(*hs_bindgen_test_fun_attributes_2b987c3b5c01a326 (void)) (signed int arg1, char const *arg2) { return &fdopen; } \n/* get_f2_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_490ca7e8c8282a69 (void)) (void) { return &f2; } \n/* get_my_memcpy_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_e2e8b5d5ac435de8 (void)) (void *arg1, void const *arg2, size_t arg3) { return &my_memcpy; } \n/* get_fatal_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_ea0bb781f9eca7f5 (void)) (void) { return &fatal; } \n/* get_hash_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_4de9606eb9c5dd01 (void)) (char *arg1) { return &hash; } \n/* get_mymalloc_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_4ce141c884649d49 (void)) (size_t arg1) { return &mymalloc; } \n/* get_foobar_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_5c243ced544ab0aa (void)) (void) { return &foobar; } \n/* get_core2_func_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_14ef55245a14f816 (void)) (void) { return &core2_func; } \n/* get_sse3_func_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_72956748bb6eee67 (void)) (void) { return &sse3_func; } \n/* get_f3_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_38506a9ac5626bf2 (void)) (void) { return &f3; } \n/* get_fn_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_5929da82079150d1 (void)) (void) { return &fn; } \n/* get_y_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_7bcb4a1873e6ece6 (void)) (void) { return &y; } \n/* get_x1_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_11098262b345351a (void)) (void) { return &x1; } \n/* get_x2_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_0d19f83087f278f9 (void)) (void) { return &x2; } \n/* get_i_ptr */ __attribute__ ((const)) signed int *hs_bindgen_test_fun_attributes_cdc30ae5fb72cd6e (void) { return &i; } \n") +$(HsBindgen.Runtime.Prelude.addCSource "#include \nvoid hs_bindgen_test_fun_attributes_8de545512324157b (void) { __f1(); }\nvoid hs_bindgen_test_fun_attributes_a2f84d2570ef3892 (void) { f1(); }\nvoid *hs_bindgen_test_fun_attributes_cefda6b95395d829 (size_t arg1, size_t arg2) { return my_memalign(arg1, arg2); }\nvoid *hs_bindgen_test_fun_attributes_e25f06c3ebec2536 (size_t arg1, size_t arg2) { return my_calloc(arg1, arg2); }\nvoid *hs_bindgen_test_fun_attributes_51fa664668350a00 (void *arg1, size_t arg2) { return my_realloc(arg1, arg2); }\nvoid *hs_bindgen_test_fun_attributes_93a5d6b7d4e02c33 (size_t arg1) { return my_alloc1(arg1); }\nvoid *hs_bindgen_test_fun_attributes_c948fd867be322fa (size_t arg1) { return my_alloc2(arg1); }\nsigned int hs_bindgen_test_fun_attributes_55e5eb89e54abf83 (signed int arg1) { return square(arg1); }\nsigned int hs_bindgen_test_fun_attributes_e9647b9c99c68776 (void) { return old_fn_deprecated(); }\nchar *hs_bindgen_test_fun_attributes_023f7813e909f518 (char *arg1, char const *arg2) { return my_dgettext(arg1, arg2); }\nFILE *hs_bindgen_test_fun_attributes_e39bbd59f1c96c14 (signed int arg1, char const *arg2) { return fdopen(arg1, arg2); }\nvoid hs_bindgen_test_fun_attributes_1d043de05a457e90 (void) { f2(); }\nvoid *hs_bindgen_test_fun_attributes_4b3bfd2d72a2db5d (void *arg1, void const *arg2, size_t arg3) { return my_memcpy(arg1, arg2, arg3); }\nvoid hs_bindgen_test_fun_attributes_348fe595d62421cf (void) { fatal(); }\nsigned int hs_bindgen_test_fun_attributes_e30754e2591f701a (char *arg1) { return hash(arg1); }\nvoid *hs_bindgen_test_fun_attributes_f6f68a022a15937a (size_t arg1) { return mymalloc(arg1); }\nvoid hs_bindgen_test_fun_attributes_d1bf41da7ab64db1 (void) { foobar(); }\nsigned int hs_bindgen_test_fun_attributes_00405e83bcb9b271 (void) { return core2_func(); }\nsigned int hs_bindgen_test_fun_attributes_06e7d2f8bcf43684 (void) { return sse3_func(); }\nvoid hs_bindgen_test_fun_attributes_e23eff1955ebb459 (void) { f3(); }\nsigned int hs_bindgen_test_fun_attributes_ef0eea5f61ef9228 (void) { return fn(); }\nsigned int hs_bindgen_test_fun_attributes_b007466f7ff1cf28 (void) { return y(); }\nsigned int hs_bindgen_test_fun_attributes_8c9825e1b20a7ea1 (void) { return x1(); }\nsigned int hs_bindgen_test_fun_attributes_c80d61b7727dab77 (void) { return x2(); }\n/* get___f1_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_7003b306f73c174b (void)) (void) { return &__f1; } \n/* get_f1_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_5469bdc0395f86c1 (void)) (void) { return &f1; } \n/* get_my_memalign_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_b3c956e53724162c (void)) (size_t arg1, size_t arg2) { return &my_memalign; } \n/* get_my_calloc_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_733646ca96f39979 (void)) (size_t arg1, size_t arg2) { return &my_calloc; } \n/* get_my_realloc_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_94e8271f186110fd (void)) (void *arg1, size_t arg2) { return &my_realloc; } \n/* get_my_alloc1_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_48d9862d70f58e70 (void)) (size_t arg1) { return &my_alloc1; } \n/* get_my_alloc2_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_17a11fd10dc57357 (void)) (size_t arg1) { return &my_alloc2; } \n/* get_square_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_c41111f40a04cdc9 (void)) (signed int arg1) { return □ } \n/* get_old_fn_deprecated_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_17f68fdc3f464b20 (void)) (void) { return &old_fn_deprecated; } \n/* get_my_dgettext_ptr */ __attribute__ ((const)) char *(*hs_bindgen_test_fun_attributes_a0be4f488601c252 (void)) (char *arg1, char const *arg2) { return &my_dgettext; } \n/* get_fdopen_ptr */ __attribute__ ((const)) FILE *(*hs_bindgen_test_fun_attributes_2b987c3b5c01a326 (void)) (signed int arg1, char const *arg2) { return &fdopen; } \n/* get_f2_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_490ca7e8c8282a69 (void)) (void) { return &f2; } \n/* get_my_memcpy_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_e2e8b5d5ac435de8 (void)) (void *arg1, void const *arg2, size_t arg3) { return &my_memcpy; } \n/* get_fatal_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_ea0bb781f9eca7f5 (void)) (void) { return &fatal; } \n/* get_hash_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_4de9606eb9c5dd01 (void)) (char *arg1) { return &hash; } \n/* get_mymalloc_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_4ce141c884649d49 (void)) (size_t arg1) { return &mymalloc; } \n/* get_foobar_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_5c243ced544ab0aa (void)) (void) { return &foobar; } \n/* get_core2_func_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_14ef55245a14f816 (void)) (void) { return &core2_func; } \n/* get_sse3_func_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_72956748bb6eee67 (void)) (void) { return &sse3_func; } \n/* get_f3_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_38506a9ac5626bf2 (void)) (void) { return &f3; } \n/* get_fn_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_5929da82079150d1 (void)) (void) { return &fn; } \n/* get_y_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_7bcb4a1873e6ece6 (void)) (void) { return &y; } \n/* get_x1_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_11098262b345351a (void)) (void) { return &x1; } \n/* get_x2_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_0d19f83087f278f9 (void)) (void) { return &x2; } \n/* get_i_ptr */ __attribute__ ((const)) signed int *hs_bindgen_test_fun_attributes_cdc30ae5fb72cd6e (void) { return &i; } \n") {-| Attributes on functions @@ -139,18 +139,18 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_55e5eb89e54abf83" squa FC.CInt -> FC.CInt -{-| __C declaration:__ @old_fn@ +{-| __C declaration:__ @old_fn_deprecated@ __defined at:__ @fun_attributes.h:46:5@ __exported by:__ @fun_attributes.h@ -} -foreign import ccall safe "hs_bindgen_test_fun_attributes_1040c24c74db8069" old_fn :: +foreign import ccall safe "hs_bindgen_test_fun_attributes_e9647b9c99c68776" old_fn_deprecated :: IO FC.CInt {-| __C declaration:__ @my_dgettext@ - __defined at:__ @fun_attributes.h:57:1@ + __defined at:__ @fun_attributes.h:62:1@ __exported by:__ @fun_attributes.h@ -} @@ -165,7 +165,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_023f7813e909f518" my_d {-| __C declaration:__ @fdopen@ - __defined at:__ @fun_attributes.h:68:9@ + __defined at:__ @fun_attributes.h:73:9@ __exported by:__ @fun_attributes.h@ -} @@ -176,7 +176,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_e39bbd59f1c96c14" fdop {-| __C declaration:__ @f2@ - __defined at:__ @fun_attributes.h:72:65@ + __defined at:__ @fun_attributes.h:77:65@ __exported by:__ @fun_attributes.h@ -} @@ -185,7 +185,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_1d043de05a457e90" f2 : {-| __C declaration:__ @my_memcpy@ - __defined at:__ @fun_attributes.h:78:1@ + __defined at:__ @fun_attributes.h:83:1@ __exported by:__ @fun_attributes.h@ -} @@ -203,7 +203,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_4b3bfd2d72a2db5d" my_m {-| __C declaration:__ @fatal@ - __defined at:__ @fun_attributes.h:95:6@ + __defined at:__ @fun_attributes.h:100:6@ __exported by:__ @fun_attributes.h@ -} @@ -216,7 +216,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_348fe595d62421cf" fata __C declaration:__ @hash@ -__defined at:__ @fun_attributes.h:103:5@ +__defined at:__ @fun_attributes.h:108:5@ __exported by:__ @fun_attributes.h@ -} @@ -226,7 +226,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_e30754e2591f701a" hash {-| __C declaration:__ @mymalloc@ - __defined at:__ @fun_attributes.h:108:1@ + __defined at:__ @fun_attributes.h:113:1@ __exported by:__ @fun_attributes.h@ -} @@ -238,7 +238,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_f6f68a022a15937a" myma {-| __C declaration:__ @foobar@ - __defined at:__ @fun_attributes.h:112:13@ + __defined at:__ @fun_attributes.h:117:13@ __exported by:__ @fun_attributes.h@ -} @@ -247,7 +247,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_d1bf41da7ab64db1" foob {-| __C declaration:__ @core2_func@ - __defined at:__ @fun_attributes.h:119:5@ + __defined at:__ @fun_attributes.h:124:5@ __exported by:__ @fun_attributes.h@ -} @@ -256,7 +256,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_00405e83bcb9b271" core {-| __C declaration:__ @sse3_func@ - __defined at:__ @fun_attributes.h:120:5@ + __defined at:__ @fun_attributes.h:125:5@ __exported by:__ @fun_attributes.h@ -} @@ -265,7 +265,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_06e7d2f8bcf43684" sse3 {-| __C declaration:__ @f3@ - __defined at:__ @fun_attributes.h:124:49@ + __defined at:__ @fun_attributes.h:129:49@ __exported by:__ @fun_attributes.h@ -} @@ -274,7 +274,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_e23eff1955ebb459" f3 : {-| __C declaration:__ @fn@ - __defined at:__ @fun_attributes.h:129:5@ + __defined at:__ @fun_attributes.h:134:5@ __exported by:__ @fun_attributes.h@ -} @@ -283,7 +283,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_ef0eea5f61ef9228" fn : {-| __C declaration:__ @y@ - __defined at:__ @fun_attributes.h:135:12@ + __defined at:__ @fun_attributes.h:140:12@ __exported by:__ @fun_attributes.h@ -} @@ -292,7 +292,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_b007466f7ff1cf28" y :: {-| __C declaration:__ @x1@ - __defined at:__ @fun_attributes.h:138:12@ + __defined at:__ @fun_attributes.h:143:12@ __exported by:__ @fun_attributes.h@ -} @@ -301,7 +301,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_8c9825e1b20a7ea1" x1 : {-| __C declaration:__ @x2@ - __defined at:__ @fun_attributes.h:141:12@ + __defined at:__ @fun_attributes.h:146:12@ __exported by:__ @fun_attributes.h@ -} @@ -428,20 +428,20 @@ square_ptr :: Ptr.FunPtr (FC.CInt -> IO FC.CInt) square_ptr = GHC.IO.Unsafe.unsafePerformIO hs_bindgen_test_fun_attributes_c41111f40a04cdc9 -foreign import ccall unsafe "hs_bindgen_test_fun_attributes_3add0261fa83e1dd" hs_bindgen_test_fun_attributes_3add0261fa83e1dd :: +foreign import ccall unsafe "hs_bindgen_test_fun_attributes_17f68fdc3f464b20" hs_bindgen_test_fun_attributes_17f68fdc3f464b20 :: IO (Ptr.FunPtr (IO FC.CInt)) -{-# NOINLINE old_fn_ptr #-} +{-# NOINLINE old_fn_deprecated_ptr #-} -{-| __C declaration:__ @old_fn@ +{-| __C declaration:__ @old_fn_deprecated@ __defined at:__ @fun_attributes.h:46:5@ __exported by:__ @fun_attributes.h@ -} -old_fn_ptr :: Ptr.FunPtr (IO FC.CInt) -old_fn_ptr = - GHC.IO.Unsafe.unsafePerformIO hs_bindgen_test_fun_attributes_3add0261fa83e1dd +old_fn_deprecated_ptr :: Ptr.FunPtr (IO FC.CInt) +old_fn_deprecated_ptr = + GHC.IO.Unsafe.unsafePerformIO hs_bindgen_test_fun_attributes_17f68fdc3f464b20 foreign import ccall unsafe "hs_bindgen_test_fun_attributes_a0be4f488601c252" hs_bindgen_test_fun_attributes_a0be4f488601c252 :: IO (Ptr.FunPtr ((Ptr.Ptr FC.CChar) -> (Ptr.Ptr FC.CChar) -> IO (Ptr.Ptr FC.CChar))) @@ -450,7 +450,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_a0be4f488601c252" hs {-| __C declaration:__ @my_dgettext@ - __defined at:__ @fun_attributes.h:57:1@ + __defined at:__ @fun_attributes.h:62:1@ __exported by:__ @fun_attributes.h@ -} @@ -465,7 +465,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_2b987c3b5c01a326" hs {-| __C declaration:__ @fdopen@ - __defined at:__ @fun_attributes.h:68:9@ + __defined at:__ @fun_attributes.h:73:9@ __exported by:__ @fun_attributes.h@ -} @@ -480,7 +480,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_490ca7e8c8282a69" hs {-| __C declaration:__ @f2@ - __defined at:__ @fun_attributes.h:72:65@ + __defined at:__ @fun_attributes.h:77:65@ __exported by:__ @fun_attributes.h@ -} @@ -495,7 +495,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_e2e8b5d5ac435de8" hs {-| __C declaration:__ @my_memcpy@ - __defined at:__ @fun_attributes.h:78:1@ + __defined at:__ @fun_attributes.h:83:1@ __exported by:__ @fun_attributes.h@ -} @@ -510,7 +510,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_ea0bb781f9eca7f5" hs {-| __C declaration:__ @fatal@ - __defined at:__ @fun_attributes.h:95:6@ + __defined at:__ @fun_attributes.h:100:6@ __exported by:__ @fun_attributes.h@ -} @@ -525,7 +525,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_4de9606eb9c5dd01" hs {-| __C declaration:__ @hash@ - __defined at:__ @fun_attributes.h:103:5@ + __defined at:__ @fun_attributes.h:108:5@ __exported by:__ @fun_attributes.h@ -} @@ -540,7 +540,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_4ce141c884649d49" hs {-| __C declaration:__ @mymalloc@ - __defined at:__ @fun_attributes.h:108:1@ + __defined at:__ @fun_attributes.h:113:1@ __exported by:__ @fun_attributes.h@ -} @@ -555,7 +555,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_5c243ced544ab0aa" hs {-| __C declaration:__ @foobar@ - __defined at:__ @fun_attributes.h:112:13@ + __defined at:__ @fun_attributes.h:117:13@ __exported by:__ @fun_attributes.h@ -} @@ -570,7 +570,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_14ef55245a14f816" hs {-| __C declaration:__ @core2_func@ - __defined at:__ @fun_attributes.h:119:5@ + __defined at:__ @fun_attributes.h:124:5@ __exported by:__ @fun_attributes.h@ -} @@ -585,7 +585,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_72956748bb6eee67" hs {-| __C declaration:__ @sse3_func@ - __defined at:__ @fun_attributes.h:120:5@ + __defined at:__ @fun_attributes.h:125:5@ __exported by:__ @fun_attributes.h@ -} @@ -600,7 +600,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_38506a9ac5626bf2" hs {-| __C declaration:__ @f3@ - __defined at:__ @fun_attributes.h:124:49@ + __defined at:__ @fun_attributes.h:129:49@ __exported by:__ @fun_attributes.h@ -} @@ -615,7 +615,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_5929da82079150d1" hs {-| __C declaration:__ @fn@ - __defined at:__ @fun_attributes.h:129:5@ + __defined at:__ @fun_attributes.h:134:5@ __exported by:__ @fun_attributes.h@ -} @@ -630,7 +630,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_7bcb4a1873e6ece6" hs {-| __C declaration:__ @y@ - __defined at:__ @fun_attributes.h:135:12@ + __defined at:__ @fun_attributes.h:140:12@ __exported by:__ @fun_attributes.h@ -} @@ -645,7 +645,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_11098262b345351a" hs {-| __C declaration:__ @x1@ - __defined at:__ @fun_attributes.h:138:12@ + __defined at:__ @fun_attributes.h:143:12@ __exported by:__ @fun_attributes.h@ -} @@ -660,7 +660,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_0d19f83087f278f9" hs {-| __C declaration:__ @x2@ - __defined at:__ @fun_attributes.h:141:12@ + __defined at:__ @fun_attributes.h:146:12@ __exported by:__ @fun_attributes.h@ -} @@ -675,7 +675,7 @@ foreign import ccall unsafe "hs_bindgen_test_fun_attributes_cdc30ae5fb72cd6e" hs {-| __C declaration:__ @i@ - __defined at:__ @fun_attributes.h:125:5@ + __defined at:__ @fun_attributes.h:130:5@ __exported by:__ @fun_attributes.h@ -} diff --git a/hs-bindgen/fixtures/fun_attributes.th.txt b/hs-bindgen/fixtures/fun_attributes.th.txt index 137409c53..07bd119c9 100644 --- a/hs-bindgen/fixtures/fun_attributes.th.txt +++ b/hs-bindgen/fixtures/fun_attributes.th.txt @@ -8,7 +8,7 @@ -- void *hs_bindgen_test_fun_attributes_93a5d6b7d4e02c33 (size_t arg1) { return my_alloc1(arg1); } -- void *hs_bindgen_test_fun_attributes_c948fd867be322fa (size_t arg1) { return my_alloc2(arg1); } -- signed int hs_bindgen_test_fun_attributes_55e5eb89e54abf83 (signed int arg1) { return square(arg1); } --- signed int hs_bindgen_test_fun_attributes_1040c24c74db8069 (void) { return old_fn(); } +-- signed int hs_bindgen_test_fun_attributes_e9647b9c99c68776 (void) { return old_fn_deprecated(); } -- char *hs_bindgen_test_fun_attributes_023f7813e909f518 (char *arg1, char const *arg2) { return my_dgettext(arg1, arg2); } -- FILE *hs_bindgen_test_fun_attributes_e39bbd59f1c96c14 (signed int arg1, char const *arg2) { return fdopen(arg1, arg2); } -- void hs_bindgen_test_fun_attributes_1d043de05a457e90 (void) { f2(); } @@ -32,7 +32,7 @@ -- void *hs_bindgen_test_fun_attributes_b3544e53af074ef1 (size_t arg1) { return my_alloc1(arg1); } -- void *hs_bindgen_test_fun_attributes_0b659f90fec40284 (size_t arg1) { return my_alloc2(arg1); } -- signed int hs_bindgen_test_fun_attributes_cb3c687f16289bb3 (signed int arg1) { return square(arg1); } --- signed int hs_bindgen_test_fun_attributes_febe1b1c3f69ce2f (void) { return old_fn(); } +-- signed int hs_bindgen_test_fun_attributes_c48f18f4f06068eb (void) { return old_fn_deprecated(); } -- char *hs_bindgen_test_fun_attributes_d492bd76e82890da (char *arg1, char const *arg2) { return my_dgettext(arg1, arg2); } -- FILE *hs_bindgen_test_fun_attributes_3c91a267bd66cc10 (signed int arg1, char const *arg2) { return fdopen(arg1, arg2); } -- void hs_bindgen_test_fun_attributes_14361e995fb5684a (void) { f2(); } @@ -56,7 +56,7 @@ -- /* get_my_alloc1_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_48d9862d70f58e70 (void)) (size_t arg1) { return &my_alloc1; } -- /* get_my_alloc2_ptr */ __attribute__ ((const)) void *(*hs_bindgen_test_fun_attributes_17a11fd10dc57357 (void)) (size_t arg1) { return &my_alloc2; } -- /* get_square_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_c41111f40a04cdc9 (void)) (signed int arg1) { return □ } --- /* get_old_fn_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_3add0261fa83e1dd (void)) (void) { return &old_fn; } +-- /* get_old_fn_deprecated_ptr */ __attribute__ ((const)) signed int (*hs_bindgen_test_fun_attributes_17f68fdc3f464b20 (void)) (void) { return &old_fn_deprecated; } -- /* get_my_dgettext_ptr */ __attribute__ ((const)) char *(*hs_bindgen_test_fun_attributes_a0be4f488601c252 (void)) (char *arg1, char const *arg2) { return &my_dgettext; } -- /* get_fdopen_ptr */ __attribute__ ((const)) FILE *(*hs_bindgen_test_fun_attributes_2b987c3b5c01a326 (void)) (signed int arg1, char const *arg2) { return &fdopen; } -- /* get_f2_ptr */ __attribute__ ((const)) void (*hs_bindgen_test_fun_attributes_490ca7e8c8282a69 (void)) (void) { return &f2; } @@ -187,16 +187,16 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_c948fd867be322fa" my_a -} foreign import ccall safe "hs_bindgen_test_fun_attributes_55e5eb89e54abf83" square :: CInt -> CInt -{-| __C declaration:__ @old_fn@ +{-| __C declaration:__ @old_fn_deprecated@ __defined at:__ @fun_attributes.h:46:5@ __exported by:__ @fun_attributes.h@ -} -foreign import ccall safe "hs_bindgen_test_fun_attributes_1040c24c74db8069" old_fn :: IO CInt +foreign import ccall safe "hs_bindgen_test_fun_attributes_e9647b9c99c68776" old_fn_deprecated :: IO CInt {-| __C declaration:__ @my_dgettext@ - __defined at:__ @fun_attributes.h:57:1@ + __defined at:__ @fun_attributes.h:62:1@ __exported by:__ @fun_attributes.h@ -} @@ -205,7 +205,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_023f7813e909f518" my_d IO (Ptr CChar) {-| __C declaration:__ @fdopen@ - __defined at:__ @fun_attributes.h:68:9@ + __defined at:__ @fun_attributes.h:73:9@ __exported by:__ @fun_attributes.h@ -} @@ -214,14 +214,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_e39bbd59f1c96c14" fdop IO (Ptr FILE) {-| __C declaration:__ @f2@ - __defined at:__ @fun_attributes.h:72:65@ + __defined at:__ @fun_attributes.h:77:65@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_1d043de05a457e90" f2 :: IO Unit {-| __C declaration:__ @my_memcpy@ - __defined at:__ @fun_attributes.h:78:1@ + __defined at:__ @fun_attributes.h:83:1@ __exported by:__ @fun_attributes.h@ -} @@ -231,7 +231,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_4b3bfd2d72a2db5d" my_m IO (Ptr Void) {-| __C declaration:__ @fatal@ - __defined at:__ @fun_attributes.h:95:6@ + __defined at:__ @fun_attributes.h:100:6@ __exported by:__ @fun_attributes.h@ -} @@ -242,7 +242,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_348fe595d62421cf" fata __C declaration:__ @hash@ -__defined at:__ @fun_attributes.h:103:5@ +__defined at:__ @fun_attributes.h:108:5@ __exported by:__ @fun_attributes.h@ -} @@ -250,7 +250,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_e30754e2591f701a" hash IO CInt {-| __C declaration:__ @mymalloc@ - __defined at:__ @fun_attributes.h:108:1@ + __defined at:__ @fun_attributes.h:113:1@ __exported by:__ @fun_attributes.h@ -} @@ -258,56 +258,56 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_f6f68a022a15937a" myma IO (Ptr Void) {-| __C declaration:__ @foobar@ - __defined at:__ @fun_attributes.h:112:13@ + __defined at:__ @fun_attributes.h:117:13@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_d1bf41da7ab64db1" foobar :: IO Unit {-| __C declaration:__ @core2_func@ - __defined at:__ @fun_attributes.h:119:5@ + __defined at:__ @fun_attributes.h:124:5@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_00405e83bcb9b271" core2_func :: IO CInt {-| __C declaration:__ @sse3_func@ - __defined at:__ @fun_attributes.h:120:5@ + __defined at:__ @fun_attributes.h:125:5@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_06e7d2f8bcf43684" sse3_func :: IO CInt {-| __C declaration:__ @f3@ - __defined at:__ @fun_attributes.h:124:49@ + __defined at:__ @fun_attributes.h:129:49@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_e23eff1955ebb459" f3 :: IO Unit {-| __C declaration:__ @fn@ - __defined at:__ @fun_attributes.h:129:5@ + __defined at:__ @fun_attributes.h:134:5@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_ef0eea5f61ef9228" fn :: IO CInt {-| __C declaration:__ @y@ - __defined at:__ @fun_attributes.h:135:12@ + __defined at:__ @fun_attributes.h:140:12@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_b007466f7ff1cf28" y :: IO CInt {-| __C declaration:__ @x1@ - __defined at:__ @fun_attributes.h:138:12@ + __defined at:__ @fun_attributes.h:143:12@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_8c9825e1b20a7ea1" x1 :: IO CInt {-| __C declaration:__ @x2@ - __defined at:__ @fun_attributes.h:141:12@ + __defined at:__ @fun_attributes.h:146:12@ __exported by:__ @fun_attributes.h@ -} @@ -377,16 +377,16 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_0b659f90fec40284" my_a -} foreign import ccall safe "hs_bindgen_test_fun_attributes_cb3c687f16289bb3" square :: CInt -> CInt -{-| __C declaration:__ @old_fn@ +{-| __C declaration:__ @old_fn_deprecated@ __defined at:__ @fun_attributes.h:46:5@ __exported by:__ @fun_attributes.h@ -} -foreign import ccall safe "hs_bindgen_test_fun_attributes_febe1b1c3f69ce2f" old_fn :: IO CInt +foreign import ccall safe "hs_bindgen_test_fun_attributes_c48f18f4f06068eb" old_fn_deprecated :: IO CInt {-| __C declaration:__ @my_dgettext@ - __defined at:__ @fun_attributes.h:57:1@ + __defined at:__ @fun_attributes.h:62:1@ __exported by:__ @fun_attributes.h@ -} @@ -395,7 +395,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_d492bd76e82890da" my_d IO (Ptr CChar) {-| __C declaration:__ @fdopen@ - __defined at:__ @fun_attributes.h:68:9@ + __defined at:__ @fun_attributes.h:73:9@ __exported by:__ @fun_attributes.h@ -} @@ -404,14 +404,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_3c91a267bd66cc10" fdop IO (Ptr FILE) {-| __C declaration:__ @f2@ - __defined at:__ @fun_attributes.h:72:65@ + __defined at:__ @fun_attributes.h:77:65@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_14361e995fb5684a" f2 :: IO Unit {-| __C declaration:__ @my_memcpy@ - __defined at:__ @fun_attributes.h:78:1@ + __defined at:__ @fun_attributes.h:83:1@ __exported by:__ @fun_attributes.h@ -} @@ -421,7 +421,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_e8c4a96cefd6117e" my_m IO (Ptr Void) {-| __C declaration:__ @fatal@ - __defined at:__ @fun_attributes.h:95:6@ + __defined at:__ @fun_attributes.h:100:6@ __exported by:__ @fun_attributes.h@ -} @@ -432,7 +432,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_64aa41e835dbb892" fata __C declaration:__ @hash@ -__defined at:__ @fun_attributes.h:103:5@ +__defined at:__ @fun_attributes.h:108:5@ __exported by:__ @fun_attributes.h@ -} @@ -440,7 +440,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_88887d4b5f42f079" hash IO CInt {-| __C declaration:__ @mymalloc@ - __defined at:__ @fun_attributes.h:108:1@ + __defined at:__ @fun_attributes.h:113:1@ __exported by:__ @fun_attributes.h@ -} @@ -448,56 +448,56 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_31e6e14ecb251fa2" myma IO (Ptr Void) {-| __C declaration:__ @foobar@ - __defined at:__ @fun_attributes.h:112:13@ + __defined at:__ @fun_attributes.h:117:13@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_bb77a71513994934" foobar :: IO Unit {-| __C declaration:__ @core2_func@ - __defined at:__ @fun_attributes.h:119:5@ + __defined at:__ @fun_attributes.h:124:5@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_640ec5b51b0819d1" core2_func :: IO CInt {-| __C declaration:__ @sse3_func@ - __defined at:__ @fun_attributes.h:120:5@ + __defined at:__ @fun_attributes.h:125:5@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_a1f7636643d63586" sse3_func :: IO CInt {-| __C declaration:__ @f3@ - __defined at:__ @fun_attributes.h:124:49@ + __defined at:__ @fun_attributes.h:129:49@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_2bef032cbe15ffd0" f3 :: IO Unit {-| __C declaration:__ @fn@ - __defined at:__ @fun_attributes.h:129:5@ + __defined at:__ @fun_attributes.h:134:5@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_8f406104a21ff66e" fn :: IO CInt {-| __C declaration:__ @y@ - __defined at:__ @fun_attributes.h:135:12@ + __defined at:__ @fun_attributes.h:140:12@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_4beb0cbf65b462bd" y :: IO CInt {-| __C declaration:__ @x1@ - __defined at:__ @fun_attributes.h:138:12@ + __defined at:__ @fun_attributes.h:143:12@ __exported by:__ @fun_attributes.h@ -} foreign import ccall safe "hs_bindgen_test_fun_attributes_ac7386c785058f4d" x1 :: IO CInt {-| __C declaration:__ @x2@ - __defined at:__ @fun_attributes.h:141:12@ + __defined at:__ @fun_attributes.h:146:12@ __exported by:__ @fun_attributes.h@ -} @@ -639,29 +639,29 @@ square_ptr :: FunPtr (CInt -> IO CInt) __exported by:__ @fun_attributes.h@ -} square_ptr = unsafePerformIO hs_bindgen_test_fun_attributes_c41111f40a04cdc9 -foreign import ccall safe "hs_bindgen_test_fun_attributes_3add0261fa83e1dd" hs_bindgen_test_fun_attributes_3add0261fa83e1dd :: IO (FunPtr (IO CInt)) -{-# NOINLINE old_fn_ptr #-} -{-| __C declaration:__ @old_fn@ +foreign import ccall safe "hs_bindgen_test_fun_attributes_17f68fdc3f464b20" hs_bindgen_test_fun_attributes_17f68fdc3f464b20 :: IO (FunPtr (IO CInt)) +{-# NOINLINE old_fn_deprecated_ptr #-} +{-| __C declaration:__ @old_fn_deprecated@ __defined at:__ @fun_attributes.h:46:5@ __exported by:__ @fun_attributes.h@ -} -old_fn_ptr :: FunPtr (IO CInt) -{-| __C declaration:__ @old_fn@ +old_fn_deprecated_ptr :: FunPtr (IO CInt) +{-| __C declaration:__ @old_fn_deprecated@ __defined at:__ @fun_attributes.h:46:5@ __exported by:__ @fun_attributes.h@ -} -old_fn_ptr = unsafePerformIO hs_bindgen_test_fun_attributes_3add0261fa83e1dd +old_fn_deprecated_ptr = unsafePerformIO hs_bindgen_test_fun_attributes_17f68fdc3f464b20 foreign import ccall safe "hs_bindgen_test_fun_attributes_a0be4f488601c252" hs_bindgen_test_fun_attributes_a0be4f488601c252 :: IO (FunPtr (Ptr CChar -> Ptr CChar -> IO (Ptr CChar))) {-# NOINLINE my_dgettext_ptr #-} {-| __C declaration:__ @my_dgettext@ - __defined at:__ @fun_attributes.h:57:1@ + __defined at:__ @fun_attributes.h:62:1@ __exported by:__ @fun_attributes.h@ -} @@ -669,7 +669,7 @@ my_dgettext_ptr :: FunPtr (Ptr CChar -> Ptr CChar -> IO (Ptr CChar)) {-| __C declaration:__ @my_dgettext@ - __defined at:__ @fun_attributes.h:57:1@ + __defined at:__ @fun_attributes.h:62:1@ __exported by:__ @fun_attributes.h@ -} @@ -680,14 +680,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_2b987c3b5c01a326" hs_b {-# NOINLINE fdopen_ptr #-} {-| __C declaration:__ @fdopen@ - __defined at:__ @fun_attributes.h:68:9@ + __defined at:__ @fun_attributes.h:73:9@ __exported by:__ @fun_attributes.h@ -} fdopen_ptr :: FunPtr (CInt -> Ptr CChar -> IO (Ptr FILE)) {-| __C declaration:__ @fdopen@ - __defined at:__ @fun_attributes.h:68:9@ + __defined at:__ @fun_attributes.h:73:9@ __exported by:__ @fun_attributes.h@ -} @@ -696,14 +696,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_490ca7e8c8282a69" hs_b {-# NOINLINE f2_ptr #-} {-| __C declaration:__ @f2@ - __defined at:__ @fun_attributes.h:72:65@ + __defined at:__ @fun_attributes.h:77:65@ __exported by:__ @fun_attributes.h@ -} f2_ptr :: FunPtr (IO Unit) {-| __C declaration:__ @f2@ - __defined at:__ @fun_attributes.h:72:65@ + __defined at:__ @fun_attributes.h:77:65@ __exported by:__ @fun_attributes.h@ -} @@ -715,7 +715,7 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_e2e8b5d5ac435de8" hs_b {-# NOINLINE my_memcpy_ptr #-} {-| __C declaration:__ @my_memcpy@ - __defined at:__ @fun_attributes.h:78:1@ + __defined at:__ @fun_attributes.h:83:1@ __exported by:__ @fun_attributes.h@ -} @@ -723,7 +723,7 @@ my_memcpy_ptr :: FunPtr (Ptr Void -> Ptr Void -> Size_t -> IO (Ptr Void)) {-| __C declaration:__ @my_memcpy@ - __defined at:__ @fun_attributes.h:78:1@ + __defined at:__ @fun_attributes.h:83:1@ __exported by:__ @fun_attributes.h@ -} @@ -732,14 +732,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_ea0bb781f9eca7f5" hs_b {-# NOINLINE fatal_ptr #-} {-| __C declaration:__ @fatal@ - __defined at:__ @fun_attributes.h:95:6@ + __defined at:__ @fun_attributes.h:100:6@ __exported by:__ @fun_attributes.h@ -} fatal_ptr :: FunPtr (IO Unit) {-| __C declaration:__ @fatal@ - __defined at:__ @fun_attributes.h:95:6@ + __defined at:__ @fun_attributes.h:100:6@ __exported by:__ @fun_attributes.h@ -} @@ -749,14 +749,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_4de9606eb9c5dd01" hs_b {-# NOINLINE hash_ptr #-} {-| __C declaration:__ @hash@ - __defined at:__ @fun_attributes.h:103:5@ + __defined at:__ @fun_attributes.h:108:5@ __exported by:__ @fun_attributes.h@ -} hash_ptr :: FunPtr (Ptr CChar -> IO CInt) {-| __C declaration:__ @hash@ - __defined at:__ @fun_attributes.h:103:5@ + __defined at:__ @fun_attributes.h:108:5@ __exported by:__ @fun_attributes.h@ -} @@ -766,14 +766,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_4ce141c884649d49" hs_b {-# NOINLINE mymalloc_ptr #-} {-| __C declaration:__ @mymalloc@ - __defined at:__ @fun_attributes.h:108:1@ + __defined at:__ @fun_attributes.h:113:1@ __exported by:__ @fun_attributes.h@ -} mymalloc_ptr :: FunPtr (Size_t -> IO (Ptr Void)) {-| __C declaration:__ @mymalloc@ - __defined at:__ @fun_attributes.h:108:1@ + __defined at:__ @fun_attributes.h:113:1@ __exported by:__ @fun_attributes.h@ -} @@ -782,14 +782,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_5c243ced544ab0aa" hs_b {-# NOINLINE foobar_ptr #-} {-| __C declaration:__ @foobar@ - __defined at:__ @fun_attributes.h:112:13@ + __defined at:__ @fun_attributes.h:117:13@ __exported by:__ @fun_attributes.h@ -} foobar_ptr :: FunPtr (IO Unit) {-| __C declaration:__ @foobar@ - __defined at:__ @fun_attributes.h:112:13@ + __defined at:__ @fun_attributes.h:117:13@ __exported by:__ @fun_attributes.h@ -} @@ -798,14 +798,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_14ef55245a14f816" hs_b {-# NOINLINE core2_func_ptr #-} {-| __C declaration:__ @core2_func@ - __defined at:__ @fun_attributes.h:119:5@ + __defined at:__ @fun_attributes.h:124:5@ __exported by:__ @fun_attributes.h@ -} core2_func_ptr :: FunPtr (IO CInt) {-| __C declaration:__ @core2_func@ - __defined at:__ @fun_attributes.h:119:5@ + __defined at:__ @fun_attributes.h:124:5@ __exported by:__ @fun_attributes.h@ -} @@ -814,14 +814,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_72956748bb6eee67" hs_b {-# NOINLINE sse3_func_ptr #-} {-| __C declaration:__ @sse3_func@ - __defined at:__ @fun_attributes.h:120:5@ + __defined at:__ @fun_attributes.h:125:5@ __exported by:__ @fun_attributes.h@ -} sse3_func_ptr :: FunPtr (IO CInt) {-| __C declaration:__ @sse3_func@ - __defined at:__ @fun_attributes.h:120:5@ + __defined at:__ @fun_attributes.h:125:5@ __exported by:__ @fun_attributes.h@ -} @@ -830,14 +830,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_38506a9ac5626bf2" hs_b {-# NOINLINE f3_ptr #-} {-| __C declaration:__ @f3@ - __defined at:__ @fun_attributes.h:124:49@ + __defined at:__ @fun_attributes.h:129:49@ __exported by:__ @fun_attributes.h@ -} f3_ptr :: FunPtr (IO Unit) {-| __C declaration:__ @f3@ - __defined at:__ @fun_attributes.h:124:49@ + __defined at:__ @fun_attributes.h:129:49@ __exported by:__ @fun_attributes.h@ -} @@ -846,14 +846,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_5929da82079150d1" hs_b {-# NOINLINE fn_ptr #-} {-| __C declaration:__ @fn@ - __defined at:__ @fun_attributes.h:129:5@ + __defined at:__ @fun_attributes.h:134:5@ __exported by:__ @fun_attributes.h@ -} fn_ptr :: FunPtr (IO CInt) {-| __C declaration:__ @fn@ - __defined at:__ @fun_attributes.h:129:5@ + __defined at:__ @fun_attributes.h:134:5@ __exported by:__ @fun_attributes.h@ -} @@ -862,14 +862,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_7bcb4a1873e6ece6" hs_b {-# NOINLINE y_ptr #-} {-| __C declaration:__ @y@ - __defined at:__ @fun_attributes.h:135:12@ + __defined at:__ @fun_attributes.h:140:12@ __exported by:__ @fun_attributes.h@ -} y_ptr :: FunPtr (IO CInt) {-| __C declaration:__ @y@ - __defined at:__ @fun_attributes.h:135:12@ + __defined at:__ @fun_attributes.h:140:12@ __exported by:__ @fun_attributes.h@ -} @@ -878,14 +878,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_11098262b345351a" hs_b {-# NOINLINE x1_ptr #-} {-| __C declaration:__ @x1@ - __defined at:__ @fun_attributes.h:138:12@ + __defined at:__ @fun_attributes.h:143:12@ __exported by:__ @fun_attributes.h@ -} x1_ptr :: FunPtr (IO CInt) {-| __C declaration:__ @x1@ - __defined at:__ @fun_attributes.h:138:12@ + __defined at:__ @fun_attributes.h:143:12@ __exported by:__ @fun_attributes.h@ -} @@ -894,14 +894,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_0d19f83087f278f9" hs_b {-# NOINLINE x2_ptr #-} {-| __C declaration:__ @x2@ - __defined at:__ @fun_attributes.h:141:12@ + __defined at:__ @fun_attributes.h:146:12@ __exported by:__ @fun_attributes.h@ -} x2_ptr :: FunPtr (IO CInt) {-| __C declaration:__ @x2@ - __defined at:__ @fun_attributes.h:141:12@ + __defined at:__ @fun_attributes.h:146:12@ __exported by:__ @fun_attributes.h@ -} @@ -910,14 +910,14 @@ foreign import ccall safe "hs_bindgen_test_fun_attributes_cdc30ae5fb72cd6e" hs_b {-# NOINLINE i_ptr #-} {-| __C declaration:__ @i@ - __defined at:__ @fun_attributes.h:125:5@ + __defined at:__ @fun_attributes.h:130:5@ __exported by:__ @fun_attributes.h@ -} i_ptr :: Ptr CInt {-| __C declaration:__ @i@ - __defined at:__ @fun_attributes.h:125:5@ + __defined at:__ @fun_attributes.h:130:5@ __exported by:__ @fun_attributes.h@ -} diff --git a/hs-bindgen/fixtures/fun_attributes.tree-diff.txt b/hs-bindgen/fixtures/fun_attributes.tree-diff.txt index ebb5099a5..a1956e03b 100644 --- a/hs-bindgen/fixtures/fun_attributes.tree-diff.txt +++ b/hs-bindgen/fixtures/fun_attributes.tree-diff.txt @@ -420,9 +420,10 @@ TranslationUnit { declLoc = "fun_attributes.h:46:5", declId = NamePair { - nameC = Name "old_fn", + nameC = Name + "old_fn_deprecated", nameHsIdent = Identifier - "old_fn"}, + "old_fn_deprecated"}, declOrigin = NameOriginInSource, declAliases = [], declHeaderInfo = Just @@ -449,7 +450,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:57:1", + "fun_attributes.h:62:1", declId = NamePair { nameC = Name "my_dgettext", nameHsIdent = Identifier @@ -507,7 +508,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:68:9", + "fun_attributes.h:73:9", declId = NamePair { nameC = Name "fdopen", nameHsIdent = Identifier @@ -560,7 +561,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:72:65", + "fun_attributes.h:77:65", declId = NamePair { nameC = Name "f2", nameHsIdent = Identifier "f2"}, @@ -589,7 +590,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:78:1", + "fun_attributes.h:83:1", declId = NamePair { nameC = Name "my_memcpy", nameHsIdent = Identifier @@ -651,7 +652,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:95:6", + "fun_attributes.h:100:6", declId = NamePair { nameC = Name "fatal", nameHsIdent = Identifier @@ -681,7 +682,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:103:5", + "fun_attributes.h:108:5", declId = NamePair { nameC = Name "hash", nameHsIdent = Identifier @@ -719,7 +720,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:108:1", + "fun_attributes.h:113:1", declId = NamePair { nameC = Name "mymalloc", nameHsIdent = Identifier @@ -765,7 +766,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:112:13", + "fun_attributes.h:117:13", declId = NamePair { nameC = Name "foobar", nameHsIdent = Identifier @@ -795,7 +796,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:119:5", + "fun_attributes.h:124:5", declId = NamePair { nameC = Name "core2_func", nameHsIdent = Identifier @@ -826,7 +827,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:120:5", + "fun_attributes.h:125:5", declId = NamePair { nameC = Name "sse3_func", nameHsIdent = Identifier @@ -857,7 +858,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:124:49", + "fun_attributes.h:129:49", declId = NamePair { nameC = Name "f3", nameHsIdent = Identifier "f3"}, @@ -886,7 +887,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:125:5", + "fun_attributes.h:130:5", declId = NamePair { nameC = Name "i", nameHsIdent = Identifier "i"}, @@ -911,7 +912,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:129:5", + "fun_attributes.h:134:5", declId = NamePair { nameC = Name "fn", nameHsIdent = Identifier "fn"}, @@ -941,7 +942,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:135:12", + "fun_attributes.h:140:12", declId = NamePair { nameC = Name "y", nameHsIdent = Identifier "y"}, @@ -971,7 +972,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:138:12", + "fun_attributes.h:143:12", declId = NamePair { nameC = Name "x1", nameHsIdent = Identifier "x1"}, @@ -1001,7 +1002,7 @@ TranslationUnit { Decl { declInfo = DeclInfo { declLoc = - "fun_attributes.h:141:12", + "fun_attributes.h:146:12", declId = NamePair { nameC = Name "x2", nameHsIdent = Identifier "x2"}, diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal index 22d0850de..b0166ebe6 100644 --- a/hs-bindgen/hs-bindgen.cabal +++ b/hs-bindgen/hs-bindgen.cabal @@ -49,9 +49,11 @@ common lang DerivingStrategies DerivingVia DisambiguateRecordFields + DuplicateRecordFields FunctionalDependencies LambdaCase MultiWayIf + OverloadedRecordDot OverloadedStrings PatternSynonyms QuantifiedConstraints @@ -134,7 +136,6 @@ library internal HsBindgen.Frontend.LanguageC.PartialAST.FromLanC HsBindgen.Frontend.LanguageC.PartialAST.ToBindgen HsBindgen.Frontend.Naming - HsBindgen.Frontend.NonParsedDecls HsBindgen.Frontend.Pass HsBindgen.Frontend.Pass.HandleMacros HsBindgen.Frontend.Pass.HandleMacros.IsPass @@ -154,8 +155,8 @@ library internal HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass HsBindgen.Frontend.Pass.Select HsBindgen.Frontend.Pass.Select.IsPass - HsBindgen.Frontend.Pass.Sort - HsBindgen.Frontend.Pass.Sort.IsPass + HsBindgen.Frontend.Pass.ConstructTranslationUnit + HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass HsBindgen.Frontend.Predicate HsBindgen.Frontend.ProcessIncludes HsBindgen.Frontend.RootHeader @@ -250,9 +251,7 @@ library executable hs-bindgen-cli import: lang default-extensions: - DuplicateRecordFields NoFieldSelectors - OverloadedRecordDot main-is: hs-bindgen-cli.hs hs-source-dirs: app diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend.hs b/hs-bindgen/src-internal/HsBindgen/Frontend.hs index 2433cb391..65b648b9f 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend.hs @@ -4,6 +4,8 @@ module HsBindgen.Frontend , FrontendMsg(..) ) where +import Optics.Core (_2, view) + import Clang.Enum.Bitfield import Clang.LowLevel.Core import Clang.Paths @@ -14,12 +16,15 @@ import HsBindgen.Clang import HsBindgen.Config.Internal import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex import HsBindgen.Frontend.Analysis.DeclUseGraph qualified as DeclUseGraph +import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph) import HsBindgen.Frontend.Analysis.IncludeGraph qualified as IncludeGraph import HsBindgen.Frontend.Analysis.UseDeclGraph qualified as UseDeclGraph import HsBindgen.Frontend.AST.External qualified as C import HsBindgen.Frontend.AST.Finalize import HsBindgen.Frontend.AST.Internal hiding (Type) import HsBindgen.Frontend.Pass hiding (Config) +import HsBindgen.Frontend.Pass.ConstructTranslationUnit +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.HandleMacros import HsBindgen.Frontend.Pass.HandleMacros.IsPass import HsBindgen.Frontend.Pass.HandleTypedefs @@ -34,8 +39,6 @@ import HsBindgen.Frontend.Pass.ResolveBindingSpecs import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass import HsBindgen.Frontend.Pass.Select import HsBindgen.Frontend.Pass.Select.IsPass -import HsBindgen.Frontend.Pass.Sort -import HsBindgen.Frontend.Pass.Sort.IsPass import HsBindgen.Frontend.Predicate import HsBindgen.Frontend.ProcessIncludes import HsBindgen.Frontend.RootHeader @@ -47,7 +50,7 @@ import HsBindgen.Util.Tracer -- Overview of passes (see documentation of 'HsBindgen.Frontend.Pass.IsPass'): -- -- 1. 'Parse' (impure; all other passes are pure) --- 2. 'Sort' +-- 2. 'ConstructTranslationUnit' -- 3. 'HandleMacros' -- 4. 'NameAnon' -- 5. 'ResolveBindingSpecs' @@ -58,7 +61,7 @@ import HsBindgen.Util.Tracer -- Although the passes and their order are subject to change, we have to honor -- various constraints: -- --- - 'Sort' must come before the following passes because we need to process +-- - 'ConstructTranslationUnit' must come before the following passes because we need to process -- declarations before their uses. -- -- - 'HandleMacros': The macro parser needs to know which things are in scope @@ -103,31 +106,32 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do (includeGraph, isMainHeader, isInMainHeaderDir, getMainHeadersAndInclude) <- processIncludes unit rootHeader <- getRootHeader - reifiedUnit <- parseDecls + parseResults <- parseDecls (contramap FrontendParse tracer) rootHeader frontendParsePredicate - includeGraph isMainHeader isInMainHeaderDir getMainHeadersAndInclude unit pure - ( reifiedUnit + ( parseResults + , includeGraph , isMainHeader , isInMainHeaderDir , toGetMainHeaders getMainHeadersAndInclude ) sortPass <- cache "sort" $ do - (afterParse, _, _, _) <- parsePass - let (afterSort, msgsSort) = sortDecls afterParse - forM_ msgsSort $ traceWith tracer . FrontendSort - pure afterSort + (afterParse, includeGraph, _, _, _) <- parsePass + let (afterConstructTranslationUnit, msgsConstructTranslationUnit) = + constructTranslationUnit afterParse includeGraph + forM_ msgsConstructTranslationUnit $ traceWith tracer . FrontendConstructTranslationUnit + pure afterConstructTranslationUnit handleMacrosPass <- cache "handleMacros" $ do - afterSort <- sortPass - let (afterHandleMacros, msgsHandleMacros) = handleMacros afterSort + afterConstructTranslationUnit <- sortPass + let (afterHandleMacros, msgsHandleMacros) = handleMacros afterConstructTranslationUnit forM_ msgsHandleMacros $ traceWith tracer . FrontendHandleMacros pure afterHandleMacros @@ -141,21 +145,27 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do afterNameAnon <- nameAnonPass extlSpec <- bootExternalBindingSpec presSpec <- bootPrescriptiveBindingSpec - let (afterResolveBindingSpecs, omitTypes, msgsResolveBindingSpecs) = + let ( afterResolveBindingSpecs + , omitTypes + , declsWithExternalBindingSpecs + , msgsResolveBindingSpecs + ) = resolveBindingSpecs extlSpec presSpec afterNameAnon forM_ msgsResolveBindingSpecs $ traceWith tracer . FrontendResolveBindingSpecs - pure (afterResolveBindingSpecs, omitTypes) + pure (afterResolveBindingSpecs, omitTypes, declsWithExternalBindingSpecs) selectPass <- cache "select" $ do - (_, isMainHeader, isInMainHeaderDir, _) <- parsePass - (afterResolveBindingSpecs, _) <- resolveBindingSpecsPass + (_, _, isMainHeader, isInMainHeaderDir, _) <- parsePass + (afterResolveBindingSpecs, _, declsWithExternalBindingSpecs) <- + resolveBindingSpecsPass let (afterSelect, msgsSelect) = selectDecls isMainHeader isInMainHeaderDir + declsWithExternalBindingSpecs selectConfig afterResolveBindingSpecs forM_ msgsSelect $ traceWith tracer . FrontendSelect @@ -180,7 +190,7 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do -- Include graph predicate. getIncludeGraphP <- cache "getIncludeGraphP" $ do - (_, isMainHeader, isInMainHeaderDir, _) <- parsePass + (_, _, isMainHeader, isInMainHeaderDir, _) <- parsePass pure $ \path -> matchParse isMainHeader isInMainHeaderDir path frontendParsePredicate && path /= name @@ -188,13 +198,13 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do -- Graphs. frontendIncludeGraph <- cache "frontendIncludeGraph" $ do includeGraphP <- getIncludeGraphP - (afterParse, _, _, _) <- parsePass - pure (includeGraphP, unitIncludeGraph afterParse) + (_, includeGraph, _, _, _) <- parsePass + pure (includeGraphP, includeGraph) frontendGetMainHeaders <- cache "frontendGetMainHeaders" $ do - (_, _, _, getMainHeaders) <- parsePass + (_, _, _, _, getMainHeaders) <- parsePass pure getMainHeaders frontendIndex <- cache "frontendIndex" $ - declIndex . unitAnn <$> sortPass + declIndex . unitAnn <$> sortPass frontendUseDeclGraph <- cache "frontendUseDeclGraph" $ declUseDecl . unitAnn <$> sortPass frontendDeclUseGraph <- cache "frontendDeclUseGraph" $ @@ -202,7 +212,7 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do -- Omitted types frontendOmitTypes <- cache "frontendOmitTypes" $ - snd <$> resolveBindingSpecsPass + view _2 <$> resolveBindingSpecsPass -- Declarations. frontendCDecls <- cache "frontendDecls" $ @@ -237,17 +247,16 @@ frontend tracer FrontendConfig{..} BootArtefact{..} = do selectConfig = SelectConfig frontendProgramSlicing frontendSelectPredicate - emptyTranslationUnit :: TranslationUnit Parse - emptyTranslationUnit = TranslationUnit { - unitDecls = [] - , unitIncludeGraph = IncludeGraph.empty - , unitAnn = emptyParseDeclMeta - } - - emptyParseResult :: - (TranslationUnit Parse, IsMainHeader, IsInMainHeaderDir, GetMainHeaders) + emptyParseResult :: ( + [ParseResult] + , IncludeGraph + , IsMainHeader + , IsInMainHeaderDir + , GetMainHeaders + ) emptyParseResult = - ( emptyTranslationUnit + ( [] + , IncludeGraph.empty , const False , const False , const (Left "empty") @@ -281,7 +290,7 @@ data FrontendArtefact = FrontendArtefact { data FrontendMsg = FrontendClang ClangMsg | FrontendParse (Msg Parse) - | FrontendSort (Msg Sort) + | FrontendConstructTranslationUnit (Msg ConstructTranslationUnit) | FrontendHandleMacros (Msg HandleMacros) | FrontendNameAnon (Msg NameAnon) | FrontendResolveBindingSpecs (Msg ResolveBindingSpecs) diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/AST/Internal.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/AST/Internal.hs index 56dbc24a9..c85b8d3df 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/AST/Internal.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/AST/Internal.hs @@ -124,12 +124,6 @@ data Availability = | Unavailable deriving stock (Show, Eq, Ord, P.Enum, Bounded, Generic) -instance PrettyForTrace Availability where - prettyForTrace = \case - Available -> "available" - Deprecated -> "deprecated" - Unavailable -> "unavailable" - data DeclInfo p = DeclInfo{ declLoc :: SingleLoc , declId :: Id p diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs index e71dd44e7..826c2fdcf 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Analysis/DeclIndex.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedLabels #-} + -- | Declaration index -- -- Intended for qualified import. @@ -5,20 +7,25 @@ -- > import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex) -- > import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex module HsBindgen.Frontend.Analysis.DeclIndex ( - DeclIndex -- opaque + DeclIndex(..) -- * Construction , DeclIndexError(..) - , fromDecls + , fromParseResults -- * Query , lookup , (!) + , lookupAttachedParseMsgs + , getDecls ) where import Prelude hiding (lookup) import Control.Monad.State import Data.Function +import Data.List.NonEmpty ((<|)) import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Optics.Core (over, set, (%)) import Text.SimplePrettyPrint (hcat, showToCtxDoc) import Clang.HighLevel.Types @@ -34,11 +41,16 @@ import HsBindgen.Util.Tracer Definition -------------------------------------------------------------------------------} --- | Index of all declarations we have parsed -newtype DeclIndex = Wrap { - unwrap :: Map C.QualPrelimDeclId (C.Decl Parse) +-- | Index of all declarations +data DeclIndex = DeclIndex { + succeeded :: !(Map C.QualPrelimDeclId ParseSuccess) + , omitted :: !(Map C.QualPrelimDeclId (NonEmpty ParseNotAttempted)) + , failed :: !(Map C.QualPrelimDeclId (NonEmpty ParseFailure)) } - deriving stock (Show) + deriving stock (Show, Generic) + +emptyIndex :: DeclIndex +emptyIndex = DeclIndex Map.empty Map.empty Map.empty {------------------------------------------------------------------------------- Construction @@ -46,44 +58,74 @@ newtype DeclIndex = Wrap { -- | Construction state (internal type) data PartialIndex = PartialIndex{ - index :: !(Map C.QualPrelimDeclId (C.Decl Parse)) + index :: DeclIndex , errors :: !(Map C.QualPrelimDeclId DeclIndexError) } + deriving (Generic) -fromDecls :: [C.Decl Parse] -> (DeclIndex, [DeclIndexError]) -fromDecls decls = +fromParseResults :: [ParseResult] -> (DeclIndex, [DeclIndexError]) +fromParseResults results = fromPartialIndex - . flip execState (PartialIndex Map.empty Map.empty) - $ mapM_ aux decls + . flip execState (PartialIndex emptyIndex Map.empty) + $ mapM_ aux results where fromPartialIndex :: PartialIndex -> (DeclIndex, [DeclIndexError]) - fromPartialIndex (PartialIndex declIndex errors) = ( - Wrap declIndex - , Map.elems errors - ) - - aux :: C.Decl Parse -> State PartialIndex () - aux decl = modify' $ \oldState@PartialIndex{index, errors} -> + fromPartialIndex (PartialIndex i e) = + -- We assert that no key is used twice. This assertion is not strictly + -- necessary, and we may want to remove it in the future. + let ss = Map.keysSet i.succeeded + os = Map.keysSet i.omitted + fs = Map.keysSet i.failed + is = Set.intersection + sharedKeys = Set.unions [is ss os, is ss fs, is os fs] + in if sharedKeys == Set.empty then + (i, Map.elems e) + else + panicPure $ + "DeclIndex.fromParseResults: shared keys: " <> show sharedKeys + + aux :: ParseResult -> State PartialIndex () + aux parse = modify' $ \oldIndex@PartialIndex{..} -> if Map.member qualPrelimDeclId errors then -- Ignore further definitions of the same ID after an error - oldState - else - let (index', mErr) = flip runState Nothing $ - Map.alterF (insert decl) qualPrelimDeclId index - in PartialIndex{ - index = index' - , errors = case mErr of - Nothing -> errors - Just e -> Map.insert qualPrelimDeclId e errors - } - where - qualPrelimDeclId :: C.QualPrelimDeclId - qualPrelimDeclId = C.declQualPrelimDeclId decl + oldIndex + else case parse of + ParseResultSuccess x -> + let (succeeded', mErr) = flip runState Nothing $ + Map.alterF + (insert x) + qualPrelimDeclId + index.succeeded + in PartialIndex{ + index = set #succeeded succeeded' index + , errors = case mErr of + Nothing -> errors + Just err -> Map.insert qualPrelimDeclId err errors + } + ParseResultNotAttempted x -> + over + ( #index % #omitted ) + ( alter qualPrelimDeclId x ) + oldIndex + ParseResultFailure x -> + over + ( #index % #failed ) + ( alter qualPrelimDeclId x ) + oldIndex + where + qualPrelimDeclId :: C.QualPrelimDeclId + qualPrelimDeclId = getQualPrelimDeclId parse + + alter :: Ord k => k -> a -> Map k (NonEmpty a) -> Map k (NonEmpty a) + alter key x = + Map.alter (\case + Nothing -> Just $ x :| [] + Just xs -> Just $ x <| xs) key insert :: - C.Decl Parse - -> Maybe (C.Decl Parse) - -> State (Maybe DeclIndexError) (Maybe (C.Decl Parse)) + ParseSuccess + -> Maybe ParseSuccess + -> State (Maybe DeclIndexError) (Maybe ParseSuccess) insert new mOld = state $ \_ -> case mOld of Nothing -> @@ -91,10 +133,11 @@ fromDecls decls = success new Just old - | sameDefinition (C.declKind new) (C.declKind old) -> + | sameDefinition new.psDecl.declKind old.psDecl.declKind -> -- Redeclaration but with the same definition. This can happen, - -- for example for opaque structs. We stick with the first. - success old + -- for example for opaque structs. We stick with the first but + -- add the parse messages of the second. + success $ over #psAttachedMsgs (++ new.psAttachedMsgs) old | otherwise -> -- Redeclaration with a /different/ value. This is only legal @@ -113,18 +156,17 @@ fromDecls decls = -- -- See issue #1155. failure $ Redeclaration{ - redeclarationId = C.declQualPrelimDeclId new - , redeclarationOld = C.declLoc $ C.declInfo old - , redeclarationNew = C.declLoc $ C.declInfo new + redeclarationId = C.declQualPrelimDeclId $ new.psDecl + , redeclarationOld = old.psDecl.declInfo.declLoc + , redeclarationNew = new.psDecl.declInfo.declLoc } where - -- No errors; set (or replace) value in the map - success :: C.Decl Parse -> (Maybe (C.Decl Parse), Maybe DeclIndexError) - success decl = (Just decl, Nothing) + success :: a -> (Maybe a, Maybe DeclIndexError) + success x = (Just x, Nothing) -- In case of an error, /remove/ the value from the map - failure :: DeclIndexError -> (Maybe (C.Decl Parse), Maybe DeclIndexError) + failure :: e -> (Maybe a, Maybe e) failure err = (Nothing, Just err) sameDefinition :: C.DeclKind Parse -> C.DeclKind Parse -> Bool @@ -173,9 +215,17 @@ instance IsTrace Level DeclIndexError where -------------------------------------------------------------------------------} lookup :: C.QualPrelimDeclId -> DeclIndex -> Maybe (C.Decl Parse) -lookup qualPrelimDeclId = Map.lookup qualPrelimDeclId . unwrap +lookup qualPrelimDeclId = + fmap psDecl . Map.lookup qualPrelimDeclId . succeeded (!) :: HasCallStack => DeclIndex -> C.QualPrelimDeclId -> C.Decl Parse (!) declIndex qualPrelimDeclId = fromMaybe (panicPure $ "Unknown key: " ++ show qualPrelimDeclId) $ lookup qualPrelimDeclId declIndex + +lookupAttachedParseMsgs :: C.QualPrelimDeclId -> DeclIndex -> [AttachedParseMsg] +lookupAttachedParseMsgs qualPrelimDeclId = + maybe [] psAttachedMsgs . Map.lookup qualPrelimDeclId . succeeded + +getDecls :: DeclIndex -> [C.Decl Parse] +getDecls = map psDecl . Map.elems . succeeded diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Naming.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Naming.hs index f5d6ed1c2..3cada471d 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Naming.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Naming.hs @@ -57,6 +57,7 @@ module HsBindgen.Frontend.Naming ( -- ** QualPrelimDeclId , QualPrelimDeclId(..) , qualPrelimDeclId + , qualPrelimDeclIdSafe -- * NameOrigin , NameOrigin(..) @@ -315,12 +316,27 @@ instance PrettyForTrace QualPrelimDeclId where PP.textToCtxDoc (tagKindPrefix kind) <+> PP.parens (prettyForTrace anonId) QualPrelimDeclIdBuiltin name -> prettyForTrace name -qualPrelimDeclId :: PrelimDeclId -> NameKind -> QualPrelimDeclId +qualPrelimDeclId :: HasCallStack => PrelimDeclId -> NameKind -> QualPrelimDeclId qualPrelimDeclId prelimDeclId kind = case prelimDeclId of PrelimDeclIdNamed name -> QualPrelimDeclIdNamed name kind PrelimDeclIdAnon anonId -> case kind of NameKindTagged tagKind -> QualPrelimDeclIdAnon anonId tagKind - NameKindOrdinary -> panicPure "qualPrelimDeclId ordinary anonymous" + NameKindOrdinary -> panicPure $ + "qualPrelimDeclId: ordinary anonymous: " ++ show anonId + PrelimDeclIdBuiltin name -> QualPrelimDeclIdBuiltin name + +-- TODO #1220. +qualPrelimDeclIdSafe :: PrelimDeclId -> NameKind -> QualPrelimDeclId +qualPrelimDeclIdSafe prelimDeclId kind = case prelimDeclId of + PrelimDeclIdNamed name -> QualPrelimDeclIdNamed name kind + PrelimDeclIdAnon anonId -> case kind of + NameKindTagged tagKind -> QualPrelimDeclIdAnon anonId tagKind + NameKindOrdinary -> + QualPrelimDeclIdNamed + (Name $ Text.pack $ + "qualPrelimDeclIdSafe: impossible ordinary anonymous: " + ++ show anonId) + NameKindOrdinary PrelimDeclIdBuiltin name -> QualPrelimDeclIdBuiltin name {------------------------------------------------------------------------------- diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/NonParsedDecls.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/NonParsedDecls.hs deleted file mode 100644 index da2130425..000000000 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/NonParsedDecls.hs +++ /dev/null @@ -1,57 +0,0 @@ -module HsBindgen.Frontend.NonParsedDecls ( - -- * Type - NonParsedDecls(..) - -- * API - , empty - , insert - , lookup - ) where - -import Prelude hiding (lookup) - -import Data.Map.Strict qualified as Map - -import Clang.Paths (SourcePath) - -import HsBindgen.Frontend.Naming qualified as C -import HsBindgen.Imports - -{------------------------------------------------------------------------------- - Type --------------------------------------------------------------------------------} - --- | Declarations that are not parsed --- --- It is important to keep track of these declarations because they can be given --- external bindings. We do /not/ support external bindings for /anonymous/ --- non-parsed declarations; /if/ you want to provide an external binding for --- some local type, for example --- --- > struct rect { --- > struct { int x; int y; } bottomleft; --- > struct { int x; int y; } topright; --- > }; --- --- then you need to make sure that you /traverse/ @rect@, so that the --- @NameAnon@ pass can do its work. -newtype NonParsedDecls = NonParsedDecls { - unNonParsedDecls :: Map C.QualName SourcePath - } - deriving (Show, Eq) - -{------------------------------------------------------------------------------- - API --------------------------------------------------------------------------------} - -empty :: NonParsedDecls -empty = NonParsedDecls Map.empty - -insert :: - C.QualName - -> SourcePath - -> NonParsedDecls - -> NonParsedDecls -insert k v = NonParsedDecls . Map.insert k v . unNonParsedDecls - -lookup :: C.QualName -> NonParsedDecls -> Maybe SourcePath -lookup k = Map.lookup k . unNonParsedDecls diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit.hs new file mode 100644 index 000000000..0febf00f8 --- /dev/null +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit.hs @@ -0,0 +1,48 @@ +module HsBindgen.Frontend.Pass.ConstructTranslationUnit ( + constructTranslationUnit + ) where + +import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex +import HsBindgen.Frontend.Analysis.DeclUseGraph qualified as DeclUseGraph +import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph) +import HsBindgen.Frontend.Analysis.UseDeclGraph qualified as UseDeclGraph +import HsBindgen.Frontend.AST.Coerce +import HsBindgen.Frontend.AST.Internal qualified as C +import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass +import HsBindgen.Frontend.Pass.Parse.IsPass + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +constructTranslationUnit :: + [ParseResult] + -> IncludeGraph + -> (C.TranslationUnit ConstructTranslationUnit, [Msg ConstructTranslationUnit]) +constructTranslationUnit parseResults includeGraph = + let (declMeta, declIndexErrors) = mkDeclMeta parseResults includeGraph + in ( C.TranslationUnit{ + unitDecls = map coercePass $ + UseDeclGraph.toDecls + (declIndex declMeta) + (declUseDecl declMeta) + , unitIncludeGraph = includeGraph + , unitAnn = declMeta + , .. + } + , declIndexErrors + ) + +mkDeclMeta :: + [ParseResult] + -> IncludeGraph + -> (DeclMeta, [Msg ConstructTranslationUnit]) +mkDeclMeta parseResults includeGraph = + let (declIndex, declIndexErrors) = DeclIndex.fromParseResults parseResults + declUseDecl = + UseDeclGraph.fromDecls includeGraph $ DeclIndex.getDecls declIndex + declDeclUse = DeclUseGraph.fromUseDecl declUseDecl + in ( DeclMeta{..} + , map ConstructTranslationUnitErrorDeclIndex declIndexErrors + ) diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs new file mode 100644 index 000000000..eb5055dc2 --- /dev/null +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ConstructTranslationUnit/IsPass.hs @@ -0,0 +1,70 @@ +module HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass ( + ConstructTranslationUnit + , DeclMeta(..) + , ConstructTranslationUnitMsg(..) + ) where + +import HsBindgen.Frontend.Analysis.DeclIndex +import HsBindgen.Frontend.Analysis.DeclUseGraph +import HsBindgen.Frontend.Analysis.UseDeclGraph +import HsBindgen.Frontend.AST.Coerce (CoercePass (..)) +import HsBindgen.Frontend.AST.Internal (ValidPass) +import HsBindgen.Frontend.Naming qualified as C +import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.Parse.IsPass +import HsBindgen.Imports +import HsBindgen.Util.Tracer + +{------------------------------------------------------------------------------- + Definition + + Inspect the parse results and construct the translation unit. +-------------------------------------------------------------------------------} + +type ConstructTranslationUnit :: Pass +data ConstructTranslationUnit a deriving anyclass ValidPass + +type family AnnConstructTranslationUnit (ix :: Symbol) :: Star where + AnnConstructTranslationUnit "TranslationUnit" = DeclMeta + AnnConstructTranslationUnit "StructField" = ReparseInfo + AnnConstructTranslationUnit "UnionField" = ReparseInfo + AnnConstructTranslationUnit "Typedef" = ReparseInfo + AnnConstructTranslationUnit "Function" = ReparseInfo + AnnConstructTranslationUnit _ = NoAnn + +instance IsPass ConstructTranslationUnit where + type Id ConstructTranslationUnit = C.PrelimDeclId + type FieldName ConstructTranslationUnit = C.Name + type ArgumentName ConstructTranslationUnit = Maybe C.Name + type TypedefRef ConstructTranslationUnit = OrigTypedefRef ConstructTranslationUnit + type MacroBody ConstructTranslationUnit = UnparsedMacro + type ExtBinding ConstructTranslationUnit = Void + type Ann ix ConstructTranslationUnit = AnnConstructTranslationUnit ix + type Msg ConstructTranslationUnit = ConstructTranslationUnitMsg + +{------------------------------------------------------------------------------- + Information about the declarations +-------------------------------------------------------------------------------} + +data DeclMeta = DeclMeta { + declIndex :: DeclIndex + , declUseDecl :: UseDeclGraph + , declDeclUse :: DeclUseGraph + } + deriving stock (Show, Generic) + +{------------------------------------------------------------------------------- + Trace messages +-------------------------------------------------------------------------------} + +data ConstructTranslationUnitMsg = + ConstructTranslationUnitErrorDeclIndex DeclIndexError + deriving stock (Show, Generic) + deriving anyclass (PrettyForTrace, IsTrace Level) + +{------------------------------------------------------------------------------- + CoercePass +-------------------------------------------------------------------------------} + +instance CoercePass TypedefRefWrapper Parse ConstructTranslationUnit where + coercePass (TypedefRefWrapper p) = TypedefRefWrapper (coercePass p) diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs index c3135f8fd..5a2f728d6 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros.hs @@ -20,9 +20,9 @@ import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.LanguageC qualified as LanC import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.HandleMacros.IsPass import HsBindgen.Frontend.Pass.Parse.IsPass -import HsBindgen.Frontend.Pass.Sort.IsPass import HsBindgen.Imports {------------------------------------------------------------------------------- @@ -31,7 +31,7 @@ import HsBindgen.Imports -- | Sort and typecheck macros, and reparse declarations handleMacros :: - C.TranslationUnit Sort + C.TranslationUnit ConstructTranslationUnit -> (C.TranslationUnit HandleMacros, [Msg HandleMacros]) handleMacros C.TranslationUnit{unitDecls, unitIncludeGraph, unitAnn} = first reassemble $ runM . fmap catMaybes $ mapM processDecl unitDecls @@ -40,10 +40,10 @@ handleMacros C.TranslationUnit{unitDecls, unitIncludeGraph, unitAnn} = reassemble decls' = C.TranslationUnit{ unitDecls = decls' , unitIncludeGraph - , unitAnn = coerceDeclMeta unitAnn + , unitAnn } -processDecl :: C.Decl Sort -> M (Maybe (C.Decl HandleMacros)) +processDecl :: C.Decl ConstructTranslationUnit -> M (Maybe (C.Decl HandleMacros)) processDecl C.Decl{declInfo, declKind} = case declKind of C.DeclMacro macro -> processMacro info' macro @@ -64,7 +64,7 @@ processDecl C.Decl{declInfo, declKind} = processStruct :: C.DeclInfo HandleMacros - -> C.Struct Sort + -> C.Struct ConstructTranslationUnit -> M (C.Decl HandleMacros) processStruct info C.Struct{..} = mkDecl <$> mapM processStructField structFields @@ -76,7 +76,7 @@ processStruct info C.Struct{..} = , declAnn = NoAnn } -processStructField :: C.StructField Sort -> M (C.StructField HandleMacros) +processStructField :: C.StructField ConstructTranslationUnit -> M (C.StructField HandleMacros) processStructField C.StructField{..} = case structFieldAnn of ReparseNotNeeded -> @@ -115,7 +115,7 @@ processStructField C.StructField{..} = processUnion :: C.DeclInfo HandleMacros - -> C.Union Sort + -> C.Union ConstructTranslationUnit -> M (C.Decl HandleMacros) processUnion info C.Union{..} = combineFields <$> mapM processUnionField unionFields @@ -127,7 +127,7 @@ processUnion info C.Union{..} = , declAnn = NoAnn } -processUnionField :: C.UnionField Sort -> M (C.UnionField HandleMacros) +processUnionField :: C.UnionField ConstructTranslationUnit -> M (C.UnionField HandleMacros) processUnionField C.UnionField{..} = case unionFieldAnn of ReparseNotNeeded -> @@ -176,7 +176,7 @@ processOpaque kind info = processEnum :: C.DeclInfo HandleMacros - -> C.Enum Sort + -> C.Enum ConstructTranslationUnit -> M (C.Decl HandleMacros) processEnum info C.Enum{..} = mkDecl <$> mapM processEnumConstant enumConstants @@ -193,7 +193,7 @@ processEnum info C.Enum{..} = } processEnumConstant :: - C.EnumConstant Sort + C.EnumConstant ConstructTranslationUnit -> M (C.EnumConstant HandleMacros) processEnumConstant C.EnumConstant{..} = return C.EnumConstant { @@ -209,7 +209,7 @@ processEnumConstant C.EnumConstant{..} = return processTypedef :: C.DeclInfo HandleMacros - -> C.Typedef Sort + -> C.Typedef ConstructTranslationUnit -> M (C.Decl HandleMacros) processTypedef info C.Typedef{typedefType, typedefAnn} = do modify $ \st -> st{ @@ -282,7 +282,7 @@ processMacro info (UnparsedMacro tokens) = do processFunction :: C.DeclInfo HandleMacros - -> C.Function Sort + -> C.Function ConstructTranslationUnit -> M (C.Decl HandleMacros) processFunction info C.Function {..} = case functionAnn of @@ -326,7 +326,7 @@ processFunction info C.Function {..} = processGlobal :: C.DeclInfo HandleMacros -> (C.Type HandleMacros -> C.DeclKind HandleMacros) - -> C.Type Sort + -> C.Type ConstructTranslationUnit -> M (C.Decl HandleMacros) processGlobal info f ty = return $ C.Decl{ diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/IsPass.hs index 5dc3ca55c..74aa9d397 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleMacros/IsPass.hs @@ -15,8 +15,9 @@ import HsBindgen.Frontend.AST.Internal (CheckedMacro, ValidPass) import HsBindgen.Frontend.LanguageC qualified as LanC import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass (ConstructTranslationUnit, + DeclMeta) import HsBindgen.Frontend.Pass.Parse.IsPass (OrigTypedefRef (..)) -import HsBindgen.Frontend.Pass.Sort.IsPass (DeclMeta, Sort) import HsBindgen.Imports import HsBindgen.Util.Tracer @@ -29,7 +30,7 @@ data HandleMacros a deriving anyclass ValidPass -- We do not need the @ReparseInfo@ anymore, so we drop it from the annotations. type family AnnHandleMacros (ix :: Symbol) :: Star where - AnnHandleMacros "TranslationUnit" = DeclMeta HandleMacros + AnnHandleMacros "TranslationUnit" = DeclMeta AnnHandleMacros _ = NoAnn instance IsPass HandleMacros where @@ -109,5 +110,5 @@ instance IsTrace Level HandleMacrosMsg where CoercePass -------------------------------------------------------------------------------} -instance CoercePass TypedefRefWrapper Sort HandleMacros where +instance CoercePass TypedefRefWrapper ConstructTranslationUnit HandleMacros where coercePass (TypedefRefWrapper ref) = TypedefRefWrapper (coercePass ref) diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs.hs index 19939c9e4..0aa47687e 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs.hs @@ -10,6 +10,7 @@ import HsBindgen.Frontend.AST.Coerce import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.HandleTypedefs.IsPass import HsBindgen.Frontend.Pass.Parse.IsPass (OrigTypedefRef (..)) import HsBindgen.Frontend.Pass.Select.IsPass @@ -31,7 +32,7 @@ handleTypedefs C.TranslationUnit{..} = ( ) where td :: TypedefAnalysis - td = TypedefAnalysis.fromDecls (selectDeclDeclUse unitAnn) unitDecls + td = TypedefAnalysis.fromDecls unitAnn.declDeclUse unitDecls msgs :: [Maybe (Msg HandleTypedefs)] decls' :: [Maybe (C.Decl HandleTypedefs)] diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs/IsPass.hs index 93b4c3718..3ab2ae964 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/HandleTypedefs/IsPass.hs @@ -11,8 +11,8 @@ import HsBindgen.Frontend.AST.Internal (ValidPass) import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass -import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass (ResolvedExtBinding) -import HsBindgen.Frontend.Pass.Select.IsPass (SelectDeclMeta) +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass +import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass import HsBindgen.Imports import HsBindgen.Util.Tracer @@ -24,7 +24,7 @@ type HandleTypedefs :: Pass data HandleTypedefs a deriving anyclass ValidPass type family AnnHandleTypedefs ix where - AnnHandleTypedefs "TranslationUnit" = SelectDeclMeta + AnnHandleTypedefs "TranslationUnit" = DeclMeta AnnHandleTypedefs "Decl" = BindingSpec.CTypeSpec AnnHandleTypedefs _ = NoAnn diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/MangleNames/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/MangleNames/IsPass.hs index 8715e9e6f..6809488ad 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/MangleNames/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/MangleNames/IsPass.hs @@ -10,9 +10,9 @@ import HsBindgen.BindingSpec qualified as BindingSpec import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.HandleTypedefs.IsPass -import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass (ResolvedExtBinding) -import HsBindgen.Frontend.Pass.Select.IsPass +import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass import HsBindgen.Imports import HsBindgen.Util.Tracer @@ -25,7 +25,7 @@ type MangleNames :: Pass data MangleNames a deriving anyclass (C.ValidPass) type family AnnMangleNames ix where - AnnMangleNames "TranslationUnit" = SelectDeclMeta + AnnMangleNames "TranslationUnit" = DeclMeta AnnMangleNames "Decl" = BindingSpec.CTypeSpec AnnMangleNames "Struct" = C.RecordNames AnnMangleNames "Union" = C.NewtypeNames diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon.hs index 2e4fcbd2f..cf020b7c5 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon.hs @@ -1,3 +1,4 @@ + module HsBindgen.Frontend.Pass.NameAnon ( nameAnon ) where @@ -13,11 +14,10 @@ import HsBindgen.Frontend.AST.Coerce import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.HandleMacros.IsPass import HsBindgen.Frontend.Pass.NameAnon.IsPass -import HsBindgen.Frontend.Pass.Parse.IsPass (OrigTypedefRef (..), - ParseMsgKey (..), mapParseMsgs) -import HsBindgen.Frontend.Pass.Sort.IsPass +import HsBindgen.Frontend.Pass.Parse.IsPass (OrigTypedefRef (..)) import HsBindgen.Imports {------------------------------------------------------------------------------- @@ -31,10 +31,6 @@ nameAnon :: nameAnon C.TranslationUnit{..} = ( C.TranslationUnit{ unitDecls = unitDecls' - , unitAnn = unitAnn { - declParseMsgs = mapParseMsgs (getDeclIdParseMsgKey env) $ - declParseMsgs unitAnn - } , .. } , msgs @@ -122,18 +118,6 @@ getDeclId env qualPrelimDeclId declId = C.PrelimDeclIdBuiltin name -> Right $ C.DeclId name C.NameOriginInSource -getDeclIdParseMsgKey :: RenameEnv -> ParseMsgKey HandleMacros -> ParseMsgKey NameAnon -getDeclIdParseMsgKey env key = key{parseMsgDeclId = declId'} - where - declId :: Id HandleMacros - declId = parseMsgDeclId key - - qualPrelimDeclId :: C.QualPrelimDeclId - qualPrelimDeclId = C.qualPrelimDeclId declId (parseMsgDeclKind key) - - declId' :: Id NameAnon - declId' = either id id $ getDeclId env qualPrelimDeclId declId - {------------------------------------------------------------------------------- Use sites -------------------------------------------------------------------------------} diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon/IsPass.hs index 39b54022b..b856026fc 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/NameAnon/IsPass.hs @@ -9,8 +9,8 @@ import HsBindgen.Frontend.AST.Internal (ValidPass) import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.Parse.IsPass -import HsBindgen.Frontend.Pass.Sort.IsPass import HsBindgen.Imports import HsBindgen.Util.Tracer @@ -22,7 +22,7 @@ type NameAnon :: Pass data NameAnon a deriving anyclass ValidPass type family AnnNameAnon ix where - AnnNameAnon "TranslationUnit" = DeclMeta NameAnon + AnnNameAnon "TranslationUnit" = DeclMeta AnnNameAnon _ = NoAnn instance IsPass NameAnon where @@ -40,7 +40,7 @@ instance IsPass NameAnon where -------------------------------------------------------------------------------} data NameAnonMsg = - -- | Skipped unused anonymous declaration entirely + -- | Skipped unused anonymous declaration -- -- @clang@ will produce a warning for this ("declaration does not declare -- anything"); we issue a separate message here in case we skip over diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse.hs index 8e6427df3..9a2dc5285 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse.hs @@ -6,8 +6,6 @@ module HsBindgen.Frontend.Pass.Parse ( import Clang.HighLevel qualified as HighLevel import Clang.LowLevel.Core -import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph) -import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Pass.Parse.Decl import HsBindgen.Frontend.Pass.Parse.Decl.Monad qualified as ParseDecl import HsBindgen.Frontend.Pass.Parse.IsPass @@ -24,17 +22,15 @@ parseDecls :: Tracer IO UnattachedParseMsg -> RootHeader -> Boolean ParsePredicate - -> IncludeGraph -> IsMainHeader -> IsInMainHeaderDir -> GetMainHeadersAndInclude -> CXTranslationUnit - -> IO (C.TranslationUnit Parse) + -> IO [ParseResult] parseDecls tracer rootHeader predicate - includeGraph isMainHeader isInMainHeaderDir getMainHeadersAndInclude @@ -50,11 +46,5 @@ parseDecls , envTracer = tracer } root <- clang_getTranslationUnitCursor unit - (omittedDecls, decls) <- fmap (fmap concat) . ParseDecl.run parseEnv $ + fmap concat . ParseDecl.run parseEnv $ HighLevel.clang_visitChildren root topLevelDecl - let reifiedUnit = C.TranslationUnit{ - unitDecls = decls - , unitIncludeGraph = includeGraph - , unitAnn = omittedDecls - } - pure reifiedUnit diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs index 64f33f545..194fe57d4 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl.hs @@ -34,18 +34,17 @@ import HsBindgen.Imports -- 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 :: Fold ParseDecl [C.Decl Parse] +topLevelDecl :: Fold ParseDecl [ParseResult] topLevelDecl = foldWithHandler handleTypeException parseDecl where handleTypeException :: CXCursor -> ParseTypeExceptionInContext ParseTypeExceptionContext - -> ParseDecl (Maybe [C.Decl Parse]) + -> ParseDecl (Maybe [ParseResult]) handleTypeException curr err = do info <- getDeclInfo curr - recordDelayedTrace info contextNameKind $ - ParseUnsupportedType (parseException err) - return Nothing + pure $ Just $ singleton $ + parseFail info contextNameKind $ ParseUnsupportedType (parseException err) where ParseTypeExceptionContext{..} = parseContext err @@ -129,10 +128,10 @@ getReparseInfo = \curr -> do Functions for each kind of declaration -------------------------------------------------------------------------------} -type Parser = CXCursor -> ParseDecl (Next ParseDecl [C.Decl Parse]) +type Parser = CXCursor -> ParseDecl (Next ParseDecl [ParseResult]) -- | Declarations -parseDecl :: Parser +parseDecl :: HasCallStack => Parser parseDecl = \curr -> do info <- getDeclInfo curr let isBuiltin = case C.declId info of @@ -142,28 +141,21 @@ parseDecl = \curr -> do C.Unavailable -> True _otherwise -> False - let parseWith :: + parseWith :: (C.DeclInfo Parse -> Parser) -> C.NameKind - -> ParseDecl (Next ParseDecl [C.Decl Parse]) + -> ParseDecl (Next ParseDecl [ParseResult]) parseWith parser kind - | isBuiltin = do - -- TODO Support builtin macros (#1087) - let trace = ParseNotAttempted "builtin declaration" info - recordUnattachedTrace trace - recordNonParsedDecl info kind >> foldContinue - | isUnavailable = do - let trace = ParseNotAttemptedUnexpected "declaration is unavailable" info - recordUnattachedTrace trace - recordNonParsedDecl info kind >> foldContinue + | isBuiltin = foldContinueWith + [parseDoNotAttempt info kind OmittedBuiltin] + | isUnavailable = foldContinueWith + [parseDoNotAttempt info kind DeclarationUnavailable] | otherwise = do matched <- evalPredicate info if matched then parser info curr - else do - let trace = ParseNotAttempted "parse predicate did not match" info - recordUnattachedTrace trace - recordNonParsedDecl info kind >> foldContinue + else foldContinueWith + [parseDoNotAttempt info kind ParsePredicateNotMatched] dispatch curr $ \case -- Ordinary kinds that we parse @@ -209,7 +201,7 @@ macroDefinition info = \curr -> do , declAnn = NoAnn } decl <- mkDecl <$> getUnparsedMacro unit curr - foldContinueWith [decl] + foldContinueWith [ParseResultSuccess $ ParseSuccess decl []] structDecl :: C.DeclInfo Parse -> Parser structDecl info = \curr -> do @@ -240,39 +232,35 @@ structDecl info = \curr -> do -- This matters, because we need the offsets of these implicit fields. -- For now we therefore only try to detect the situation and report an -- error when it happens. Hopefully this is anyway very rare. - let partitionChildren :: [ - Either [C.Decl Parse] (C.StructField Parse)] - -> ParseDecl (Maybe ([C.Decl Parse], [C.StructField Parse])) - partitionChildren xs - | null unused = return $ Just (used, fields) - | otherwise = do - recordDelayedTrace info (NameKindTagged TagKindStruct) - ParseUnsupportedImplicitFields - return Nothing + let partitionChildren :: + [C.Decl Parse] -> [C.StructField Parse] + -> ParseDecl (Maybe [C.Decl Parse]) + partitionChildren otherDecls fields + | null unused = pure $ Just used + | otherwise = pure Nothing where - otherDecls :: [C.Decl Parse] - fields :: [C.StructField Parse] - (otherDecls, fields) = first concat $ partitionEithers xs - used, unused :: [C.Decl Parse] (used, unused) = detectStructImplicitFields otherDecls fields foldRecurseWith (declOrFieldDecl $ structFieldDecl info) $ \xs -> do - mPartitioned <- partitionChildren xs - case mPartitioned of - Just (decls, fields) -> - return $ decls ++ [mkStruct fields] + let (otherRs, fields) = first concat $ partitionEithers xs + (fails, otherDecls) = partitionEithers $ map getDecl otherRs + mPartitioned <- partitionChildren otherDecls fields + pure $ (fails ++) $ case mPartitioned of + Just decls -> + map parseSucceed $ decls ++ [mkStruct fields] Nothing -> -- If the struct has implicit fields, don't generate anything. - return [] - DefinitionUnavailable -> do + singleton $ parseFail info (NameKindTagged TagKindStruct) $ + ParseUnsupportedImplicitFields + DefinitionUnavailable -> let decl :: C.Decl Parse decl = C.Decl{ declInfo = info , declKind = C.DeclOpaque (C.NameKindTagged C.TagKindStruct) , declAnn = NoAnn } - foldContinueWith [decl] + in foldContinueWith [ParseResultSuccess $ ParseSuccess decl []] DefinitionElsewhere _ -> foldContinue @@ -306,30 +294,26 @@ unionDecl info = \curr -> do -- For now we only try to detect the situation and report an error when -- it happens. Hopefully this is anyway very rare. let partitionChildren :: - [Either [C.Decl Parse] (C.UnionField Parse)] - -> ParseDecl (Maybe ([C.Decl Parse], [C.UnionField Parse])) - partitionChildren xs - | null unused = return $ Just (used, fields) - | otherwise = do - recordDelayedTrace info (NameKindTagged TagKindUnion) - ParseUnsupportedImplicitFields - return Nothing + [C.Decl Parse] -> [C.UnionField Parse] + -> ParseDecl (Maybe [C.Decl Parse]) + partitionChildren otherDecls fields + | null unused = pure $ Just used + | otherwise = pure Nothing where - otherDecls :: [C.Decl Parse] - fields :: [C.UnionField Parse] - (otherDecls, fields) = first concat $ partitionEithers xs - used, unused :: [C.Decl Parse] (used, unused) = detectUnionImplicitFields otherDecls fields foldRecurseWith (declOrFieldDecl $ unionFieldDecl info) $ \xs -> do - mPartitioned <- partitionChildren xs - case mPartitioned of - Just (decls, fields) -> - return $ decls ++ [mkUnion fields] - Nothing -> - -- If the struct has implicit fields, don't generate anything. - return [] + let (otherRs, fields) = first concat $ partitionEithers xs + (fails, otherDecls) = partitionEithers $ map getDecl otherRs + mPartitioned <- partitionChildren otherDecls fields + pure $ (fails ++) $ case mPartitioned of + Just decls -> + map parseSucceed $ decls ++ [mkUnion fields] + Nothing -> + -- If the struct has implicit fields, don't generate anything. + singleton $ parseFail info (NameKindTagged TagKindUnion) $ + ParseUnsupportedImplicitFields DefinitionUnavailable -> do let decl :: C.Decl Parse decl = C.Decl{ @@ -337,13 +321,13 @@ unionDecl info = \curr -> do , declKind = C.DeclOpaque (C.NameKindTagged C.TagKindUnion) , declAnn = NoAnn } - foldContinueWith [decl] + foldContinueWith [parseSucceed decl] DefinitionElsewhere _ -> foldContinue declOrFieldDecl :: (CXCursor -> ParseDecl (a Parse)) - -> Fold ParseDecl (Either [C.Decl Parse] (a Parse)) + -> Fold ParseDecl (Either [ParseResult] (a Parse)) declOrFieldDecl fieldDecl = simpleFold $ \curr -> do kind <- fromSimpleEnum <$> clang_getCursorKind curr case kind of @@ -407,7 +391,7 @@ typedefDecl info = \curr -> do } , declAnn = NoAnn } - foldContinueWith [decl] + foldContinueWith [parseSucceed decl] macroExpansion :: Parser macroExpansion = \curr -> do @@ -440,7 +424,7 @@ enumDecl info = \curr -> do , declAnn = NoAnn } - foldRecursePure parseConstant ((:[]) . mkEnum) + foldRecursePure parseConstant ((:[]) . parseSucceed . mkEnum) DefinitionUnavailable -> do let decl :: C.Decl Parse decl = C.Decl{ @@ -448,7 +432,7 @@ enumDecl info = \curr -> do , declKind = C.DeclOpaque (C.NameKindTagged C.TagKindEnum) , declAnn = NoAnn } - foldContinueWith [decl] + foldContinueWith [parseSucceed decl] DefinitionElsewhere _ -> foldContinue where @@ -476,8 +460,8 @@ functionDecl info = \curr -> do typ <- fromCXType' (ParseTypeExceptionContext info NameKindOrdinary) =<< clang_getCursorType curr guardTypeFunction curr typ >>= \case - Nothing -> foldContinue - Just (functionArgs, functionRes) -> do + Left rs -> foldContinueWith [rs] + Right (functionArgs, functionRes) -> do functionAnn <- getReparseInfo curr let mkDecl :: C.FunctionPurity -> C.Decl Parse mkDecl purity = C.Decl{ @@ -499,30 +483,37 @@ functionDecl info = \curr -> do foldContinue _ -> foldRecurseWith nestedDecl $ \nestedDecls -> do let declsAndAttrs = concat nestedDecls - (decls, attrs) = partitionEithers declsAndAttrs + (parseRs, attrs) = partitionEithers declsAndAttrs + (fails, decls) = partitionEithers $ map getDecl parseRs purity = C.decideFunctionPurity attrs (anonDecls, otherDecls) = partitionAnonDecls decls -- This declaration may act as a definition. let isDefn = declCls == Definition - if not (null anonDecls) then do - recordDelayedTrace info NameKindOrdinary - ParseUnexpectedAnonInSignature - return [] - else do - when (visibilityCanCauseErrors visibility linkage isDefn) $ - recordDelayedTrace info NameKindOrdinary - ParseNonPublicVisibility - when (isDefn && linkage == ExternalLinkage) $ - recordDelayedTrace info NameKindOrdinary $ - ParsePotentialDuplicateSymbol (visibility == PublicVisibility) - return $ otherDecls ++ [mkDecl purity] + pure $ (fails ++) $ + if not (null anonDecls) + then + singleton $ + parseFail info NameKindOrdinary ParseUnexpectedAnonInSignature + else + let nonPublicVisibility = [ + ParseNonPublicVisibility + | visibilityCanCauseErrors visibility linkage isDefn + ] + potentialDuplicate = [ + ParsePotentialDuplicateSymbol (visibility == PublicVisibility) + | isDefn && linkage == ExternalLinkage + ] + funDeclResult = + parseSucceedWith + (nonPublicVisibility ++ potentialDuplicate) $ mkDecl purity + in map parseSucceed otherDecls ++ [funDeclResult] where guardTypeFunction :: CXCursor -> C.Type Parse - -> ParseDecl (Maybe ([(Maybe C.Name, C.Type Parse)], C.Type Parse)) + -> ParseDecl (Either ParseResult ([(Maybe C.Name, C.Type Parse)], C.Type Parse)) guardTypeFunction curr ty = case ty of C.TypeFun args res -> do @@ -536,17 +527,16 @@ functionDecl info = \curr -> do else Just (C.Name argName) return (mbArgName, argCType) - pure $ Just (args', res) - C.TypeTypedef{} -> do - recordDelayedTrace info NameKindOrdinary ParseFunctionOfTypeTypedef - pure Nothing + pure $ Right (args', res) + C.TypeTypedef{} -> + pure $ Left $ parseFail info NameKindOrdinary ParseFunctionOfTypeTypedef otherType -> - panicIO $ "Expected function type, but got " <> show otherType + panicIO $ "expected function type, but got " <> 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 (C.Decl Parse) C.FunctionPurity] + nestedDecl :: Fold ParseDecl [Either ParseResult C.FunctionPurity] nestedDecl = simpleFold $ \curr -> do kind <- fromSimpleEnum <$> clang_getCursorKind curr case kind of @@ -611,8 +601,10 @@ varDecl info = \curr -> do -- declaration. DefinitionElsewhere _-> foldContinue - _ -> foldRecurseWith nestedDecl $ \nestedDecls -> do - let (anonDecls, otherDecls) = partitionAnonDecls (concat nestedDecls) + _ -> foldRecurseWith nestedDecl $ \nestedRs -> do + let + (fails, nestedDecls) = partitionEithers $ map getDecl $ concat nestedRs + (anonDecls, otherDecls) = partitionAnonDecls nestedDecls -- This declaration may act as a definition even if it has no -- initialiser. @@ -620,30 +612,38 @@ varDecl info = \curr -> do let isDefn = declCls == Definition || (isTentative && declCls == DefinitionUnavailable) - if not (null anonDecls) then do - recordDelayedTrace info NameKindOrdinary ParseUnexpectedAnonInExtern - return [] - else (otherDecls ++) <$> do - when (visibilityCanCauseErrors visibility linkage isDefn) $ - recordDelayedTrace info NameKindOrdinary ParseNonPublicVisibility - when (isDefn && linkage == ExternalLinkage) $ - recordDelayedTrace info NameKindOrdinary $ - ParsePotentialDuplicateSymbol (visibility == PublicVisibility) - case cls of - VarGlobal -> do - return [mkDecl $ C.DeclGlobal typ] - VarConst -> do - return [mkDecl $ C.DeclGlobal typ] - VarThreadLocal -> do - recordDelayedTrace info NameKindOrdinary ParseUnsupportedTLS - return [] - VarUnsupported storage -> do - recordDelayedTrace info NameKindOrdinary $ - ParseUnknownStorageClass storage - return [] + pure $ (fails ++) $ + if not (null anonDecls) + then singleton $ + parseFail info NameKindOrdinary ParseUnexpectedAnonInExtern + else (map parseSucceed otherDecls ++) $ + let nonPublicVisibility = [ + ParseNonPublicVisibility + | visibilityCanCauseErrors visibility linkage isDefn + ] + potentialDuplicate = [ + ParsePotentialDuplicateSymbol (visibility == PublicVisibility) + | isDefn && linkage == ExternalLinkage + ] + msgs = nonPublicVisibility ++ potentialDuplicate + parseFailWith' = parseFailWith info NameKindOrdinary + + in case cls of + VarGlobal -> + singleton $ + parseSucceedWith msgs (mkDecl $ C.DeclGlobal typ) + VarConst -> + singleton $ + parseSucceedWith msgs (mkDecl $ C.DeclGlobal typ) + VarThreadLocal -> + singleton $ + parseFailWith' $ ParseUnsupportedTLS :| msgs + VarUnsupported storage -> + singleton $ + parseFailWith' $ ParseUnknownStorageClass storage :| msgs where -- Look for nested declarations inside the global variable type - nestedDecl :: Fold ParseDecl [C.Decl Parse] + nestedDecl :: Fold ParseDecl [ParseResult] nestedDecl = simpleFold $ \curr -> do kind <- fromSimpleEnum <$> clang_getCursorKind curr case kind of diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl/Monad.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl/Monad.hs index 570faf44b..bb021b6a0 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl/Monad.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/Decl/Monad.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedLabels #-} + -- | Monad for parsing declarations -- -- Intended for unqualified import (unless context is unambiguous). @@ -17,10 +19,8 @@ module HsBindgen.Frontend.Pass.Parse.Decl.Monad ( -- ** "State" , recordMacroExpansionAt , checkHasMacroExpansion - , recordNonParsedDecl -- ** Logging , recordUnattachedTrace - , recordDelayedTrace -- ** Errors , unknownCursorKind -- * Utility: dispatching @@ -40,10 +40,6 @@ import Clang.Paths import HsBindgen.Eff import HsBindgen.Errors import HsBindgen.Frontend.AST.Internal qualified as C -import HsBindgen.Frontend.Naming qualified as C -import HsBindgen.Frontend.NonParsedDecls (NonParsedDecls) -import HsBindgen.Frontend.NonParsedDecls qualified as NonParsedDecls -import HsBindgen.Frontend.Pass import HsBindgen.Frontend.Pass.Parse.IsPass import HsBindgen.Frontend.Predicate import HsBindgen.Frontend.ProcessIncludes (GetMainHeadersAndInclude) @@ -72,16 +68,10 @@ data ParseSupport = ParseSupport { type instance Support ParseDeclMonad = ParseSupport -run :: Env -> ParseDecl a -> IO (Ann "TranslationUnit" Parse, a) +run :: Env -> ParseDecl a -> IO a run env f = do support <- ParseSupport env <$> newIORef initParseState - x <- unwrapEff f support - state <- readIORef (parseState support) - let meta = ParseDeclMeta { - parseDeclNonParsed = stateNonParsedDecls state - , parseDeclParseMsg = stateParseMsgs state - } - pure (meta, x) + unwrapEff f support {------------------------------------------------------------------------------- "Reader" @@ -123,28 +113,13 @@ data ParseState = ParseState { -- | Where did clang expand macros? -- -- Declarations with expanded macros need to be reparsed. - stateMacroExpansions :: Set SingleLoc - - -- | Non-parsed declarations - -- - -- We need to track which header each excluded declaration is declared in - -- so that we can resolve external bindings. - , stateNonParsedDecls :: NonParsedDecls - - -- | Some traces are linked to specific declarations. However, we only - -- select and process a subset of all parsed declarations. To reduce - -- noise, we only emit traces linked to selected and processed - -- declarations. Since we change the info object between passes, we link - -- messages to source locations. For a given declaration, the source - -- location should be constant across all passes. - , stateParseMsgs :: ParseMsgs Parse + stateMacroExpansions :: Set SingleLoc } + deriving (Generic) initParseState :: ParseState initParseState = ParseState{ - stateMacroExpansions = Set.empty - , stateNonParsedDecls = NonParsedDecls.empty - , stateParseMsgs = emptyParseMsgs + stateMacroExpansions = Set.empty } recordMacroExpansionAt :: SingleLoc -> ParseDecl () @@ -176,30 +151,6 @@ checkHasMacroExpansion extent = do , any (\e -> fromMaybe False (rangeContainsLoc range e)) expansions ] -recordNonParsedDecl :: C.DeclInfo Parse -> C.NameKind -> ParseDecl () -recordNonParsedDecl declInfo nameKind = - case declName of - Just cname -> do - let cQualName = C.QualName cname nameKind - sourcePath = singleLocPath (C.declLoc declInfo) - wrapEff $ \ParseSupport{parseState} -> - modifyIORef parseState $ \st -> st{ - stateNonParsedDecls = - NonParsedDecls.insert cQualName sourcePath $ - stateNonParsedDecls st - } - Nothing -> - -- We __do not track unselected anonymous declarations__. If we want to - -- use descriptive binding specification with anonymous declarations, we - -- __must__ select these declarations. - return () - where - declName :: Maybe C.Name - declName = case C.declId declInfo of - C.PrelimDeclIdNamed cname -> Just cname - C.PrelimDeclIdAnon{} -> Nothing - C.PrelimDeclIdBuiltin builtin -> Just builtin - {------------------------------------------------------------------------------- Logging -------------------------------------------------------------------------------} @@ -210,14 +161,6 @@ recordUnattachedTrace :: UnattachedParseMsg -> ParseDecl () recordUnattachedTrace trace = wrapEff $ \ParseSupport{parseEnv} -> traceWith (envTracer parseEnv) trace --- | Attach a delayed parse message to a declaration. We only emit the parse --- message when we select the declaration. -recordDelayedTrace :: C.DeclInfo Parse -> C.NameKind -> DelayedParseMsg -> ParseDecl () -recordDelayedTrace info kind trace = wrapEff $ \ParseSupport{parseState} -> - modifyIORef parseState $ \st -> st{ - stateParseMsgs = recordParseMsg info kind trace (stateParseMsgs st) - } - {------------------------------------------------------------------------------- Errors -------------------------------------------------------------------------------} diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs index 3df30301a..0367ed8e5 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Parse/IsPass.hs @@ -1,7 +1,5 @@ module HsBindgen.Frontend.Pass.Parse.IsPass ( Parse - , ParseDeclMeta(..) - , emptyParseDeclMeta -- * Typedefs , OrigTypedefRef(..) -- * Macros @@ -9,19 +7,26 @@ module HsBindgen.Frontend.Pass.Parse.IsPass ( , ReparseInfo(..) , getUnparsedMacro -- * Trace messages + , ParseSuccess(..) + , ParseNotAttemptedReason(..) + , ParseNotAttempted(..) + , ParseFailure(..) + , ParseResult(..) + , getDecl + , getQualPrelimDeclId + , parseSucceed + , parseSucceedWith + , parseDoNotAttempt + , parseFail + , parseFailWith , ParseTypeExceptionContext(..) , UnattachedParseMsg(..) + , AttachedParseMsg(..) , DelayedParseMsg(..) - , ParseMsgKey(..) - , ParseMsgs(..) - , emptyParseMsgs - , coerceParseMsgs - , mapParseMsgs - , recordParseMsg ) where -import Data.Map qualified as Map -import Text.SimplePrettyPrint (CtxDoc, (<+>), (><)) +import Data.List.NonEmpty qualified as NonEmpty +import Text.SimplePrettyPrint (CtxDoc, (<+>)) import Text.SimplePrettyPrint qualified as PP import Clang.Enum.Simple @@ -29,12 +34,10 @@ import Clang.HighLevel qualified as HighLevel import Clang.HighLevel.Types import Clang.LowLevel.Core -import HsBindgen.Frontend.AST.Coerce (CoercePass (..)) +import HsBindgen.Frontend.AST.Coerce import HsBindgen.Frontend.AST.Internal qualified as C -import HsBindgen.Frontend.Naming (NameKind) +import HsBindgen.Frontend.Naming (NameKind, QualPrelimDeclId) import HsBindgen.Frontend.Naming qualified as C -import HsBindgen.Frontend.NonParsedDecls (NonParsedDecls) -import HsBindgen.Frontend.NonParsedDecls qualified as NonParsedDecls import HsBindgen.Frontend.Pass import HsBindgen.Frontend.Pass.Parse.Type.Monad import HsBindgen.Imports @@ -48,7 +51,6 @@ type Parse :: Pass data Parse a deriving anyclass C.ValidPass type family AnnParse (ix :: Symbol) :: Star where - AnnParse "TranslationUnit" = ParseDeclMeta AnnParse "StructField" = ReparseInfo AnnParse "UnionField" = ReparseInfo AnnParse "Typedef" = ReparseInfo @@ -69,17 +71,122 @@ instance IsPass Parse where Information about the declarations -------------------------------------------------------------------------------} -data ParseDeclMeta = ParseDeclMeta { - parseDeclNonParsed :: NonParsedDecls - , parseDeclParseMsg :: ParseMsgs Parse +data ParseSuccess = ParseSuccess { + psDecl :: C.Decl Parse + , psAttachedMsgs :: [AttachedParseMsg] } - deriving stock (Show) + deriving stock (Show, Generic) + +-- | Why did we not attempt to parse a declaration? +data ParseNotAttemptedReason = + -- | We do not parse builtin declarations. + OmittedBuiltin + + -- | We unexpectedly excluded a declaration because it is reported + -- "unavailable". + | DeclarationUnavailable + + -- | Declarations that do not match the parse predicate. + -- + -- For example, we may provide external bindings for skipped declarations. + -- We do /not/ support external bindings for /anonymous/ non-parsed + -- declarations; /if/ you want to provide an external binding for some local + -- type, for example + -- + -- > struct rect { + -- > struct { int x; int y; } bottomleft; + -- > struct { int x; int y; } topright; + -- > }; + -- + -- then you need to make sure that you /traverse/ @rect@, so that the + -- @NameAnon@ pass can do its work. + | ParsePredicateNotMatched + deriving stock (Show, Eq, Ord) + +instance PrettyForTrace ParseNotAttemptedReason where + prettyForTrace = \case + OmittedBuiltin -> "Builtin declaration" + DeclarationUnavailable -> "Declaration is 'unavailable' on this platform" + ParsePredicateNotMatched -> "Parse predicate did not match" -emptyParseDeclMeta :: ParseDeclMeta -emptyParseDeclMeta = ParseDeclMeta { - parseDeclNonParsed = NonParsedDecls.empty - , parseDeclParseMsg = emptyParseMsgs +-- | Declarations we did not attempt to parse +-- +-- We need this information when selecting declarations: Does the user want to +-- select declarations we did not attempt to parse? +data ParseNotAttempted = ParseNotAttempted { + poQualPrelimDeclId :: QualPrelimDeclId + , poSingleLoc :: SingleLoc + , poAvailability :: C.Availability + , poParseNotAttemptedReason :: ParseNotAttemptedReason + } + deriving stock (Show, Generic) + +-- | Declarations that match the parse predicate but that we fail to parse and +-- reify +-- +-- We need this information when selecting declarations: Does the user want to +-- select declarations, we have failed to parse? +data ParseFailure = ParseFailure { + pfQualPrelimDeclId :: QualPrelimDeclId + , pfSingleLoc :: SingleLoc + , pfAvailability :: C.Availability + , pfDelayedParseMsgs :: NonEmpty AttachedParseMsg } + deriving stock (Show, Generic) + +data ParseResult = + ParseResultSuccess ParseSuccess + | ParseResultNotAttempted ParseNotAttempted + | ParseResultFailure ParseFailure + deriving stock (Show, Generic) + +getDecl :: ParseResult -> Either ParseResult (C.Decl Parse) +getDecl = \case + ParseResultSuccess ParseSuccess{..} -> Right psDecl + other -> Left other + +getQualPrelimDeclId :: ParseResult -> QualPrelimDeclId +getQualPrelimDeclId = \case + ParseResultSuccess ParseSuccess{..} -> C.declQualPrelimDeclId psDecl + ParseResultNotAttempted ParseNotAttempted{..} -> poQualPrelimDeclId + ParseResultFailure ParseFailure{..} -> pfQualPrelimDeclId + +parseSucceed :: C.Decl Parse -> ParseResult +parseSucceed = parseSucceedWith [] + +parseSucceedWith :: [DelayedParseMsg] -> C.Decl Parse -> ParseResult +parseSucceedWith msgs decl = + ParseResultSuccess $ ParseSuccess decl $ + map (AttachedParseMsg decl.declInfo) msgs + +parseDoNotAttempt :: + C.DeclInfo Parse + -> C.NameKind + -> ParseNotAttemptedReason + -> ParseResult +parseDoNotAttempt C.DeclInfo{..} kind reason = + ParseResultNotAttempted $ ParseNotAttempted + (C.qualPrelimDeclIdSafe declId kind) + declLoc + declAvailability + reason + +parseFail :: + C.DeclInfo Parse -> C.NameKind -> DelayedParseMsg -> ParseResult +parseFail info kind msg = parseFailWith info kind (NonEmpty.singleton msg) + +parseFailWith :: + HasCallStack + => C.DeclInfo Parse + -> C.NameKind + -> NonEmpty DelayedParseMsg + -> ParseResult +parseFailWith info@C.DeclInfo{..} kind msgs = + ParseResultFailure $ ParseFailure + (C.qualPrelimDeclId declId kind) + declLoc + declAvailability + (NonEmpty.map (AttachedParseMsg info) msgs) {------------------------------------------------------------------------------- Typedefs @@ -172,28 +279,15 @@ instance PrettyForTrace ParseTypeExceptionContext where -- If we can not attach messages to declarations, we emit them directly while -- parsing. data UnattachedParseMsg = - -- | We excluded a declaration. - ParseNotAttempted String (C.DeclInfo Parse) - - -- | We unepxectedly excluded a declaration (for example, because it is - -- reported "unavailable"). - | ParseNotAttemptedUnexpected String (C.DeclInfo Parse) - -- | Declaration availability can not be determined. -- -- That is 'Clang.LowLevel.Core.clang_getCursorAvailability' does not -- provide a valid 'Clang.LowLevel.Core.CXAvailabilityKind'. - | ParseUnknownCursorAvailability (C.DeclInfo Parse) (SimpleEnum CXAvailabilityKind) + ParseUnknownCursorAvailability (C.DeclInfo Parse) (SimpleEnum CXAvailabilityKind) deriving stock (Show) instance PrettyForTrace UnattachedParseMsg where prettyForTrace = \case - ParseNotAttempted reason info -> - withInfo info $ - "parse not attempted because:" <+> PP.string reason - ParseNotAttemptedUnexpected reason info -> - withInfo info $ - "parse unexpectedly not attempted because:" <+> PP.string reason ParseUnknownCursorAvailability info simpleKind -> withInfo info $ "unknown declaration availability:" <+> PP.showToCtxDoc simpleKind @@ -204,12 +298,21 @@ instance PrettyForTrace UnattachedParseMsg where instance IsTrace Level UnattachedParseMsg where getDefaultLogLevel = \case - ParseNotAttempted{} -> Info - ParseNotAttemptedUnexpected{} -> Notice ParseUnknownCursorAvailability{} -> Notice getSource = const HsBindgen getTraceId = const "parse-unattached" +data AttachedParseMsg = AttachedParseMsg (C.DeclInfo Parse) DelayedParseMsg + deriving stock (Show, Generic) + +instance PrettyForTrace AttachedParseMsg where + prettyForTrace (AttachedParseMsg i x) = prettyForTrace i <+> prettyForTrace x + +instance IsTrace Level AttachedParseMsg where + getDefaultLogLevel (AttachedParseMsg _ x) = getDefaultLogLevel x + getSource (AttachedParseMsg _ x) = getSource x + getTraceId (AttachedParseMsg _ x) = getTraceId x + -- | Delayed parse messages -- -- We emit these parse messages only when we attempt to select the attached @@ -337,7 +440,7 @@ data DelayedParseMsg = -- -- | ParseFunctionOfTypeTypedef - deriving stock (Show) + deriving stock (Show, Eq, Ord, Generic) instance PrettyForTrace DelayedParseMsg where prettyForTrace = \case @@ -355,13 +458,14 @@ instance PrettyForTrace DelayedParseMsg where "unsupported storage class" , PP.showToCtxDoc storage ] - ParsePotentialDuplicateSymbol isPublic -> PP.hsep $ [ - "Bindings may result in duplicate symbols;" - , "consider using 'static' or 'extern';" + ParsePotentialDuplicateSymbol isPublic -> PP.hcat $ [ + "Bindings may result in duplicate symbols; " + , "consider using 'static' or 'extern'" ] ++ if isPublic then [ - "or if that is not an option, consider attributing hidden" + "; " + , "or if that is not an option, consider attributing hidden " , "visibility to the symbol" ] else [] @@ -389,64 +493,3 @@ instance IsTrace Level DelayedParseMsg where ParseFunctionOfTypeTypedef{} -> Warning getSource = const HsBindgen getTraceId = const "parse-delayed" - -{------------------------------------------------------------------------------- - Location-specific parse messages --------------------------------------------------------------------------------} - --- | We emit parse traces only when we select the corresponding declaration. --- --- The 'ParseMsgKey' allows us to identify parse messages for selected and --- parsed/reified declarations, as well as for declarations we wanted to select --- but that were skipped during parse/reification. We call these latter --- declarations "failed declarations". -newtype ParseMsgs p = ParseMsgs { - unParseMsgs :: Map (ParseMsgKey p) [DelayedParseMsg] - } -deriving instance Show (Id p) => Show (ParseMsgs p) - -data ParseMsgKey p = ParseMsgKey { - parseMsgDeclLoc :: SingleLoc - , parseMsgDeclId :: Id p - , parseMsgDeclKind :: NameKind - , parseMsgDeclAvailability :: C.Availability - } -deriving stock instance Show (Id p) => Show (ParseMsgKey p) -deriving stock instance Eq (Id p) => Eq (ParseMsgKey p) -deriving stock instance Ord (Id p) => Ord (ParseMsgKey p) - -instance (Id p ~ Id p') => CoercePass ParseMsgKey p p' where - coercePass (ParseMsgKey l i k a) = ParseMsgKey l i k a - -instance PrettyForTrace (Id p) => PrettyForTrace (ParseMsgKey p) where - prettyForTrace ParseMsgKey{..} = PP.hsep [ - prettyForTrace parseMsgDeclKind - , prettyForTrace parseMsgDeclId - , "at" - , PP.showToCtxDoc parseMsgDeclLoc - , "(" >< prettyForTrace parseMsgDeclAvailability >< ")" - ] - -emptyParseMsgs :: ParseMsgs p -emptyParseMsgs = ParseMsgs $ Map.empty - -coerceParseMsgs :: (Id p ~ Id p', Ord (ParseMsgKey p')) - => ParseMsgs p -> ParseMsgs p' -coerceParseMsgs = ParseMsgs . Map.mapKeys coercePass . unParseMsgs - -mapParseMsgs :: Ord (ParseMsgKey p') - => (ParseMsgKey p -> ParseMsgKey p') - -> ParseMsgs p - -> ParseMsgs p' -mapParseMsgs f = ParseMsgs . Map.mapKeys f . unParseMsgs - -recordParseMsg :: forall p. Ord (ParseMsgKey p) - => C.DeclInfo p -> NameKind -> DelayedParseMsg -> ParseMsgs p -> ParseMsgs p -recordParseMsg info kind trace = - ParseMsgs . Map.alter (Just <$> add trace) key . unParseMsgs - where - key :: ParseMsgKey p - key = ParseMsgKey (C.declLoc info) (C.declId info) kind (C.declAvailability info) - - add x Nothing = [x] - add x (Just xs) = x:xs diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs index a504e315c..42a5ffedd 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedLabels #-} + module HsBindgen.Frontend.Pass.ResolveBindingSpecs ( resolveBindingSpecs ) where @@ -5,14 +7,18 @@ module HsBindgen.Frontend.Pass.ResolveBindingSpecs ( import Control.Monad ((<=<)) import Control.Monad.RWS (MonadReader, MonadState, RWS) import Control.Monad.RWS qualified as RWS +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Set qualified as Set +import Optics.Core ((&), (.~)) import Clang.HighLevel.Types import Clang.Paths import HsBindgen.BindingSpec (ExternalBindingSpec, PrescriptiveBindingSpec) import HsBindgen.BindingSpec qualified as BindingSpec +import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex) +import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph) import HsBindgen.Frontend.Analysis.IncludeGraph qualified as IncludeGraph import HsBindgen.Frontend.Analysis.UseDeclGraph (UseDeclGraph) @@ -20,13 +26,11 @@ import HsBindgen.Frontend.Analysis.UseDeclGraph qualified as UseDeclGraph import HsBindgen.Frontend.AST.Coerce import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C -import HsBindgen.Frontend.NonParsedDecls (NonParsedDecls) -import HsBindgen.Frontend.NonParsedDecls qualified as NonParsedDecls import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.NameAnon.IsPass -import HsBindgen.Frontend.Pass.Parse.IsPass (OrigTypedefRef (..)) +import HsBindgen.Frontend.Pass.Parse.IsPass import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass -import HsBindgen.Frontend.Pass.Sort.IsPass import HsBindgen.Imports import HsBindgen.Language.Haskell qualified as Hs import HsBindgen.Util.Monad (mapMaybeM) @@ -41,6 +45,7 @@ resolveBindingSpecs :: -> C.TranslationUnit NameAnon -> ( C.TranslationUnit ResolveBindingSpecs , Map C.QualName SourcePath + , Set C.QualName , [Msg ResolveBindingSpecs] ) resolveBindingSpecs @@ -52,12 +57,16 @@ resolveBindingSpecs extSpec pSpec unitIncludeGraph - (declUseDecl unitAnn) - (declNonParsed unitAnn) + unitAnn.declIndex + unitAnn.declUseDecl (resolveDecls unitDecls) notUsedErrs = ResolveBindingSpecsTypeNotUsed <$> Map.keys stateNoPTypes + declsWithExternalBindingSpecs :: Set C.QualName + declsWithExternalBindingSpecs = + Map.keysSet stateOmitTypes `Set.union` Map.keysSet stateExtTypes in ( reassemble decls stateUseDecl , stateOmitTypes + , declsWithExternalBindingSpecs , reverse stateErrors ++ notUsedErrs ) where @@ -65,10 +74,13 @@ resolveBindingSpecs [C.Decl ResolveBindingSpecs] -> UseDeclGraph -> C.TranslationUnit ResolveBindingSpecs - reassemble decls' useDeclGraph = C.TranslationUnit{ + reassemble decls' useDeclGraph = + let unitAnn' :: DeclMeta + unitAnn' = unitAnn & #declUseDecl .~ useDeclGraph + in C.TranslationUnit{ unitDecls = decls' , unitIncludeGraph - , unitAnn = coerceDeclMeta $ unitAnn { declUseDecl = useDeclGraph } + , unitAnn = unitAnn' } {------------------------------------------------------------------------------- @@ -88,12 +100,12 @@ runM :: ExternalBindingSpec -> PrescriptiveBindingSpec -> IncludeGraph + -> DeclIndex -> UseDeclGraph - -> NonParsedDecls -> M a -> (a, MState) -runM extSpec pSpec includeGraph useDeclGraph nonParsedDecls (WrapM m) = - let env = MEnv extSpec pSpec includeGraph nonParsedDecls +runM extSpec pSpec includeGraph declIndex useDeclGraph (WrapM m) = + let env = MEnv extSpec pSpec includeGraph declIndex state0 = initMState pSpec useDeclGraph (x, s, ()) = RWS.runRWS m env state0 in (x, s) @@ -106,7 +118,7 @@ data MEnv = MEnv { envExtSpec :: ExternalBindingSpec , envPSpec :: PrescriptiveBindingSpec , envIncludeGraph :: IncludeGraph - , envNonParsedDecls :: NonParsedDecls + , envDeclIndex :: DeclIndex } deriving (Show) @@ -426,26 +438,29 @@ instance Resolve C.Type where -> M (Set C.QualPrelimDeclId, C.Type ResolveBindingSpecs) aux mk cQualDeclId@C.QualDeclId{..} = RWS.ask >>= \MEnv{..} -> RWS.get >>= \MState{..} -> do - let cQualName = C.QualName qualDeclIdName qualDeclIdKind + let qualName = C.QualName qualDeclIdName qualDeclIdKind qualPrelimDeclId = C.qualDeclIdToQualPrelimDeclId cQualDeclId - -- check for type omitted by binding specification - when (Map.member cQualName stateOmitTypes) $ + -- Check for type omitted by binding specification + when (Map.member qualName stateOmitTypes) $ RWS.modify' $ - insertError (ResolveBindingSpecsOmittedTypeUse cQualName) - -- check for selected external binding - case Map.lookup cQualName stateExtTypes of + insertError (ResolveBindingSpecsOmittedTypeUse qualName) + -- Check for selected external binding + case Map.lookup qualName stateExtTypes of Just ty -> return (Set.singleton qualPrelimDeclId, ty) Nothing -> do - -- check for external binding of non-selected type - case NonParsedDecls.lookup cQualName envNonParsedDecls of - Nothing -> return (Set.empty, mk qualDeclIdName) - Just sourcePath -> do + -- Check for external binding of type that we omitted or failed to + -- parse. + case lookupMissing qualPrelimDeclId envDeclIndex of + [] -> return (Set.empty, mk qualDeclIdName) + locs -> do let declPaths = - IncludeGraph.reaches envIncludeGraph sourcePath - resolveExtBinding cQualName declPaths >>= \case + foldMap + (IncludeGraph.reaches envIncludeGraph . singleLocPath) + locs + resolveExtBinding qualName declPaths >>= \case Just resolved -> do let ty = C.TypeExtBinding resolved - RWS.modify' $ insertExtType cQualName ty + RWS.modify' $ insertExtType qualName ty return (Set.singleton qualPrelimDeclId, ty) Nothing -> return (Set.empty, mk qualDeclIdName) @@ -498,3 +513,13 @@ getHsExtRef cQualName cTypeSpec = do maybe (Left (ResolveBindingSpecsExtHsRefNoIdentifier cQualName)) Right $ BindingSpec.cTypeSpecIdentifier cTypeSpec return Hs.ExtRef{extRefModule, extRefIdentifier} + +-- For a given declaration ID, look up the source locations of "not attempted" +-- or "failed" parses. +lookupMissing :: C.QualPrelimDeclId -> DeclIndex -> [SingleLoc] +lookupMissing qualPrelimDeclId index = + (maybe [] (map poSingleLoc . NonEmpty.toList) $ + Map.lookup qualPrelimDeclId $ index.omitted) + ++ + (maybe [] (map pfSingleLoc . NonEmpty.toList) $ + Map.lookup qualPrelimDeclId $ index.failed) diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs/IsPass.hs index 303c86795..6a6ecd4aa 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/ResolveBindingSpecs/IsPass.hs @@ -10,8 +10,8 @@ import HsBindgen.BindingSpec qualified as BindingSpec import HsBindgen.Frontend.AST.Internal (CheckedMacro, ValidPass) import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass (DeclMeta) import HsBindgen.Frontend.Pass.Parse.IsPass (OrigTypedefRef) -import HsBindgen.Frontend.Pass.Sort.IsPass (DeclMeta) import HsBindgen.Imports import HsBindgen.Language.Haskell qualified as Hs import HsBindgen.Util.Tracer @@ -34,7 +34,7 @@ type ResolveBindingSpecs :: Pass data ResolveBindingSpecs a deriving anyclass (ValidPass) type family AnnResolveBindingSpecs ix where - AnnResolveBindingSpecs "TranslationUnit" = DeclMeta ResolveBindingSpecs + AnnResolveBindingSpecs "TranslationUnit" = DeclMeta AnnResolveBindingSpecs "Decl" = BindingSpec.CTypeSpec AnnResolveBindingSpecs _ = NoAnn diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs index 5c924012d..300d7a2ed 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select.hs @@ -2,270 +2,257 @@ module HsBindgen.Frontend.Pass.Select ( selectDecls ) where -import Data.List (partition) -import Data.Map qualified as Map +import Data.Foldable qualified as Foldable +import Data.List.NonEmpty qualified as NonEmpty import Data.Set qualified as Set import Clang.HighLevel.Types import HsBindgen.Errors (panicPure) -import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex) +import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex (..)) import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex -import HsBindgen.Frontend.Analysis.DeclUseGraph (DeclUseGraph) import HsBindgen.Frontend.Analysis.DeclUseGraph qualified as DeclUseGraph -import HsBindgen.Frontend.Analysis.UseDeclGraph (UseDeclGraph) import HsBindgen.Frontend.Analysis.UseDeclGraph qualified as UseDeclGraph import HsBindgen.Frontend.AST.Coerce (CoercePass (coercePass)) import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.Parse.IsPass import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass import HsBindgen.Frontend.Pass.Select.IsPass -import HsBindgen.Frontend.Pass.Sort.IsPass import HsBindgen.Frontend.Predicate import HsBindgen.Imports -import HsBindgen.Util.Tracer + +-- Identifier of a declaration. +type I = C.QualPrelimDeclId + +-- Declaration itself. +type D = C.Decl Select + +-- Match function to find selection roots. +type Match = I -> SingleLoc -> C.Availability -> Bool selectDecls :: IsMainHeader -> IsInMainHeaderDir + -> Set C.QualName -> Config Select -> C.TranslationUnit ResolveBindingSpecs -> (C.TranslationUnit Select, [Msg Select]) -selectDecls isMainHeader isInMainHeaderDir SelectConfig{..} unitRBS = - let matchedDecls, unmatchedDecls :: [C.Decl Select] - (matchedDecls, unmatchedDecls) = partition matchDecl decls - - selectedRoots :: [C.QualPrelimDeclId] - selectedRoots = map C.declOrigQualPrelimDeclId matchedDecls - - transitiveDeps :: Set C.QualPrelimDeclId - transitiveDeps = case selectConfigProgramSlicing of +selectDecls + isMainHeader + isInMainHeaderDir + declsWithExternalBindingSpecs + SelectConfig{..} + unit = + let -- Identifiers of selection roots. + rootIds :: Set I + rootIds = getSelectedRoots match index + + -- Identifiers of transitive dependencies (without roots), and all + -- selected declarations. + transIds, selIds :: Set I + (transIds, selIds) = case selectConfigProgramSlicing of DisableProgramSlicing -> - Set.empty + (Set.empty, rootIds) EnableProgramSlicing -> - UseDeclGraph.getTransitiveDeps useDeclGraph selectedRoots - - selectedDecls :: [C.Decl Select] - selectedDecls = case selectConfigProgramSlicing of - DisableProgramSlicing -> - matchedDecls - EnableProgramSlicing -> - -- NOTE: Careful, we need to maintain the order of declarations so - -- that children come before parents. 'filter' does that for us. - filter ((`Set.member` transitiveDeps) . C.declOrigQualPrelimDeclId) decls - - parseMsgs :: [Msg Select] - parseMsgs = getDelayedParseMsgs' selectedDecls - - selectMsgs :: [Msg Select] - unavailableTransitiveDeps :: Set C.QualPrelimDeclId - (selectMsgs, unavailableTransitiveDeps) = - getSelectMsgs selectedRoots transitiveDeps selectedDecls unmatchedDecls - - in if Set.null unavailableTransitiveDeps - then ( unitSelect { C.unitDecls = selectedDecls } - , parseMsgs ++ selectMsgs - ) - else panicPure $ errorMsgWith unavailableTransitiveDeps + let rootAndTransIds = + UseDeclGraph.getTransitiveDeps unit.unitAnn.declUseDecl $ + Set.toList rootIds + in (rootAndTransIds Set.\\ rootIds, rootAndTransIds) + + Acc { + selDs = selDeclsReversed + -- TODO: #1037. + , rIds = _unavailableRootIds + , tIds = _unavailableTransIds + , msgs = selectStatusMsgs + } = foldDecls rootIds transIds decls + + in ( unitSelectWith $ reverse selDeclsReversed + , selectStatusMsgs + -- TODO: #1037. + -- ++ toUnavailableMsgs unavailableRootIds + -- ++ toUnavailableMsgs unavailableTransIds + ++ getDelayedParseMsgs selIds index + ++ getParseNotAttemptedMsgs match hasExternalBindingSpec index + ++ getParseFailureMsgs match hasExternalBindingSpec index + ) where - errorMsgWith :: Set C.QualPrelimDeclId -> String - errorMsgWith xs = unlines $ - "Unavailable transitive dependencies: " - : map (show . prettyForTrace) (Set.toList xs) - ++ [ - "This is an indication that declarations have been removed after parse." - , "Please remove unsupported declarations in the parse pass, and not later!" - ] - - unitSelect :: C.TranslationUnit Select - unitSelect = - let C.TranslationUnit{..} = unitRBS - in C.TranslationUnit { - C.unitDecls = map coercePass unitDecls - , C.unitIncludeGraph = unitIncludeGraph - , C.unitAnn = SelectDeclMeta { - selectDeclIndex = declIndex unitAnn - , selectDeclUseDecl = declUseDecl unitAnn - , selectDeclDeclUse = declDeclUse unitAnn - , selectDeclNonParsed = declNonParsed unitAnn - } + decls :: [D] + decls = map coercePass unit.unitDecls + + hasExternalBindingSpec :: I -> Bool + hasExternalBindingSpec = \case + C.QualPrelimDeclIdNamed n k -> + Set.member (C.QualName n k) declsWithExternalBindingSpecs + _otherwise -> False + + -- TODO: #1037. + _toUnavailableMsgs :: Set I -> [Msg Select] + _toUnavailableMsgs = map SelectUnavailableDeclaration + . Set.toList + . Set.filter (not . hasExternalBindingSpec) + + index :: DeclIndex + index = unit.unitAnn.declIndex + + unitSelectWith :: [D] -> C.TranslationUnit Select + unitSelectWith xs = C.TranslationUnit { + C.unitDecls = xs + , C.unitIncludeGraph = unit.unitIncludeGraph + , C.unitAnn = unit.unitAnn } - decls :: [C.Decl Select] - decls = C.unitDecls unitSelect - - ann :: DeclMeta ResolveBindingSpecs - ann = C.unitAnn unitRBS - - useDeclGraph :: UseDeclGraph - useDeclGraph = declUseDecl ann - - matchDecl :: C.Decl Select -> Bool - matchDecl decl = isSelected $ - match - (C.declOrigQualPrelimDeclId decl) - (C.declLoc $ C.declInfo decl) - (C.declAvailability $ C.declInfo decl) - - match :: C.QualPrelimDeclId -> SingleLoc -> C.Availability -> SelectStatus + match :: Match match = \declId -> go declId declId where -- We compare the use sites of anonymous declarations with the original -- @declId@, so we can detect cycles involving anonymous declarations in -- the use-decl graph. We believe these cycles can not exist. - go originalDeclId declId loc availability = case declId of + go origDeclId declId loc availability = case declId of C.QualPrelimDeclIdNamed name kind -> - if matchSelect - isMainHeader - isInMainHeaderDir - (singleLocPath loc) - (C.QualName name kind) - availability - selectConfigPredicate - then Selected SelectionRoot - else NotSelected + matchSelect + isMainHeader + isInMainHeaderDir + (singleLocPath loc) + (C.QualName name kind) + availability + selectConfigPredicate -- Apply the select predicate to the use site. - anon@(C.QualPrelimDeclIdAnon{}) -> matchAnon anon + anon@(C.QualPrelimDeclIdAnon{}) -> matchAnon origDeclId anon -- Never select builtins. - C.QualPrelimDeclIdBuiltin _ -> NotSelected - where - declUseGraph :: DeclUseGraph - declUseGraph = declDeclUse (C.unitAnn unitRBS) - - index :: DeclIndex - index = declIndex (C.unitAnn unitRBS) - - matchAnon :: C.QualPrelimDeclId -> SelectStatus - matchAnon anon = - case DeclUseGraph.getUseSites declUseGraph anon of - [x] -> - matchUseSite $ fst x - [] -> - panicPure "anonymous declaration without use site" - xs -> - panicPure $ - "anonymous declaration with multiple use sites" ++ show xs - - matchUseSite :: C.QualPrelimDeclId -> SelectStatus - matchUseSite declIdUseSite - | declIdUseSite == originalDeclId = - panicPure $ - "unexpected cycle involving anonymous declaration: " - ++ show originalDeclId - | otherwise = - case DeclIndex.lookup declIdUseSite index of - Nothing -> panicPure "did not find declaration" - Just decl -> match - declIdUseSite - (C.declLoc $ C.declInfo decl) - (C.declAvailability $ C.declInfo decl) - - matchKey :: Key -> SelectStatus - matchKey (ParseMsgKey loc declId declKind declAvailability) = - let qualDeclId = C.QualDeclId { - qualDeclIdName = C.declIdName declId - , qualDeclIdOrigin = C.declIdOrigin declId - , qualDeclIdKind = declKind - } - in match (C.qualDeclIdToQualPrelimDeclId qualDeclId) loc declAvailability - - getDelayedParseMsgs' :: [C.Decl Select] -> [Msg Select] - getDelayedParseMsgs' = getDelayedParseMsgs ann matchKey + C.QualPrelimDeclIdBuiltin _ -> False + + matchAnon :: I -> I -> Bool + matchAnon origDeclId anon = + case DeclUseGraph.getUseSites unit.unitAnn.declDeclUse anon of + [(declId, _)] -> matchUseSite origDeclId declId + -- Unused anonymous declarations are removed in the @NameAnon@ + -- pass. Here we are using the decl-use graph to find use sites, + -- and so we still can encounter unused anonymous declarations. + [] -> False + xs -> panicPure $ + "anonymous declaration with multiple use sites: " + ++ show anon ++ " used by " ++ show xs + + matchUseSite :: I -> I -> Bool + matchUseSite origDeclId declIdUseSite + | declIdUseSite == origDeclId = panicPure $ + "unexpected cycle involving anonymous declaration: " + ++ show origDeclId + | otherwise = + case DeclIndex.lookup declIdUseSite index of + Nothing -> panicPure "did not find declaration" + Just decl -> match + declIdUseSite + (C.declLoc $ C.declInfo decl) + (C.declAvailability $ C.declInfo decl) {------------------------------------------------------------------------------- Trace messages -------------------------------------------------------------------------------} -getSelectMsgs - :: [C.QualPrelimDeclId] - -> Set C.QualPrelimDeclId - -> [C.Decl Select] - -> [C.Decl Select] - -> ([Msg Select], Set C.QualPrelimDeclId) -getSelectMsgs selectedRootsIds transitiveDeps selectedDecls unmatchedDecls = - (excludeMsgs ++ selectRootMsgs ++ selectTransMsgs, unavailableTransitiveDeps) +getSelectedRoots :: Match -> DeclIndex -> Set I +getSelectedRoots match index = Foldable.foldl' addMatch Set.empty index.succeeded where - unavailableTransitiveDeps :: Set C.QualPrelimDeclId - unavailableTransitiveDeps = - transitiveDeps `Set.difference` - (Set.fromList $ map C.declOrigQualPrelimDeclId selectedDecls) - - unselectedDecls :: [C.Decl Select] - unselectedDecls = - filter - ((`Set.notMember` transitiveDeps) . C.declOrigQualPrelimDeclId) - unmatchedDecls - - isRoot :: C.Decl Select -> Bool - isRoot x = Set.member (C.declOrigQualPrelimDeclId x) (Set.fromList selectedRootsIds) - - -- | Strict transitive dependencies are not selection roots. - selectedRoots, transitiveDepsStrict :: [C.Decl Select] - (selectedRoots, transitiveDepsStrict) = partition isRoot selectedDecls - - excludeMsgs, selectRootMsgs, selectTransMsgs :: [Msg Select] - excludeMsgs = - map (SelectSelectStatus NotSelected . C.declInfo) unselectedDecls - selectRootMsgs = - map (SelectSelectStatus (Selected SelectionRoot) . C.declInfo) selectedRoots - selectTransMsgs = - map (SelectSelectStatus (Selected TransitiveDependency) . C.declInfo) transitiveDepsStrict - -type Key = ParseMsgKey Select - -getDelayedParseMsgs :: - DeclMeta ResolveBindingSpecs - -> (ParseMsgKey Select -> SelectStatus) - -> [C.Decl Select] - -> [Msg Select] -getDelayedParseMsgs meta matchKey decls = - map (uncurry SelectParse) (flatten selectedMsgs) - ++ map (uncurry SelectFailed) (flatten failedMsgs) + addMatch :: Set I -> ParseSuccess -> Set I + addMatch xs (ParseSuccess decl _) = + let info = decl.declInfo + qualPrelimDeclId = C.declQualPrelimDeclId decl + isSelected = match qualPrelimDeclId info.declLoc info.declAvailability + in if isSelected then + Set.insert qualPrelimDeclId xs + else xs + +data Acc = Acc { + -- Selected declarations + selDs :: [D] + -- Identifiers of selection roots yet to be selected. Identifiers + -- remaining after the fold are unavailable and lead to error traces. + , rIds :: Set I + -- Identifiers of transitive dependencies yet to be selected. Identifiers + -- remaining after the fold are unavailable and lead to error traces. + , tIds :: Set I + -- @SelectSelectStatus@ trace messages. + , msgs :: [Msg Select] + } + +-- Traverse the declarations, partition them into selected and not-selected +-- declarations. Also return IDs that were _not_ found in the list of available +-- declarations. These declarations are _unvailable_, and lead to error traces. +foldDecls :: Set I -> Set I -> [D] -> Acc +foldDecls rootIds transIds decls = + Foldable.foldl' acc (Acc [] rootIds transIds []) decls where - msgs :: Map Key [DelayedParseMsg] - msgs = unParseMsgs $ coerceParseMsgs $ declParseMsgs meta - - allKeys :: Set Key - allKeys = Map.keysSet msgs - - declToKey :: C.Decl Select -> Key - declToKey C.Decl{declInfo, declKind} = - ParseMsgKey - (C.declLoc declInfo) - (C.declId declInfo) - (C.declKindNameKind declKind) - (C.declAvailability declInfo) - - selectedKeys :: Set Key - selectedKeys = Set.fromList $ map declToKey decls - - -- The set of desired selected keys is a super-set of the set of actually - -- selected keys, in which some keys may be missing because parsing has - -- failed. - desiredSelectedKeys :: Set Key - desiredSelectedKeys = Set.filter (isSelected . matchKey) allKeys - - -- Failed declarations are declarations we desired to select, but that we - -- failed to reify during parse/reification. See the documentation of - -- 'ParseMsgs'. - failedKeys :: Set Key - failedKeys = desiredSelectedKeys Set.\\ selectedKeys - - selectedMsgs :: Map Key [DelayedParseMsg] - selectedMsgs = Map.restrictKeys msgs selectedKeys - - failedMsgs :: Map Key [DelayedParseMsg] - failedMsgs = Map.restrictKeys msgs failedKeys - - flatten :: Map a [b] -> [(a, b)] - flatten = concatMap (\(k, xs) -> map (k,) xs) . Map.toList - -{------------------------------------------------------------------------------- - Helpers --------------------------------------------------------------------------------} + acc :: Acc -> D -> Acc + acc Acc{..} decl = + let declId = C.declOrigQualPrelimDeclId decl + in case ( deleteAndCheck declId rIds + , deleteAndCheck declId tIds ) of + -- Declaration is a selection root. + (Just rIds', Nothing) -> + Acc (decl:selDs) rIds' tIds + (getSelMsgs SelectionRoot decl ++ msgs) + -- Declaration is a transitive dependency. + (Nothing, Just tIds') -> + Acc (decl:selDs) rIds tIds' + (getSelMsgs TransitiveDependency decl ++ msgs) + -- Declaration is not selected. + (Nothing, Nothing) -> + Acc selDs rIds tIds + (getNotSelMsg decl : msgs) + -- Impossible :-), bug. + (Just _, Just _) -> + panicPure $ + "Declaration is selection root and transitive dependency: " + ++ show decl.declInfo + + -- Return @Just@ the new set if the element was deleted, otherwise return + -- @Nothing@. + deleteAndCheck :: Ord a => a -> Set a -> Maybe (Set a) + deleteAndCheck x xs = Set.alterF (\b -> if b then Just False else Nothing) x xs + + getSelMsgs :: SelectReason -> D -> [Msg Select] + getSelMsgs selectReason decl = + let info = decl.declInfo + selectDepr = [ SelectDeprecated info | isDeprecated info ] + in SelectSelectStatus (Selected selectReason) info : selectDepr + + isDeprecated :: C.DeclInfo Select -> Bool + isDeprecated info = case C.declAvailability info of + C.Deprecated -> True + _ -> False + + getNotSelMsg :: D -> Msg Select + getNotSelMsg decl = SelectSelectStatus NotSelected decl.declInfo + +getDelayedParseMsgs :: Set I -> DeclIndex -> [Msg Select] +getDelayedParseMsgs selIds index = concatMap getMsgs $ Set.toList selIds + where + getMsgs :: I -> [Msg Select] + getMsgs k = map SelectParseSuccess $ DeclIndex.lookupAttachedParseMsgs k index -isSelected :: SelectStatus -> Bool -isSelected NotSelected = False -isSelected (Selected _reason) = True +getParseNotAttemptedMsgs :: Match -> (I -> Bool) -> DeclIndex -> [Msg Select] +getParseNotAttemptedMsgs match hasExternalBindingSpec = + Foldable.foldl' (Foldable.foldl' addMsg) [] . omitted + where + addMsg :: [SelectMsg] -> ParseNotAttempted -> [SelectMsg] + addMsg xs (ParseNotAttempted i l a r) = + [ SelectParseNotAttempted i l r + | match i l a + , not $ hasExternalBindingSpec i + ] ++ xs + +getParseFailureMsgs :: Match -> (I -> Bool) -> DeclIndex -> [Msg Select] +getParseFailureMsgs match hasExternalBindingSpec = + Foldable.foldl' (Foldable.foldl' addMsg) [] . failed + where + addMsg :: [SelectMsg] -> ParseFailure -> [SelectMsg] + addMsg xs (ParseFailure i l a msgs) = + [ SelectParseFailure msg + | match i l a + , not $ hasExternalBindingSpec i + , msg <- NonEmpty.toList msgs + ] ++ xs diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs index 32bbf2860..23fa15331 100644 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs +++ b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Select/IsPass.hs @@ -1,6 +1,5 @@ module HsBindgen.Frontend.Pass.Select.IsPass ( Select - , SelectDeclMeta(..) -- * Configuration , ProgramSlicing(..) , SelectConfig(..) @@ -14,19 +13,17 @@ import Data.Default (Default (def)) import Text.SimplePrettyPrint (CtxDoc, (<+>), (><)) import Text.SimplePrettyPrint qualified as PP +import Clang.HighLevel.Types (SingleLoc) + import HsBindgen.BindingSpec qualified as BindingSpec -import HsBindgen.Frontend.Analysis.DeclIndex -import HsBindgen.Frontend.Analysis.DeclUseGraph -import HsBindgen.Frontend.Analysis.UseDeclGraph import HsBindgen.Frontend.AST.Coerce (CoercePass (coercePass)) import HsBindgen.Frontend.AST.Internal (CheckedMacro, ValidPass) import HsBindgen.Frontend.AST.Internal qualified as C import HsBindgen.Frontend.Naming qualified as C -import HsBindgen.Frontend.NonParsedDecls import HsBindgen.Frontend.Pass +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass import HsBindgen.Frontend.Pass.Parse.IsPass -import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass (ResolveBindingSpecs, - ResolvedExtBinding) +import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass import HsBindgen.Frontend.Predicate import HsBindgen.Util.Tracer @@ -38,7 +35,7 @@ type Select :: Pass data Select a deriving anyclass ValidPass type family AnnSelect ix where - AnnSelect "TranslationUnit" = SelectDeclMeta + AnnSelect "TranslationUnit" = DeclMeta AnnSelect "Decl" = BindingSpec.CTypeSpec AnnSelect _ = NoAnn @@ -54,21 +51,6 @@ instance IsPass Select where type Config Select = SelectConfig type Msg Select = SelectMsg -{------------------------------------------------------------------------------- - Information about the declarations --------------------------------------------------------------------------------} - --- TODO https://github.com/well-typed/hs-bindgen/issues/1038: Remove and thread --- through parse messages until the end. However, we have trouble mangling names --- due to (expected) missing declarations. -data SelectDeclMeta = SelectDeclMeta { - selectDeclIndex :: DeclIndex - , selectDeclUseDecl :: UseDeclGraph - , selectDeclDeclUse :: DeclUseGraph - , selectDeclNonParsed :: NonParsedDecls - } - deriving stock (Show) - {------------------------------------------------------------------------------- Configuration -------------------------------------------------------------------------------} @@ -105,7 +87,7 @@ data SelectReason = instance PrettyForTrace SelectReason where prettyForTrace = \case - SelectionRoot -> "selection root" + SelectionRoot -> "selection root; direct select predicate match" TransitiveDependency -> "transitive dependency" data SelectStatus = @@ -116,13 +98,18 @@ data SelectStatus = -- | Select trace messages data SelectMsg = SelectSelectStatus SelectStatus (C.DeclInfo Select) + | SelectUnavailableDeclaration C.QualPrelimDeclId + -- | Inform the user that they select a deprecated declaration. Maybe they + -- want to de-select deprecated declaration? + | SelectDeprecated (C.DeclInfo Select) -- | Delayed parse message for actually selected declarations. - | SelectParse (ParseMsgKey Select) DelayedParseMsg - -- | Delayed parse message for declarations that the user wanted to select, - -- but we failed to parse. - | SelectFailed (ParseMsgKey Select) DelayedParseMsg - -- TODO https://github.com/well-typed/hs-bindgen/issues/1037: Introduce - -- `SelectedButSkipped`. + | SelectParseSuccess AttachedParseMsg + -- | Delayred parse message for declarations the user wants to select, but + -- we have not attempted to parse. + | SelectParseNotAttempted C.QualPrelimDeclId SingleLoc ParseNotAttemptedReason + -- | Delayed parse message for declarations the user wants to select, but + -- we have failed to parse. + | SelectParseFailure AttachedParseMsg deriving stock (Show) instance PrettyForTrace SelectMsg where @@ -131,26 +118,47 @@ instance PrettyForTrace SelectMsg where prettyForTrace info >< " not selected" SelectSelectStatus (Selected reason) info -> prettyForTrace info >< " selected (" >< prettyForTrace reason >< ")" - SelectParse k x -> "During parse:" <+> prettyDelayedParseMsg k x - SelectFailed k x -> "Failed to select declaration declaration:" <+> prettyDelayedParseMsg k x + SelectUnavailableDeclaration i -> PP.vcat [ + prettyForTrace i >< " selected but unavailable" + , "This may be a bug and is an indication that declarations have been removed after parse." + ] + SelectDeprecated info -> PP.hcat [ + "Selected a deprecated declaration: " + , prettyForTrace info + , "; you may want to de-select it" + ] + SelectParseSuccess x -> + "During parse:" <+> prettyForTrace x + SelectParseNotAttempted n l r -> PP.vcat [ + "Failed to select declaration:" <+> prettyInfo n l + , "Parse not attempted:" <+> prettyForTrace r + ] + SelectParseFailure x -> + "Failed to select declaration; during parse:" <+> prettyForTrace x where - prettyDelayedParseMsg :: ParseMsgKey Select -> DelayedParseMsg -> CtxDoc - prettyDelayedParseMsg k v = PP.hcat [ - prettyForTrace k - , ":" - , prettyForTrace v - ] + prettyInfo :: C.QualPrelimDeclId -> SingleLoc -> CtxDoc + prettyInfo n l = PP.hsep [ + prettyForTrace n + , "at" + , PP.showToCtxDoc l + ] >< ":" instance IsTrace Level SelectMsg where getDefaultLogLevel = \case - SelectSelectStatus{} -> Info - SelectParse _ x -> getDefaultLogLevel x - SelectFailed _ x -> getDefaultLogLevel x + SelectSelectStatus{} -> Info + SelectUnavailableDeclaration{} -> Warning + SelectDeprecated{} -> Notice + SelectParseSuccess x -> getDefaultLogLevel x + SelectParseNotAttempted{} -> Warning + SelectParseFailure x -> getDefaultLogLevel x getSource = const HsBindgen getTraceId = \case - SelectParse _ x -> "select-parse-" <> getTraceId x - SelectFailed _ x -> "select-missed-" <> getTraceId x - _else -> "select" + SelectSelectStatus{} -> "select" + SelectUnavailableDeclaration{} -> "select" + SelectDeprecated{} -> "select" + SelectParseSuccess x -> "select-" <> getTraceId x + SelectParseNotAttempted{} -> "select-parse" + SelectParseFailure x -> "select-" <> getTraceId x {------------------------------------------------------------------------------- CoercePass diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Sort.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Sort.hs deleted file mode 100644 index 6cb87a607..000000000 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Sort.hs +++ /dev/null @@ -1,54 +0,0 @@ -module HsBindgen.Frontend.Pass.Sort ( - sortDecls - ) where - -import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex -import HsBindgen.Frontend.Analysis.DeclUseGraph qualified as DeclUseGraph -import HsBindgen.Frontend.Analysis.UseDeclGraph qualified as UseDeclGraph -import HsBindgen.Frontend.AST.Coerce -import HsBindgen.Frontend.AST.Internal qualified as C -import HsBindgen.Frontend.NonParsedDecls (NonParsedDecls) -import HsBindgen.Frontend.Pass -import HsBindgen.Frontend.Pass.Parse.IsPass -import HsBindgen.Frontend.Pass.Sort.IsPass - -{------------------------------------------------------------------------------- - Construction --------------------------------------------------------------------------------} - -sortDecls :: - C.TranslationUnit Parse - -> (C.TranslationUnit Sort, [Msg Sort]) -sortDecls unit@C.TranslationUnit{..} = - let (declMeta, declIndexErrors) = mkDeclMeta unit - in ( C.TranslationUnit{ - unitAnn = declMeta - , unitDecls = map coercePass $ - UseDeclGraph.toDecls - (declIndex declMeta) - (declUseDecl declMeta) - , .. - } - , declIndexErrors - ) - -mkDeclMeta :: C.TranslationUnit Parse -> (DeclMeta Sort, [Msg Sort]) -mkDeclMeta unit = - let (declIndex, declIndexErrors) = DeclIndex.fromDecls unitDecls - declUseDecl = UseDeclGraph.fromDecls unitIncludeGraph unitDecls - declDeclUse = DeclUseGraph.fromUseDecl declUseDecl - in ( DeclMeta{..} - , map SortErrorDeclIndex declIndexErrors - ) - where - C.TranslationUnit{ - unitDecls - , unitIncludeGraph - , unitAnn = parseUnitAnn - } = unit - - declNonParsed :: NonParsedDecls - declNonParsed = parseDeclNonParsed parseUnitAnn - - declParseMsgs :: ParseMsgs Sort - declParseMsgs = coerceParseMsgs $ parseDeclParseMsg parseUnitAnn diff --git a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Sort/IsPass.hs b/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Sort/IsPass.hs deleted file mode 100644 index bf9b44d11..000000000 --- a/hs-bindgen/src-internal/HsBindgen/Frontend/Pass/Sort/IsPass.hs +++ /dev/null @@ -1,82 +0,0 @@ -module HsBindgen.Frontend.Pass.Sort.IsPass ( - Sort - , DeclMeta(..) - , coerceDeclMeta - , SortMsg(..) - ) where - -import HsBindgen.Frontend.Analysis.DeclIndex -import HsBindgen.Frontend.Analysis.DeclUseGraph -import HsBindgen.Frontend.Analysis.UseDeclGraph -import HsBindgen.Frontend.AST.Coerce (CoercePass (..)) -import HsBindgen.Frontend.AST.Internal (ValidPass) -import HsBindgen.Frontend.Naming qualified as C -import HsBindgen.Frontend.NonParsedDecls -import HsBindgen.Frontend.Pass -import HsBindgen.Frontend.Pass.Parse.IsPass -import HsBindgen.Imports -import HsBindgen.Util.Tracer - -{------------------------------------------------------------------------------- - Definition - - The only thing that changes in this pass is the annotation on the top-level - 'TranslationUnit'; for everything else we simply refer to the 'Parse' pass. --------------------------------------------------------------------------------} - -type Sort :: Pass -data Sort a deriving anyclass ValidPass - -type family AnnSort (ix :: Symbol) :: Star where - AnnSort "TranslationUnit" = DeclMeta Sort - AnnSort "StructField" = ReparseInfo - AnnSort "UnionField" = ReparseInfo - AnnSort "Typedef" = ReparseInfo - AnnSort "Function" = ReparseInfo - AnnSort _ = NoAnn - -instance IsPass Sort where - type Id Sort = C.PrelimDeclId - type FieldName Sort = C.Name - type ArgumentName Sort = Maybe C.Name - type TypedefRef Sort = OrigTypedefRef Sort - type MacroBody Sort = UnparsedMacro - type ExtBinding Sort = Void - type Ann ix Sort = AnnSort ix - type Msg Sort = SortMsg - -{------------------------------------------------------------------------------- - Information about the declarations --------------------------------------------------------------------------------} - -data DeclMeta p = DeclMeta { - declIndex :: DeclIndex - , declUseDecl :: UseDeclGraph - , declDeclUse :: DeclUseGraph - , declNonParsed :: NonParsedDecls - , declParseMsgs :: ParseMsgs p - } - -deriving instance ValidPass p => Show (DeclMeta p) - -coerceDeclMeta :: forall p p'. (Id p ~ Id p', Ord (ParseMsgKey p')) - => DeclMeta p -> DeclMeta p' -coerceDeclMeta declMeta = declMeta { - declParseMsgs = coerceParseMsgs (declParseMsgs declMeta) - } - -{------------------------------------------------------------------------------- - Trace messages --------------------------------------------------------------------------------} - -data SortMsg = - SortErrorDeclIndex DeclIndexError - deriving stock (Show, Generic) - deriving anyclass (PrettyForTrace, IsTrace Level) - -{------------------------------------------------------------------------------- - CoercePass --------------------------------------------------------------------------------} - -instance CoercePass TypedefRefWrapper Parse Sort where - coercePass (TypedefRefWrapper p) = TypedefRefWrapper (coercePass p) diff --git a/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs b/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs index 432dedfbd..04e86b892 100644 --- a/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs +++ b/hs-bindgen/src-internal/HsBindgen/TraceMsg.hs @@ -22,7 +22,7 @@ module HsBindgen.TraceMsg ( , ResolveBindingSpecsMsg(..) , ResolveHeaderMsg(..) , SelectMsg(..) - , SortMsg(..) + , ConstructTranslationUnitMsg(..) , CExpr.DSL.MacroTcError(..) -- * Log level customization , CustomLogLevelSetting (..) @@ -40,6 +40,7 @@ import HsBindgen.Clang (ClangMsg (..)) import HsBindgen.Clang.BuiltinIncDir (BuiltinIncDirMsg (..)) import HsBindgen.Frontend (FrontendMsg (..)) import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndexError (..)) +import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass (ConstructTranslationUnitMsg (..)) import HsBindgen.Frontend.Pass.HandleMacros.IsPass (HandleMacrosMsg (..)) import HsBindgen.Frontend.Pass.HandleTypedefs.IsPass (HandleTypedefsMsg (..)) import HsBindgen.Frontend.Pass.MangleNames.IsPass (MangleNamesMsg (..)) @@ -49,7 +50,6 @@ import HsBindgen.Frontend.Pass.Parse.IsPass (DelayedParseMsg (..), import HsBindgen.Frontend.Pass.Parse.Type.Monad (ParseTypeException (..)) import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass (ResolveBindingSpecsMsg (..)) import HsBindgen.Frontend.Pass.Select.IsPass (SelectMsg (..)) -import HsBindgen.Frontend.Pass.Sort.IsPass (SortMsg (..)) import HsBindgen.Frontend.RootHeader (HashIncludeArgMsg (..)) import HsBindgen.Imports import HsBindgen.Resolve (ResolveHeaderMsg (..)) diff --git a/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs b/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs index c51bc7008..4f09bba9c 100644 --- a/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs +++ b/hs-bindgen/test/hs-bindgen/Test/HsBindgen/Golden.hs @@ -128,15 +128,15 @@ testCases = manualTestCases ++ [ -- , testTraceCustom "decls_in_signature" ["f3", "f4", "f5"] $ \case - TraceFrontend (FrontendSelect (SelectFailed key ParseUnexpectedAnonInSignature)) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i ParseUnexpectedAnonInSignature))) -> + Just $ expectFromDeclInfoParse i TraceFrontend (FrontendClang (ClangDiagnostic _diag)) -> Just Tolerated _otherwise -> Nothing , testTraceCustom "definitions" ["foo", "n"] $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i (ParsePotentialDuplicateSymbol{})))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing , let declsWithMsgs = [ @@ -148,20 +148,20 @@ testCases = manualTestCases ++ [ , "wam" ] in testTraceCustom "macro_in_fundecl" declsWithMsgs $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing , testTraceCustom "macro_in_fundecl_vs_typedef" ["quux1", "quux2", "wam1", "wam2"] $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing , testTraceCustom "redeclaration" ["x", "n"] $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static)))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static))))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing , let declsWithMsgs :: [C.QualPrelimDeclId] @@ -171,22 +171,22 @@ testCases = manualTestCases ++ [ , C.QualPrelimDeclIdNamed "stderr" C.NameKindOrdinary ] in testTraceCustom "macro_redefines_global" declsWithMsgs $ \case - TraceFrontend (FrontendSort (SortErrorDeclIndex (Redeclaration {redeclarationId = x}))) -> + TraceFrontend (FrontendConstructTranslationUnit (ConstructTranslationUnitErrorDeclIndex (Redeclaration {redeclarationId = x}))) -> Just $ Expected x _otherwise -> Nothing , testTraceCustom "skip_over_long_double" ["fun1", "struct1"] $ \case - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnsupportedType UnsupportedLongDouble))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnsupportedType UnsupportedLongDouble)))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing , testTraceCustom "tentative_definitions" ["i1", "i2", "i3", "i3"] $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectFailed key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static)))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static))))) -> + Just $ expectFromDeclInfoParse i TraceFrontend (FrontendClang (ClangDiagnostic Diagnostic {diagnosticOption = Just "-Wno-extern-initializer"})) -> Just Tolerated _otherwise -> @@ -219,13 +219,13 @@ testCases = manualTestCases ++ [ _otherwise -> Nothing , testTraceCustom "typedefs" ["foo"] $ \case - TraceFrontend (FrontendSelect (SelectFailed key ParseFunctionOfTypeTypedef)) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i ParseFunctionOfTypeTypedef))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing , testTraceCustom "varargs" ["f", "g"] $ \case - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnsupportedType UnsupportedVariadicFunction))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnsupportedType UnsupportedVariadicFunction)))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing , let declsWithWarnings = [ @@ -257,12 +257,12 @@ testCases = manualTestCases ++ [ (BNot (BIf (SelectDecl DeclDeprecated))) } , testTracePredicate = customTracePredicate' declsWithWarnings $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectParse key ParseNonPublicVisibility)) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static)))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParseNonPublicVisibility))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static))))) -> + Just $ expectFromDeclInfoParse i TraceFrontend (FrontendClang (ClangDiagnostic Diagnostic {diagnosticOption = Just "-Wno-extern-initializer"})) -> Just Tolerated _otherwise -> @@ -274,17 +274,17 @@ testCases = manualTestCases ++ [ -- , failingTestSimple "long_double" $ \case - TraceFrontend (FrontendSelect (SelectFailed _ (ParseUnsupportedType UnsupportedLongDouble))) -> + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg _ (ParseUnsupportedType UnsupportedLongDouble)))) -> Just $ Expected () _otherwise -> Nothing , failingTestSimple "implicit_fields_struct" $ \case - TraceFrontend (FrontendSelect (SelectFailed _ ParseUnsupportedImplicitFields)) -> + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg _ ParseUnsupportedImplicitFields))) -> Just $ Expected () _otherwise -> Nothing , failingTestSimple "implicit_fields_union" $ \case - TraceFrontend (FrontendSelect (SelectFailed _ ParseUnsupportedImplicitFields)) -> + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg _ ParseUnsupportedImplicitFields))) -> Just $ Expected () _otherwise -> Nothing @@ -294,7 +294,7 @@ testCases = manualTestCases ++ [ _otherwise -> Nothing , failingTestSimple "redeclaration_different" $ \case - TraceFrontend (FrontendSort (SortErrorDeclIndex (Redeclaration {}))) -> + TraceFrontend (FrontendConstructTranslationUnit (ConstructTranslationUnitErrorDeclIndex (Redeclaration {}))) -> Just (Expected ()) TraceFrontend (FrontendClang (ClangDiagnostic x)) -> if "macro redefined" `Text.isInfixOf` diagnosticSpelling x @@ -310,7 +310,7 @@ testCases = manualTestCases ++ [ _otherwise -> Nothing , failingTestSimple "unsupported_builtin" $ \case - TraceFrontend (FrontendSelect (SelectFailed _ (ParseUnsupportedType (UnsupportedBuiltin "__builtin_va_list")))) -> + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg _ (ParseUnsupportedType (UnsupportedBuiltin "__builtin_va_list"))))) -> Just $ Expected () _otherwise -> Nothing @@ -407,14 +407,14 @@ testCases = manualTestCases ++ [ in (defaultTest "array") { testClangVersion = Just (>= (19, 0, 0)) , testTracePredicate = customTracePredicate' declsWithWarnings $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i TraceFrontend (FrontendClang (ClangDiagnostic Diagnostic {diagnosticOption = Just "-Wno-extern-initializer"})) -> Just Tolerated TraceFrontend (FrontendClang (ClangDiagnostic Diagnostic {diagnosticOption = Just "-Wno-tentative-definition-array"})) -> Just Tolerated - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static)))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnknownStorageClass (unsafeFromSimpleEnum -> CX_SC_Static))))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing } @@ -434,10 +434,10 @@ testCases = manualTestCases ++ [ , "long_double_s" , "nested_long_double_s" ] $ \case - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnsupportedType UnsupportedLongDouble))) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnsupportedType UnsupportedVariadicFunction))) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnsupportedType UnsupportedLongDouble)))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnsupportedType UnsupportedVariadicFunction)))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing } @@ -456,13 +456,23 @@ testCases = manualTestCases ++ [ } , (defaultTest "fun_attributes") { testClangVersion = Just (>= (15, 0, 0)) - , testTracePredicate = customTracePredicate' ["my_printf", "i", "f3"] $ \case - TraceFrontend (FrontendSelect (SelectFailed key (ParseUnsupportedType UnsupportedVariadicFunction))) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectParse key ParseNonPublicVisibility)) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key + , testTracePredicate = customTracePredicate' [ + "my_printf" + , "i" + , "f3" + , "old_fn_deprecated" + , "old_fn_unavailable" + ] $ \case + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i (ParseUnsupportedType UnsupportedVariadicFunction)))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParseNonPublicVisibility))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectDeprecated i)) -> + Just $ expectFromDeclInfoSelect i + TraceFrontend (FrontendSelect (SelectParseNotAttempted n _ DeclarationUnavailable)) -> + Just $ expectFromQualPrelimDeclId n _otherwise -> Nothing , testRustBindgen = RustBindgenFail @@ -516,10 +526,10 @@ testCases = manualTestCases ++ [ -- different llvm version? For now we just disable it. testRustBindgen = RustBindgenIgnore , testTracePredicate = customTracePredicate' declsWithWarnings $ \case - TraceFrontend (FrontendSelect (SelectParse key (ParsePotentialDuplicateSymbol _isPublic))) -> - Just $ expectFromKey key - TraceFrontend (FrontendSelect (SelectFailed key ParseUnexpectedAnonInExtern)) -> - Just $ expectFromKey key + TraceFrontend (FrontendSelect (SelectParseSuccess (AttachedParseMsg i ParsePotentialDuplicateSymbol{}))) -> + Just $ expectFromDeclInfoParse i + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg i ParseUnexpectedAnonInExtern))) -> + Just $ expectFromDeclInfoParse i _otherwise -> Nothing } @@ -586,7 +596,7 @@ testCases = manualTestCases ++ [ ] TraceFrontend (FrontendSelect (SelectSelectStatus (Selected TransitiveDependency) info)) -> expectSelected info $ Set.singleton "FileOperationStatus" - TraceFrontend (FrontendSort (SortErrorDeclIndex (Redeclaration {redeclarationId = x}))) -> + TraceFrontend (FrontendConstructTranslationUnit (ConstructTranslationUnitErrorDeclIndex (Redeclaration {redeclarationId = x}))) -> Just $ Expected (show x) _otherwise -> Nothing @@ -597,13 +607,18 @@ testCases = manualTestCases ++ [ , (defaultFailingTest "thread_local"){ testClangVersion = Just (>= (16, 0, 0)) , testTracePredicate = singleTracePredicate $ \case - TraceFrontend (FrontendSelect (SelectFailed _ ParseUnsupportedTLS)) -> + TraceFrontend (FrontendSelect (SelectParseFailure (AttachedParseMsg _ ParseUnsupportedTLS))) -> Just $ Expected () _otherwise -> Nothing } , (defaultTest "type_attributes") { testRustBindgen = RustBindgenFail + , testTracePredicate = singleTracePredicate $ \case + TraceFrontend (FrontendSelect (SelectDeprecated _)) -> + Just $ Expected () + _otherwise -> + Nothing } ] where @@ -625,5 +640,17 @@ manualTestCases = [ , defaultTest "manual/function_pointers" ] -expectFromKey :: ParseMsgKey Select -> TraceExpectation Text -expectFromKey = Expected . C.getName . C.declIdName . parseMsgDeclId +expectFromQualPrelimDeclId :: C.QualPrelimDeclId -> TraceExpectation Text +expectFromQualPrelimDeclId = Expected . \case + C.QualPrelimDeclIdNamed n _ -> C.getName n + C.QualPrelimDeclIdAnon n _ -> Text.pack $ show n + C.QualPrelimDeclIdBuiltin n -> C.getName n + +expectFromDeclInfoParse :: C.DeclInfo Parse -> TraceExpectation Text +expectFromDeclInfoParse info = case info.declId of + C.PrelimDeclIdNamed n -> Expected $ C.getName n + C.PrelimDeclIdAnon _ -> Unexpected + C.PrelimDeclIdBuiltin n -> Expected $ C.getName n + +expectFromDeclInfoSelect :: C.DeclInfo Select -> TraceExpectation Text +expectFromDeclInfoSelect = Expected . C.getName . C.declIdName . C.declId