From 3f441d026b39d6b2c4587cb30892a9153778cb78 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Mon, 1 Aug 2022 09:57:44 +0200
Subject: [PATCH] Add conversion functions for waylands `fixed` type

---
 quasar-wayland.cabal                |  8 ++--
 src/Quasar/Wayland/Protocol.hs      |  2 +
 src/Quasar/Wayland/Protocol/Core.hs | 16 +++++--
 test/Quasar/Wayland/WlFixedSpec.hs  | 71 +++++++++++++++++++++++++++++
 4 files changed, 90 insertions(+), 7 deletions(-)
 create mode 100644 test/Quasar/Wayland/WlFixedSpec.hs

diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index a504901..4a01433 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -126,11 +126,13 @@ test-suite quasar-wayland-test
   type: exitcode-stdio-1.0
   build-depends:
     base,
-    --QuickCheck,
     hspec,
-    --quasar-wayland,
+    inline-c,
+    quasar,
+    quasar-wayland,
+    QuickCheck,
   main-is: Spec.hs
   other-modules:
-    --Quasar.TemplateSpec
+    Quasar.Wayland.WlFixedSpec
   hs-source-dirs:
     test
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
index 002f22a..1d22016 100644
--- a/src/Quasar/Wayland/Protocol.hs
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -11,6 +11,8 @@ module Quasar.Wayland.Protocol (
 
   -- ** Wayland types
   WlFixed(..),
+  fixedToDouble,
+  doubleToFixed,
   WlString(..),
   toString,
 
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 60940c7..bc56fa3 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -7,6 +7,8 @@ module Quasar.Wayland.Protocol.Core (
   GenericNewId,
   Opcode,
   WlFixed(..),
+  fixedToDouble,
+  doubleToFixed,
   WlString(..),
   toString,
   fromString,
@@ -115,11 +117,17 @@ data GenericNewId = GenericNewId WlString Version Word32
 
 
 -- | Signed 24.8 decimal numbers.
-newtype WlFixed = WlFixed Word32
+newtype WlFixed = WlFixed Int32
   deriving newtype Eq
 
 instance Show WlFixed where
-  show x = "[fixed " <> show x <> "]"
+  show (WlFixed x) = "[fixed " <> show x <> "]"
+
+fixedToDouble :: WlFixed -> Double
+fixedToDouble (WlFixed f) = fromIntegral f / 256
+
+doubleToFixed :: Double -> WlFixed
+doubleToFixed d = WlFixed (round (d * 256))
 
 
 -- | A string. The encoding is not officially specified, but in practice UTF-8 is used.
@@ -163,8 +171,8 @@ instance WireFormat Word32 where
   showArgument = show
 
 instance WireFormat WlFixed where
-  putArgument (WlFixed repr) = pure $ MessagePart (putWord32host repr) 4 mempty
-  getArgument = pure . WlFixed <$> getWord32host
+  putArgument (WlFixed repr) = pure $ MessagePart (putInt32host repr) 4 mempty
+  getArgument = pure . WlFixed <$> getInt32host
   showArgument = show
 
 instance WireFormat WlString where
diff --git a/test/Quasar/Wayland/WlFixedSpec.hs b/test/Quasar/Wayland/WlFixedSpec.hs
new file mode 100644
index 0000000..ce257dd
--- /dev/null
+++ b/test/Quasar/Wayland/WlFixedSpec.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Quasar.Wayland.WlFixedSpec (spec) where
+
+import Foreign.C.Types
+import Language.C.Inline qualified as C
+import Language.C.Inline.Unsafe qualified as CU
+import Quasar.Prelude
+import Quasar.Wayland.Protocol (WlFixed(..), fixedToDouble, doubleToFixed)
+import System.IO.Unsafe (unsafeDupablePerformIO)
+import Test.Hspec
+import Test.QuickCheck
+
+
+deriving newtype instance Arbitrary WlFixed
+
+C.include "<stdint.h>"
+
+-- Libwayland implementation wl_fixed_to_double
+-- https://github.com/wayland-project/wayland/blob/5e4253ed50cfc9a132b5231f68a7084e0c3dc417/src/wayland-util.h#L596-L644
+libwaylandFixedToDouble :: WlFixed -> Double
+libwaylandFixedToDouble (WlFixed value) = unsafeDupablePerformIO do
+  CDouble result <- [CU.block|
+    double {
+      union {
+        double d;
+        int64_t i;
+      } u;
+
+      u.i = ((1023LL + 44LL) << 52) + (1LL << 51) + $(int32_t value);
+
+      return u.d - (3LL << 43);
+    }
+  |]
+  pure result
+
+-- Libwayland implementation wl_fixed_from_double
+-- https://github.com/wayland-project/wayland/blob/5e4253ed50cfc9a132b5231f68a7084e0c3dc417/src/wayland-util.h#L596-L644
+libwaylandDoubleToFixed :: Double -> WlFixed
+libwaylandDoubleToFixed (CDouble -> value) = WlFixed $ unsafeDupablePerformIO
+  [CU.block|
+    int32_t {
+      union {
+        double d;
+        int64_t i;
+      } u;
+
+      u.d = $(double value) + (3LL << (51 - 8));
+
+      return (int32_t)u.i;
+    }
+  |]
+
+spec :: Spec
+spec = do
+  describe "fixedToDouble and doubleToFixed" do
+    it "produces the same value when passing through both functions" $ property \value -> do
+      doubleToFixed (fixedToDouble value) `shouldBe` value
+  describe "fixedToDouble" do
+    it "behaves like wl_fixed_to_double" $ property \value -> do
+      fixedToDouble value `shouldBe` libwaylandFixedToDouble value
+    it "is correct when interacting with wl_fixed_from_double" $ property \value -> do
+      libwaylandDoubleToFixed (fixedToDouble value) `shouldBe` value
+  describe "doubleToFixed" do
+    it "behaves like wl_fixed_from_double" $ property \value -> do
+      doubleToFixed value `shouldBe` libwaylandDoubleToFixed value
+    it "is correct when interacting with wl_fixed_to_double"  $ property \value -> do
+      doubleToFixed (libwaylandFixedToDouble value) `shouldBe` value
-- 
GitLab