diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal index a504901a5999acb5028c25ffb9e4c130afa8f3c2..4a01433781bd4a5f2a3f6428816fa4289e2dc26d 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 002f22a138b84eddc4247af74820b15322dee938..1d2201604ef87af73e740dad46d0783a2651a729 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 60940c72275afd0e9b744a880ee66cdc8339dbc5..bc56fa3332c85799b5bc8c8aad081e9938b9e0a4 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 0000000000000000000000000000000000000000..ce257dd0b7e42995c47bfee2e55e95e6d7d2a7dc --- /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