Revive TH tests

hs-bindgen/fixtures/primitive_types.th.txt

@@ -0,0 +1,10 @@
+instance Foreign.Storable.Storable primitive
+    where {Foreign.Storable.sizeOf = \_ -> 176;
+           Foreign.Storable.alignment = \_ -> 16;
+           Foreign.Storable.peek = \x_0 -> ((((GHC.Base.pure Mkprimitive GHC.Base.<*> Foreign.Storable.peekByteOff x_0 0) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 128) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 160) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 192) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 1088;
+           Foreign.Storable.poke = \x_1 -> \x_2 -> case x_2 of
+                                                   {Mkprimitive c_3
+                                                                i_4
+                                                                s2_5
+                                                                si2_6
+                                                                f_7 -> (((Foreign.Storable.pokeByteOff x_1 0 c_3 GHC.Base.>> Foreign.Storable.pokeByteOff x_1 128 i_4) GHC.Base.>> Foreign.Storable.pokeByteOff x_1 160 s2_5) GHC.Base.>> Foreign.Storable.pokeByteOff x_1 192 si2_6) GHC.Base.>> Foreign.Storable.pokeByteOff x_1 1088 f_7}}

hs-bindgen/fixtures/simple_structs.th.txt

@@ -0,0 +1,28 @@
+instance Foreign.Storable.Storable S1
+    where {Foreign.Storable.sizeOf = \_ -> 8;
+           Foreign.Storable.alignment = \_ -> 4;
+           Foreign.Storable.peek = \x_0 -> (GHC.Base.pure MkS1 GHC.Base.<*> Foreign.Storable.peekByteOff x_0 0) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 32;
+           Foreign.Storable.poke = \x_1 -> \x_2 -> case x_2 of
+                                                   {MkS1 a_3
+                                                         b_4 -> Foreign.Storable.pokeByteOff x_1 0 a_3 GHC.Base.>> Foreign.Storable.pokeByteOff x_1 32 b_4}}
+instance Foreign.Storable.Storable S2
+    where {Foreign.Storable.sizeOf = \_ -> 12;
+           Foreign.Storable.alignment = \_ -> 4;
+           Foreign.Storable.peek = \x_0 -> ((GHC.Base.pure MkS2 GHC.Base.<*> Foreign.Storable.peekByteOff x_0 0) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 32) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 64;
+           Foreign.Storable.poke = \x_1 -> \x_2 -> case x_2 of
+                                                   {MkS2 a_3
+                                                         b_4
+                                                         c_5 -> (Foreign.Storable.pokeByteOff x_1 0 a_3 GHC.Base.>> Foreign.Storable.pokeByteOff x_1 32 b_4) GHC.Base.>> Foreign.Storable.pokeByteOff x_1 64 c_5}}
+instance Foreign.Storable.Storable X
+    where {Foreign.Storable.sizeOf = \_ -> 1;
+           Foreign.Storable.alignment = \_ -> 1;
+           Foreign.Storable.peek = \x_0 -> GHC.Base.pure MkX GHC.Base.<*> Foreign.Storable.peekByteOff x_0 0;
+           Foreign.Storable.poke = \x_1 -> \x_2 -> case x_2 of
+                                                   {MkX a_3 -> Foreign.Storable.pokeByteOff x_1 0 a_3}}
+instance Foreign.Storable.Storable S4
+    where {Foreign.Storable.sizeOf = \_ -> 8;
+           Foreign.Storable.alignment = \_ -> 4;
+           Foreign.Storable.peek = \x_0 -> (GHC.Base.pure MkS4 GHC.Base.<*> Foreign.Storable.peekByteOff x_0 0) GHC.Base.<*> Foreign.Storable.peekByteOff x_0 32;
+           Foreign.Storable.poke = \x_1 -> \x_2 -> case x_2 of
+                                                   {MkS4 b_3
+                                                         a_4 -> Foreign.Storable.pokeByteOff x_1 0 b_3 GHC.Base.>> Foreign.Storable.pokeByteOff x_1 32 a_4}}

hs-bindgen/hs-bindgen.cabal

@@ -117,6 +117,8 @@ test-suite golden
       -- Inherited dependencies
     , containers
     , bytestring
+    , mtl
+    , template-haskell
   build-depends:
       -- External dependencies
     , directory    ^>=1.3.6.2

hs-bindgen/src/HsBindgen/Backend/TH.hs

@@ -7,7 +7,7 @@ module HsBindgen.Backend.TH (
   ) where
 
 import Foreign.Storable qualified
-import Language.Haskell.TH (Q)
+import Data.Kind (Type)
 import Language.Haskell.TH qualified as TH
 
 import HsBindgen.Backend.Common
@@ -16,12 +16,13 @@ import HsBindgen.Backend.Common
   Backend definition
 -------------------------------------------------------------------------------}
 
-data BE = BE
+type BE :: (Type -> Type) -> Type
+data BE q = BE
 
-instance BackendRep BE where
-  type Name BE = TH.Name
-  type Expr BE = TH.ExpQ
-  type Decl BE = TH.DecQ
+instance TH.Quote q => BackendRep (BE q) where
+  type Name (BE q) = TH.Name
+  type Expr (BE q) = q TH.Exp
+  type Decl (BE q) = q TH.Dec
 
   resolve _ =  \case
       Applicative_pure     -> 'pure
@@ -70,11 +71,11 @@ instance BackendRep BE where
                         instanceDecs i
                     )
     where
-      simpleDecl :: TH.Name -> SExpr BE -> TH.DecQ
+      simpleDecl :: TH.Name -> SExpr (BE q) -> q TH.Dec
       simpleDecl x f = TH.valD (TH.varP x) (TH.normalB $ mkExpr be f) []
 
-instance Backend BE where
-  newtype M BE a = Gen { unwrapGen :: Q a }
+instance TH.Quote q => Backend (BE q) where
+  newtype M (BE q) a = Gen { unwrapGen :: q a }
     deriving newtype (
         Functor
       , Applicative
@@ -88,5 +89,5 @@ instance Backend BE where
   Monad functionality
 -------------------------------------------------------------------------------}
 
-runM :: M BE a -> Q a
+runM :: M (BE q) a -> q a
 runM = unwrapGen

hs-bindgen/src/HsBindgen/Backend/TH/Translation.hs

@@ -3,7 +3,6 @@ module HsBindgen.Backend.TH.Translation (
   , translateHs
   ) where
 
-import Language.Haskell.TH (Q)
 import Language.Haskell.TH qualified as TH
 
 import HsBindgen.Backend.Common
@@ -17,13 +16,13 @@ import HsBindgen.Translation.LowLevel
   Generate list of declarations for splicing
 -------------------------------------------------------------------------------}
 
-translateC :: C.Header -> TH.DecsQ
+translateC :: TH.Quote q => C.Header -> q [TH.Dec]
 translateC = translateHs . generateDeclarations
 
-translateHs :: [Hs.Decl (Fresh BE)] -> TH.DecsQ
+translateHs :: forall q. TH.Quote q => [Hs.Decl (Fresh (BE q))] -> q [TH.Dec]
 translateHs =
     aux . runM . mapM (toBE BE)
   where
-    aux :: Q [TH.DecQ] -> TH.DecsQ
+    aux :: q ([q TH.Dec]) -> q [TH.Dec]
     aux = (>>= sequence)
 

hs-bindgen/src/HsBindgen/Lib.hs

@@ -119,7 +119,7 @@ parseCHeader tracer p args fp =
 genModule :: HsModuleOpts -> CHeader -> HsModule
 genModule opts = WrapHsModule . Backend.E.translate opts . unwrapCHeader
 
-genDecls :: CHeader -> TH.DecsQ
+genDecls :: TH.Quote q => CHeader -> q [TH.Dec]
 genDecls = Backend.TH.translateC . unwrapCHeader
 
 {-------------------------------------------------------------------------------

hs-bindgen/tests/golden.hs

@@ -10,6 +10,9 @@ import Test.Tasty (defaultMain, testGroup)
 import Test.Tasty.Golden (goldenVsStringDiff)
 import Test.Tasty.Golden.Advanced (goldenTest)
 import Test.Tasty.HUnit (testCase, (@?=))
+import Language.Haskell.TH qualified as TH
+import Language.Haskell.TH.Syntax qualified as TH
+import Control.Monad.State.Strict (State, get, put, evalState)
 
 import Orphans ()
 
@@ -45,6 +48,7 @@ main = do
         [ goldenDump name
         , goldenTreeDiff name
         , goldenHs name
+        , goldenTh name
         ]
 
     goldenDump name = goldenVsStringDiff "ast" diff ("fixtures" </> (name ++ ".dump.txt")) $ do
@@ -76,6 +80,18 @@ main = do
 
         return $ LBS8.pack $ showClosed decls
 
+    goldenTh name = goldenVsStringDiff "th" diff ("fixtures" </> (name ++ ".th.txt")) $ do
+        -- -<.> does weird stuff for filenames with multiple dots;
+        -- I usually simply avoid using it.
+        let fp = "examples" </> (name ++ ".h")
+            args = ["-target", "x86_64-pc-linux-gnu"]
+
+        header <- parseCHeader nullTracer SelectFromMainFile args fp
+        let decls :: Qu [TH.Dec]
+            decls = genDecls header
+
+        return $ LBS8.pack $ unlines $ map (show . TH.ppr) $ runQu decls
+
 treeToLines :: Tree Element -> [String]
 treeToLines tree = go 0 tree [] where
     go :: Int -> Tree Element -> [String] -> [String]
@@ -110,3 +126,15 @@ findPackageDirectory pkgname = do
         then setCurrentDirectory pkgname
         -- do not try too hard, if not in the package directory, nor project root: abort
         else fail $ "Cannot find package directory for " ++ pkgname
+
+newtype Qu a = Qu (State Integer a)
+  deriving newtype (Functor, Applicative, Monad)
+
+instance TH.Quote Qu where
+    newName n = Qu $ do
+        u <- get
+        put $! u + 1
+        return $ TH.Name (TH.OccName n) (TH.NameU u)
+
+runQu :: Qu a -> a
+runQu (Qu m) = evalState m 0