Revive TH tests

- Add a custom Diff implementation as I couldn't find similar already
  done

.github/workflows/simple.yml

@@ -15,7 +15,7 @@ jobs:
     strategy:
       matrix:
         os: [macos-latest, windows-latest]
-        ghc: ['9.2.8']
+        ghc: ['9.4.8']
       fail-fast: false
     timeout-minutes:
       60

hs-bindgen/fixtures/nested_types.th.txt

@@ -0,0 +1,13 @@
+instance Storable foo
+    where {sizeOf = \_ -> 8;
+           alignment = \_ -> 4;
+           peek = \x_0 -> (pure Mkfoo <*> peekByteOff x_0 0) <*> peekByteOff x_0 32;
+           poke = \x_1 -> \x_2 -> case x_2 of
+                                  {Mkfoo i_3
+                                         c_4 -> pokeByteOff x_1 0 i_3 >> pokeByteOff x_1 32 c_4}}
+instance Storable bar
+    where {sizeOf = \_ -> 16;
+           alignment = \_ -> 4;
+           peek = \x_0 -> pure Mkbar;
+           poke = \x_1 -> \x_2 -> case x_2 of
+                                  {Mkbar -> return ()}}

hs-bindgen/fixtures/primitive_types.th.txt

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

hs-bindgen/fixtures/simple_structs.th.txt

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

hs-bindgen/hs-bindgen.cabal

@@ -108,7 +108,7 @@ test-suite golden
   type:           exitcode-stdio-1.0
   main-is:        golden.hs
   hs-source-dirs: tests
-  other-modules:  Orphans
+  other-modules:  Orphans Diff TH
   build-depends:
       -- Internal dependencies
     , hs-bindgen
@@ -117,14 +117,20 @@ test-suite golden
       -- Inherited dependencies
     , containers
     , bytestring
+    , mtl
+    , template-haskell
   build-depends:
       -- External dependencies
-    , directory    ^>=1.3.6.2
-    , filepath     ^>=1.4.2.2 || ^>=1.5.2.0
-    , tasty        ^>=1.5
-    , tasty-golden ^>=2.3.5
-    , tasty-hunit  ^>=0.10.2
-    , tree-diff    ^>=0.3.1
+    , directory     ^>=1.3.6.2
+    , filepath      ^>=1.4.2.2 || ^>=1.5.2.0
+    , tasty         ^>=1.5
+    , tasty-golden  ^>=2.3.5
+    , tasty-hunit   ^>=0.10.2
+    , tree-diff     ^>=0.3.1
+    , syb           ^>=0.7.2.4
+    , vector        ^>=0.13.1.0
+    , ansi-terminal ^>=1.1.1
+    , utf8-string   ^>=1.0.2
 
 test-suite test-th
   import:         lang

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
       Unit_type            -> ''()
@@ -73,11 +74,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
@@ -91,5 +92,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/Hs/Syntax.hs

@@ -0,0 +1,9 @@
+module HsBindgen.Hs.Syntax where
+
+data Typ
+    = Typ String -- ^ ground type
+  deriving (Show, Generic)
+
+data Decl
+    = NewtypeDecl String Typ
+  deriving (Show, Generic)

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/Diff.hs

@@ -0,0 +1,193 @@
+-- | Colorful diff. Reasonably efficient, pretty colors.
+module Diff (ansiLinesDiff) where
+
+import Data.Maybe (mapMaybe)
+import Data.Vector qualified as V
+import System.Console.ANSI qualified as ANSI
+
+-------------------------------------------------------------------------------
+-- Utilities
+-------------------------------------------------------------------------------
+
+min3 :: Ord k => k -> k -> k -> k
+min3 x y z = min x (min y z)
+
+pick3 :: Ord k => k -> a -> k -> a -> k -> a -> a
+pick3 a x b y c z =
+    if a < b
+    then (if a < c then x else z)
+    else (if b < c then y else z)
+
+-------------------------------------------------------------------------------
+-- Generic diff
+-------------------------------------------------------------------------------
+
+data Diff a b d
+    = End
+    | Same [a] [b] (Diff a b d)
+    | Diff [a] [b] [d] (Diff a b d)
+  deriving Show
+
+consS :: a -> b -> Diff a b d -> Diff a b d
+consS x y (Same xs ys df) = Same (x : xs) (y : ys) df
+consS x y df              = Same [x] [y] df
+
+consR :: b -> d -> Diff a b d -> Diff a b d
+consR y d (Diff xs ys ds df) = Diff xs (y : ys) (d : ds) df
+consR y d df                 = Diff [] [y] [d] df
+
+consL :: a -> d -> Diff a b d -> Diff a b d
+consL x d (Diff xs ys ds df) = Diff (x : xs) ys (d : ds) df
+consL x d df                 = Diff [x] [] [d] df
+
+consD :: a -> b -> d -> Diff a b d -> Diff a b d
+consD x y d (Diff xs ys ds df) = Diff (x : xs) (y : ys) (d : ds) df
+consD x y d df                 = Diff [x] [y] [d] df
+
+genericDiff :: forall a b d. (a -> b -> (Double, d))
+     -> (a -> d)
+     -> (b -> d)
+     -> [a]
+     -> [b]
+     -> (Double, Diff a b d)
+genericDiff cmp_ inl inr xs_ ys_ = (distance, walk 0 0)
+  where
+    distance = if dist 0 0 == 0 then 0 else dist 0 0 / fromIntegral (max xn yn)
+
+    xs :: V.Vector a
+    xs = V.fromList xs_
+
+    ys :: V.Vector b
+    ys = V.fromList ys_
+
+    xn = V.length xs
+    yn = V.length ys
+
+    cmp :: Int -> Int -> (Double, d)
+    cmp !i !j = comparisons V.! (j + i * yn)
+
+    comparisons :: V.Vector (Double, d)
+    comparisons = V.generate (xn * yn) aux
+      where
+        aux ij = cmp_ xc yc
+          where
+            (i, j) = ij `divMod` yn
+            xc = xs V.! i
+            yc = ys V.! j
+
+    dist :: Int -> Int -> Double
+    dist !i !j = distances V.! (j + i * (yn + 1))
+
+    distances :: V.Vector Double
+    distances = V.generate ((xn + 1) * (yn + 1)) $ \ij -> case ij `divMod` (yn + 1) of
+        (i, j)
+            | i == xn, j == yn
+            -> 0
+
+            | i == xn
+            -> 1 + dist i (j + 1)
+
+            | j == yn
+            -> 1 + dist (i + 1) j
+
+            | otherwise
+            , let (r, _) = cmp i j
+            -> if r == 0
+               then dist (i + 1) (j + 1)
+               else min3 (r + dist i       (j + 1))
+                         (r + dist (i + 1) j)
+                         (r + dist (i + 1) (j + 1))
+
+    walk :: Int -> Int -> Diff a b d
+    walk !i !j
+        | i == xn, j == yn
+        = End
+
+        | i == xn
+        = consR yc (inr yc) (walk i (j + 1))
+
+        | j == yn
+        = consL xc (inl xc) (walk (i + 1) j)
+
+        | otherwise
+        , let (r, d) = cmp i j
+        = if r == 0
+          then consS xc yc (walk (i + 1) (j + 1))
+          else pick3 (dist i       (j + 1)) (consR yc    (inr yc) (walk i       (j + 1)))
+                     (dist (i + 1) j)       (consL xc    (inl xc) (walk (i + 1) j))
+                     (dist (i + 1) (j + 1)) (consD xc yc d        (walk (i + 1) (j + 1)))
+      where
+        xc = xs V.! i
+        yc = ys V.! j
+
+-------------------------------------------------------------------------------
+-- ANSI helpers
+-------------------------------------------------------------------------------
+
+ansiRed :: String
+ansiRed = ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]
+
+ansiGreen :: String
+ansiGreen = ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green]
+
+ansiReset :: String
+ansiReset = ANSI.setSGRCode [ANSI.Reset]
+
+-------------------------------------------------------------------------------
+-- Lines diff
+-------------------------------------------------------------------------------
+
+-- | Lines diff, where each line is also diffed to show in line additions/removals
+linesDiff :: [String] -> [String] -> (Double, Diff String String (Either (Either String String) (Diff Char Char ())))
+linesDiff xss yss = fullDiff
+  where
+    fullDiff = genericDiff
+        (\xs ys -> let (r, d) = lineDiff xs ys in (r, Right d))
+        (Left . Left)
+        (Left . Right)
+        xss
+        yss
+
+    lineDiff :: String -> String -> (Double, Diff Char Char ())
+    lineDiff = genericDiff
+        (\x y -> (if x == y then 0 else 1, ()))
+        (\_ -> ())
+        (\_ -> ())
+
+ansiLinesDiff :: [String] -> [String] -> [String]
+ansiLinesDiff xss yss = ansify (snd (linesDiff xss yss))
+
+ansify :: Diff String String (Either (Either String String) (Diff Char Char ())) -> [String]
+ansify End = []
+ansify (Same xs _ df) =
+    map noChange xs ++
+    ansify df
+  where
+    noChange s = ansiReset ++ " " ++ s
+ansify (Diff _xs _ys ds df) =
+    mapMaybe removed_ ds ++
+    mapMaybe added_ ds ++
+    ansify df
+  where
+    removed s = ansiRed   ++ "-" ++ s ++ ansiReset
+    added   s = ansiGreen ++ "+" ++ s ++ ansiReset
+
+    removed_ :: Either (Either String String) (Diff Char Char ()) -> Maybe String
+    removed_ (Left (Left s))  = Just $ removed s
+    removed_ (Left (Right _)) = Nothing
+    removed_ (Right d)        = Just $ ansiRed ++ "-" ++ ansiReset ++ removedLine d
+
+    added_ :: Either (Either String String) (Diff Char Char ()) -> Maybe String
+    added_ (Left (Right s)) = Just $ added s
+    added_ (Left (Left _))  = Nothing
+    added_ (Right d)        = Just $ ansiGreen ++ "+" ++ ansiReset ++ addedLine d
+
+removedLine :: Diff Char Char () -> String
+removedLine End = ansiReset
+removedLine (Same xs _ df)   = ansiRed ++ xs ++ ansiReset ++ removedLine df
+removedLine (Diff xs _ _ df) = ANSI.setSGRCode [ANSI.SetColor ANSI.Background ANSI.Dull ANSI.Red] ++ xs ++ ansiReset ++ removedLine df
+
+addedLine :: Diff Char Char () -> String
+addedLine End = ansiReset
+addedLine (Same _ ys df)   = ansiGreen ++ ys ++ ansiReset ++ addedLine df
+addedLine (Diff _ ys _ df) = ANSI.setSGRCode [ANSI.SetColor ANSI.Background ANSI.Dull ANSI.Green] ++ ys ++ ansiReset ++ addedLine df