diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,113 @@ +# Revision history for hs-bindgen-runtime + +## 1.0.0.0 -- 2026-10-08 + +### Breaking changes + +* Drop support for GHC 9.2. +* The modules supporting generated code have been renamed from + `HsBindgen.Runtime.Internal.*` to `HsBindgen.Runtime.Support.*`, and their + contents have changed. Bindings generated by earlier versions of + `hs-bindgen` must be regenerated. +* `zeroUnionValue` is no longer exported from `HsBindgen.Runtime.Prelude`. Use + `zero` from the new `IsUnion` class instead. See [issue #2060][is-2060] and + [PR #2091][pr-2091]. + +### New features + +* Add a new `HsBindgen.Runtime.HasFFIType` module with the `HasFFIType` class, + which maps types to the types used in `foreign import` argument and result + positions. The class is open: users can write their own instances, e.g. for + types referenced by external binding specifications. The module also exports + `PtrVoid`, `FunPtrVoid` and the deriving helper `ViaIdentity`. See [PR + #2267][pr-2267]. +* Add a new `HsBindgen.Runtime.Union` module for C unions. Generated union + types are newtypes around a byte array, so their fields cannot be accessed + through a data constructor. The `IsUnion` class has the single method + `zero`, the union value whose bytes are all zero. A union value is + constructed by setting one field of `zero`, either with `set` or by a record + update (see `HsBindgen.Runtime.Overloading`); `get` reads a field. The module + also exports the deriving helper `IsUnionViaReadRaw`. See [issue + #2060][is-2060] and [PR #2091][pr-2091]. +* Add a new `HsBindgen.Runtime.Struct` module with the `IsStruct` class for C + structs (currently with the single method `zero`) and the deriving + helper `IsStructViaReadRaw`. See [issue #2121][is-2121] and [PR + #2164][pr-2164]. +* Add a new `HsBindgen.Runtime.Overloading` module that re-exports the + functions the `RebindableSyntax` language extension takes out of scope (such + as `fromString`, `ifThenElse`, `getField`, and `setField`). + `RebindableSyntax` is required for overloaded record updates. See [issue + #2085][is-2085] and [PR #2168][pr-2168]. +* Add a new `HsBindgen.Runtime.Macro` module providing `Raw`, the type of macros + that are kept as their token spellings only, rather than typechecked. See + [issue #2242][is-2242]. + +### Minor changes + +* `HsBindgen.Runtime.Prelude` additionally exports `IsStruct`, `IsUnion`, and + `WithFlam` (opaque). +* `HsBindgen.Runtime.LibC` exports the data constructors of `CTime` and + `CClock`. + +### Bug fixes + +* Fix bit-field writes (`BitfieldPtr.poke`, `HasCBitfield`) that could write + more bytes than necessary. See [PR #2169][pr-2169]. +* Setting a union field no longer zeroes the bytes outside the field; only the + bytes belonging to the field are modified. See [issue #2183][is-2183]. + +[is-2060]: https://github.com/well-typed/hs-bindgen/issues/2060 +[is-2085]: https://github.com/well-typed/hs-bindgen/issues/2085 +[is-2121]: https://github.com/well-typed/hs-bindgen/issues/2121 +[is-2183]: https://github.com/well-typed/hs-bindgen/issues/2183 +[is-2242]: https://github.com/well-typed/hs-bindgen/issues/2242 +[pr-2091]: https://github.com/well-typed/hs-bindgen/pull/2091 +[pr-2164]: https://github.com/well-typed/hs-bindgen/pull/2164 +[pr-2168]: https://github.com/well-typed/hs-bindgen/pull/2168 +[pr-2169]: https://github.com/well-typed/hs-bindgen/pull/2169 +[pr-2267]: https://github.com/well-typed/hs-bindgen/pull/2267 + +## 0.1.0-alpha2 -- 2026-03-27 + +### Breaking changes + +* Remove `withPtr` for `IncompleteArray` and `ConstArray`. Use `withElemPtr` + from the `IsArray` class instead. See [PR #1712][pr-1712]. +* The `BitfieldPtr` constructor pattern is removed, making the type opaque. A + smart constructor and accessor functions are exported instead. +* `StaticSize` constraints are added to `HasCBitfield` API functions, in order + to calculate memory bounds. This enables single `peek`/`poke` reads/writes + when possible while ensuring that neighboring memory is not accessed. + +### New features + +* Add new `safeCastFunPtr` function to `HsBindgen.Runtime.Prelude`. + +* Improve documentation and fix documentation-related warnings. + +* Add new `IsArray` class with instances for `IncompleteArray` and + `ConstArray`. See [PR #1712][pr-1712]. + +### Minor changes + +* Add an internal prelude, re-exporting all definitions required by `hs-bindgen` + generated code. + +* Remove `TypeEquality` module and `TyEq`. Use built-in `(~)` or operator + `(~)` (for later versions of GHC; implicitly imported from `Prelude`). + +* Do not export `intVal` from `HsBindgen.Runtime.ConstantArray`. + +### Bug fixes + +* Rewrite bit-field `peek` and `poke` code to read to and write from the correct + locations in memory, support packed `struct` fields that cross machine word + boundaries, and only use aligned reads/writes so that it is safe across all + architectures +* Fix `loMask @Int64 64`, which was returning an incorrect mask + +[pr-1712]: https://github.com/well-typed/hs-bindgen/pull/1712 + +## 0.1.0-alpha -- 2026-02-06 + +* First public pre-release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2024-2026, Well-Typed LLP and Anduril Industries Inc. + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# `hs-bindgen-runtime` + +`hs-bindgen-runtime` is a library that provides runtime support for code +generated by [`hs-bindgen`][]. + +[`hs-bindgen`]: diff --git a/hs-bindgen-runtime.cabal b/hs-bindgen-runtime.cabal new file mode 100644 --- /dev/null +++ b/hs-bindgen-runtime.cabal @@ -0,0 +1,162 @@ +cabal-version: 3.0 +name: hs-bindgen-runtime +version: 1.0.0.0 +synopsis: Runtime support for code generated by hs-bindgen +license: BSD-3-Clause +license-file: LICENSE +author: Well-Typed LLP +maintainer: info@well-typed.com +category: Development +build-type: Simple +tested-with: + GHC ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.2 + || ==9.14.1 + +description: + This library provides abstractions used by the code generated by @hs-bindgen@. + In most cases it is also necessary for /interacting/ with that code. To do so, + you will probably want to start by importing the prelude + + > HsBindgen.Runtime.Prelude + + and then import other modules as needed; with the exception of the prelude, + all other modules are intended for qualified import. + +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/well-typed/hs-bindgen + subdir: hs-bindgen-runtime + +source-repository this + type: git + location: https://github.com/well-typed/hs-bindgen + subdir: hs-bindgen-runtime + tag: release-1.0.0.0 + +common lang + ghc-options: + -Wall -Wcompat -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wpartial-fields -Widentities + -Wredundant-constraints -Wmissing-export-lists + -Wno-unticked-promoted-constructors -Wunused-packages + -Wprepositive-qualified-module + + ghc-options: -Werror=missing-deriving-strategies + build-depends: base >=4.17 && <4.23 + default-language: GHC2021 + default-extensions: + DataKinds + DefaultSignatures + DeriveAnyClass + DerivingStrategies + DerivingVia + FunctionalDependencies + LambdaCase + PatternSynonyms + RecordWildCards + RoleAnnotations + ScopedTypeVariables + TypeFamilies + UndecidableInstances + ViewPatterns + + other-extensions: + CPP + MagicHash + NoImplicitPrelude + TemplateHaskell + UnboxedTuples + +library + import: lang + exposed-modules: + HsBindgen.Runtime.BitfieldPtr + HsBindgen.Runtime.Block + HsBindgen.Runtime.CBool + HsBindgen.Runtime.CEnum + HsBindgen.Runtime.ConstantArray + HsBindgen.Runtime.FLAM + HsBindgen.Runtime.HasCBitfield + HsBindgen.Runtime.HasCField + HsBindgen.Runtime.HasFFIType + HsBindgen.Runtime.IncompleteArray + HsBindgen.Runtime.IsArray + HsBindgen.Runtime.LibC + HsBindgen.Runtime.Macro + HsBindgen.Runtime.Marshal + HsBindgen.Runtime.Overloading + HsBindgen.Runtime.Prelude + HsBindgen.Runtime.PtrConst + HsBindgen.Runtime.Struct + HsBindgen.Runtime.Support + HsBindgen.Runtime.Support.Bitfield + HsBindgen.Runtime.Support.ByteArray + HsBindgen.Runtime.Support.CAPI + HsBindgen.Runtime.Support.CompatHasField + HsBindgen.Runtime.Support.FunPtr + HsBindgen.Runtime.Support.LibC.Auxiliary + HsBindgen.Runtime.Support.Ptr + HsBindgen.Runtime.Support.SizedByteArray + HsBindgen.Runtime.Union + + other-modules: + HsBindgen.Runtime.Support.FunPtr.Class + HsBindgen.Runtime.Support.TH.Instances + HsBindgen.Runtime.Support.TH.Types + + hs-source-dirs: src + + -- Internal dependencies + build-depends: + + -- External dependencies + build-depends: + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.9 + , primitive >=0.9 && <0.10 + , record-hasfield >=1.0 && <2 + , template-haskell >=2.19 && <2.25 + , vector >=0.13 && <0.14 + + build-tool-depends: hsc2hs:hsc2hs + +test-suite test-hs-bindgen-runtime + import: lang + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: test-runtime.hs + other-modules: + Test.HsBindgen.Runtime.Bitfield + Test.HsBindgen.Runtime.CBool + Test.HsBindgen.Runtime.CEnum + Test.HsBindgen.Runtime.CEnumArbitrary + Test.HsBindgen.Runtime.ConstantArray + Test.HsBindgen.Runtime.IncompleteArray + Test.HsBindgen.Runtime.Macro + Test.HsBindgen.Runtime.SizedByteArray + Test.HsBindgen.Runtime.Support.ByteArray + Test.Util.Orphans + Test.Util.QC + Test.Util.Show + Test.Util.Tasty + + -- Internal dependencies + build-depends: hs-bindgen-runtime + + -- External dependencies + build-depends: + , primitive >=0.8 && <0.10 + , QuickCheck >=2.14.3 && <2.18 + , tasty >=1.5 && <1.6 + , tasty-expected-failure >=0.12.3 && <1.13 + , tasty-hunit >=0.10.2 && <0.11 + , tasty-quickcheck >=0.11 && <0.12 + , transformers >=0.5 && <0.7 diff --git a/src/HsBindgen/Runtime/BitfieldPtr.hs b/src/HsBindgen/Runtime/BitfieldPtr.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/BitfieldPtr.hs @@ -0,0 +1,82 @@ +-- | Pointers to bitfields +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.BitfieldPtr qualified as BitfieldPtr +module HsBindgen.Runtime.BitfieldPtr ( + Bitfield(..) + , BitfieldPtr -- opaque + , mkBitfieldPtr + , startingByte + , offset + , width + , bounds + , peek + , poke + ) where + +import Data.Kind +import Data.Proxy +import Foreign.Ptr + +import HsBindgen.Runtime.Marshal qualified as Marshal +import HsBindgen.Runtime.Support.Bitfield as Bitfield + +-- | Pointer to a bit-field of a C object +-- +-- A @BitfieldPtr a@ is for a bit-field of type @a@. For example, a +-- @Bitfield CUInt@ points to a bit-field of type @CUInt@. +type BitfieldPtr :: Type -> Type +type role BitfieldPtr nominal +data BitfieldPtr a = UnsafeBitfieldPtr { + -- | Pointer to the byte where the bit-field starts + -- + -- We do /not/ assume that the pointer is aligned. + startingByte :: Ptr () + -- | Offset of the bit-field (0 to 7 bits) + , offset :: Int + -- | Width of the bit-field (1 to 64 bits) + , width :: Int + -- | Memory bounds of the @struct@ + -- + -- The lower bound is inclusive, and the upper bound is exclusive. + -- + -- To peek/poke a bit-field, we may peek/poke any memory within these + -- bounds. We must not peek/poke memory outside of these bounds. + , bounds :: (Ptr (), Ptr ()) + } + +-- | Construct a 'BitfieldPtr' given the C object pointer, offset, and width +mkBitfieldPtr :: forall s a. + Marshal.StaticSize s + => Ptr s -- ^ Pointer to the C object with the bit-field + -> Int -- ^ Offset of the bit-field (0 or more bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> BitfieldPtr a +mkBitfieldPtr ptr off width + | width < 1 || width > 64 = + error $ "invalid bit-field width: " ++ show width + | otherwise = UnsafeBitfieldPtr{ + startingByte = castPtr $ ptr `plusPtr` offBytes + , offset = offBits + , width = width + , bounds = (ptrL, ptrH) + } + where + offBytes, offBits :: Int + (offBytes, offBits) = off `quotRem` 8 + + ptrL, ptrH :: Ptr () + ptrL = castPtr ptr + ptrH = ptrL `plusPtr` Marshal.staticSizeOf @s Proxy + +{-# INLINE peek #-} +-- | Read from a bit-field +peek :: Bitfield a => BitfieldPtr a -> IO a +peek (UnsafeBitfieldPtr p o w b) = Bitfield.peekBitOffWidth p o w b + +{-# INLINE poke #-} +-- | Write to a bit-field +poke :: Bitfield a => BitfieldPtr a -> a -> IO () +poke (UnsafeBitfieldPtr p o w b) = Bitfield.pokeBitOffWidth p o w b diff --git a/src/HsBindgen/Runtime/Block.hs b/src/HsBindgen/Runtime/Block.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Block.hs @@ -0,0 +1,40 @@ +-- | Bare-bones support for blocks +-- +-- TODO +-- +-- Ideally we would at least support @Block_copy@ and @Block_release@. This +-- would be easy to do, but would mean that @hs-bindgen-runtime@ would then +-- depend on the runtime (@libblocksruntime@). +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.Block qualified as Block +module HsBindgen.Runtime.Block ( + Block(..) + ) where + +import Foreign (Ptr) + +import HsBindgen.Runtime.HasFFIType (HasFFIType) + +{------------------------------------------------------------------------------- + Definition + + We expose the definition of 'Block' so that it can appear in foreign imports. +-------------------------------------------------------------------------------} + +-- | Block +-- +-- See +-- +-- The type index is the type of the bloc, for example: +-- +-- > typedef int(^VarCounter)(int increment); +-- +-- corresponds to +-- +-- > newtype VarCounter = VarCounter (Block (CInt -> IO CInt)) +newtype Block t = Block (Ptr ()) + +deriving newtype instance HasFFIType (Block t) diff --git a/src/HsBindgen/Runtime/CBool.hs b/src/HsBindgen/Runtime/CBool.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/CBool.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | C boolean semantics +-- +-- In C, boolean types are numeric, where value @0@ is considered false and any +-- other value is considered true. They are implemented differently across +-- different C projects: +-- +-- * Since C23, there is a @bool@ type and predefined constants @true@ and +-- @false@. +-- * Since C99, standard header @stdbool.h@ defines (implementation-dependent) +-- type @_Bool@ and macros @true@ and @false@. This header is deprecated +-- since C23. +-- * Before C99, users defined boolean types and values, following the common +-- conventions. Some projects still define their own boolean type, perhaps +-- for compatibility with old C standards. Common implementations include the +-- following, where @bool@ may be spelled differently (such as @Bool@ or +-- @BOOL@): +-- +-- * An @enum@ type: +-- +-- @ +-- typedef enum { false, true } bool; +-- @ +-- +-- * A @typedef@ and /separate/ @enum@ values: +-- +-- @ +-- typedef int bool; +-- enum { false, true }; +-- @ +-- +-- * A @typedef@ and macro values: +-- +-- @ +-- typedef int bool; +-- #define true 1 +-- #define false 0 +-- @ +-- +-- * A macro alias and macro values: +-- +-- @ +-- #define bool int +-- #define true 1 +-- #define false 0 +-- @ +-- +-- This module provides an API that is compatible with bindings generated for +-- any of these possible implementations. Note that the implementation only +-- requires 'Eq' and 'Num' instances. Conversion follows C23 semantics: /only/ +-- value @0@ is considered false, and any other value is considered true. +-- +-- Intended for qualified import. +-- +-- > import HsBindgen.Runtime.CBool qualified as CBool +module HsBindgen.Runtime.CBool ( + -- * Values + true + , false + -- * Predicates + , isTrue + , isFalse + -- * Conversion + , fromBool + , toBool + -- * Operations + , (&&) + , (||) + , not + , bool + , if_ + , when + , unless + ) where + +import Prelude hiding (not, (&&), (||)) +import Prelude qualified + +{------------------------------------------------------------------------------- + Values +-------------------------------------------------------------------------------} + +-- | Standard true value: @1@ +true :: Num b => b +true = 1 + +-- | Standard false value: @0@ +false :: Num b => b +false = 0 + +{------------------------------------------------------------------------------- + Predicates +-------------------------------------------------------------------------------} + +-- | 'True' if the value is not @0@ +isTrue :: (Eq b, Num b) => b -> Bool +isTrue = (/= false) + +-- | 'True' if the value is @0@ +isFalse :: (Eq b, Num b) => b -> Bool +isFalse = (== false) + +{------------------------------------------------------------------------------- + Conversion +-------------------------------------------------------------------------------} + +-- | Convert from 'Bool' to 'true' or 'false' +fromBool :: Num b => Bool -> b +fromBool True = true +fromBool False = false + +-- | Convert to 'Bool' using 'isTrue' +toBool :: (Eq b, Num b) => b -> Bool +toBool = isTrue + +{------------------------------------------------------------------------------- + Operations +-------------------------------------------------------------------------------} + +-- | Boolean /and/, lazy in the second argument +-- +-- This function returns one of the standard values. +(&&) :: (Eq b, Num b) => b -> b -> b +l && r = fromBool $ toBool l Prelude.&& toBool r + +-- | Boolean /or/, lazy in the second argument +-- +-- This function returns one of the standard values. +(||) :: (Eq b, Num b) => b -> b -> b +l || r = fromBool $ toBool l Prelude.|| toBool r + +-- | Boolean /not/ +-- +-- This function returns one of the standard values. +not :: (Eq b, Num b) => b -> b +not = fromBool . Prelude.not . toBool + +-- | Boolean case analysis, implemented using 'isTrue' +-- +-- See 'Data.Bool.bool' for details. +bool :: (Eq b, Num b) => a -> a -> b -> a +bool f t b = if isTrue b then t else f + +-- | Boolean case analysis, implemented using 'isTrue' +if_ :: (Eq b, Num b) => b -> a -> a -> a +if_ b t f = if isTrue b then t else f + +-- | Execute an applicative expression when the condition 'isTrue' +when :: (Eq b, Num b, Applicative f) => b -> f () -> f () +when b e = if isTrue b then e else pure () +{-# ANN when ("HLint: ignore Use when" :: String) #-} + +-- | Execute an applicative expression when the condition 'isFalse' +unless :: (Eq b, Num b, Applicative f) => b -> f () -> f () +unless b e = if isFalse b then e else pure () +{-# ANN unless ("HLint: ignore Use when" :: String) #-} diff --git a/src/HsBindgen/Runtime/CEnum.hs b/src/HsBindgen/Runtime/CEnum.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/CEnum.hs @@ -0,0 +1,644 @@ +-- | C enumerations +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.CEnum qualified as CEnum +module HsBindgen.Runtime.CEnum ( + -- * Type classes + CEnum(..) + , SequentialCEnum(..) + -- * Deriving via support + , AsCEnum(..) + , AsSequentialCEnum(..) + -- * API + , getNames + -- * Instance support + , DeclaredValues + , declaredValuesFromList + , show + , shows + , showsWrappedUndeclared + , readEither + , readPrec + , readPrecWrappedUndeclared + , seqIsDeclared + , seqMkDeclared + -- ** Exceptions + , CEnumException(..) + ) where + +import Prelude hiding (show, shows) +import Prelude qualified + +import Control.Exception (Exception (displayException), throw) +import Data.Bifunctor (Bifunctor (first)) +import Data.Coerce (Coercible, coerce) +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Proxy (Proxy (Proxy)) +import GHC.Show (appPrec, appPrec1, showSpace) +import Text.ParserCombinators.ReadP qualified as ReadP +import Text.ParserCombinators.ReadPrec qualified as ReadPrec +import Text.Read (ReadPrec, minPrec, (+++)) +import Text.Read qualified as Read +import Text.Read.Lex (Lexeme (..), expect) + +{------------------------------------------------------------------------------- + Type classes +-------------------------------------------------------------------------------} + +-- | C enumeration +-- +-- This class implements an API for Haskell representations of C enumerations. +-- C @enum@ declarations only declare values; they do not limit the range of the +-- corresponding integral type. They may have negative values, non-sequential +-- values, and multiple names for a single value. +-- +-- At a low level, @hs-bindgen@ generates a @newtype@ wrapper around the +-- integral representation type to represent a C @enum@. An instance of this +-- class is generated automatically. A 'Show' instance defined using 'shows' is +-- also generated by default. 'Bounded' and 'Prelude.Enum' instances are /not/ +-- generated automatically because values do not technically need to be +-- declared. Users may optionally derive these instances using 'AsCEnum' or +-- 'AsSequentialCEnum' when appropriate. +-- +-- This class may also be used with Haskell sum-type representations of +-- enumerations. +class Integral (CEnumZ a) => CEnum a where + -- | Integral representation type + type CEnumZ a + + -- | Construct a value from the integral representation + -- + -- prop> fromCEnum . toCEnum === id + toCEnum :: CEnumZ a -> a + default toCEnum :: Coercible a (CEnumZ a) => CEnumZ a -> a + toCEnum = coerce + + -- | Get the integral representation for a value + -- + -- prop> toCEnum . fromCEnum === id + -- + -- If @a@ has an 'Ord' instance, it should be compatible with the 'Ord' + -- instance on the underlying integral value: + -- + -- prop> \x y -> (x <= y) === (fromCEnum x <= fromCEnum y) + fromCEnum :: a -> CEnumZ a + default fromCEnum :: Coercible a (CEnumZ a) => a -> CEnumZ a + fromCEnum = coerce + + -- | Declared values and associated names + declaredValues :: proxy a -> DeclaredValues a + + -- | Show undeclared value + -- + -- Like any 'Show' related function, this should generate a valid Haskell + -- expression. In this case, a valid Haskell expression for values /outside/ + -- of the set of declared values (that is, for which 'isDeclared' will return + -- 'False'). + -- + -- The default definition just shows the underlying integer value; this is + -- valid if the Haskell wrapper has a 'Num' instance. If the Haskell type is + -- simply a newtype wrapper around the underlying C type, you can use + -- 'showsWrappedUndeclared'. Finally, if the Haskell type /cannot/ represent + -- undeclared values, this can be defined using @error@. + -- + -- > showsUndeclared _ = \_ x -> + -- > error $ "Unexpected value " ++ show x ++ " for type Foo" + showsUndeclared :: proxy a -> Int -> CEnumZ a -> ShowS + default showsUndeclared :: + Show (CEnumZ a) + => proxy a -> Int -> CEnumZ a -> ShowS + showsUndeclared _ = showsPrec + + -- | Read undeclared value + -- + -- See 'showsUndeclared', 'showsWrappedUndeclared', and + -- 'readPrecWrappedUndeclared'. + readPrecUndeclared :: ReadPrec a + + -- | Determine if the specified value is declared + -- + -- This has a default definition in terms of 'declaredValues', but you may + -- wish to override this with a more efficient implementation (in particular, + -- see 'seqIsDeclared'). + isDeclared :: a -> Bool + isDeclared x = (fromCEnum x) `Map.member` getIntegralToDeclaredValues (Proxy :: Proxy a) + + -- | Construct a value only if it is declared + -- + -- See also 'seqMkDeclared'. + mkDeclared :: CEnumZ a -> Maybe a + mkDeclared i + | i `Map.member` getIntegralToDeclaredValues (Proxy :: Proxy a) = Just (toCEnum i) + | otherwise = Nothing + +-- | C enumeration with sequential values +-- +-- 'Bounded' and 'Enum' methods may be implemented more efficiently when the +-- values of an enumeration are sequential. An instance of this class is +-- generated automatically in this case. Users may optionally derive these +-- instances using 'AsSequentialCEnum' when appropriate. +-- +-- This class may also be used with Haskell sum-type representations of +-- enumerations. +-- +-- prop> all isDeclared [minDeclaredValue..maxDeclaredValue] +class CEnum a => SequentialCEnum a where + -- | The minimum declared value + -- + -- prop> minDeclaredValue == minimum (filter isDeclared (map toCEnum [minBound..])) + minDeclaredValue :: a + + -- | The maximum declared value + -- + -- prop> maxDeclaredValue == maximum (filter isDeclared (map toCEnum [minBound..])) + maxDeclaredValue :: a + +{------------------------------------------------------------------------------- + API +-------------------------------------------------------------------------------} + +-- | Get all names associated with a value +-- +-- An empty list is returned when the specified value is not declared. +getNames :: forall a. CEnum a => a -> [String] +getNames x = maybe [] NonEmpty.toList $ + Map.lookup (fromCEnum x) (getIntegralToDeclaredValues (Proxy :: Proxy a)) + +{------------------------------------------------------------------------------- + Instance support +-------------------------------------------------------------------------------} + +-- | Declared values (opaque) +data DeclaredValues a = DeclaredValues + { integralToDeclaredValues :: !(Map (CEnumZ a) (NonEmpty String)) + , declaredValueToIntegral :: !(Map String (CEnumZ a)) + } + +-- | Construct t'DeclaredValues' from a list of values and associated names +declaredValuesFromList :: + Ord (CEnumZ a) + => [(CEnumZ a, NonEmpty String)] + -> DeclaredValues a +declaredValuesFromList xs = + DeclaredValues + { integralToDeclaredValues = Map.fromList xs + , declaredValueToIntegral = + Map.fromList [ (n, i) | (i, ns) <- xs , n <- NonEmpty.toList ns ] } + +declaredValuesList :: DeclaredValues a -> [String] +declaredValuesList = Map.keys . declaredValueToIntegral + +-- | Show the specified value +-- +-- Examples for a hypothetical enumeration type, using generated defaults: +-- +-- > showCEnum StatusOK == "StatusOK" +-- +-- > showCEnum (StatusCode 418) == "StatusCode 418" +show :: forall a. CEnum a => a -> String +show x = shows 0 x "" + +-- | Generalization of 'Prelude.show' (akin to 'Prelude.shows'). +-- +-- This function may be used in the definition of a 'Show' instance for a +-- @newtype@ representation of a C enumeration. +-- +-- When the value is declared, a corresponding name is returned. Otherwise, +-- 'showsUndeclared' is called. +shows :: forall a. CEnum a => Int -> a -> ShowS +shows prec x = + case Map.lookup i (getIntegralToDeclaredValues (Proxy :: Proxy a)) of + Just (name :| _names) -> showString name + Nothing -> showsUndeclared (Proxy :: Proxy a) prec i + where + i :: CEnumZ a + i = fromCEnum x + +-- | Read a 'CEnum' from string +-- +-- Examples for a hypothetical enumeration type, using generated defaults: +-- +-- > (readEitherCEnum "StatusCode 200" :: StatusCode) == Right StatusOK +-- +-- > (readEitherCEnum "StatusOK" :: StatusCode) == Right StatusOK +-- +-- > (readEitherCEnum "StatusCode 123" :: StatusCode) == Right (StatusCode 123) +readEither :: forall a. CEnum a => String -> Either String a +readEither s = + case [ x | (x,"") <- ReadPrec.readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "readEitherCEnum: no parse" + _xs -> Left "readEitherCEnum: ambiguous parse" + where + read' = + do x <- readPrec + ReadPrec.lift ReadP.skipSpaces + return x + +-- | Helper function for defining 'showsUndeclared' +-- +-- This helper can be used in the case where @a@ is a newtype wrapper around +-- the underlying @CEnumZ a@. +showsWrappedUndeclared :: + Show (CEnumZ a) + => String -> proxy a -> Int -> CEnumZ a -> ShowS +showsWrappedUndeclared constructorName _ p x = showParen (p >= appPrec1) $ + showString constructorName + . showSpace + . showsPrec appPrec1 x + +-- | Read a declared 'CEnum' value +readPrecDeclaredValue :: forall proxy a. CEnum a => proxy a -> ReadPrec a +readPrecDeclaredValue proxy = Read.parens $ ReadPrec.prec appPrec1 $ do + declaredValue <- ReadPrec.lift $ ReadP.choice $ + map ReadP.string $ declaredValuesList $ declaredValues proxy + pure $ toCEnum $ (declaredValueToIntegral $ declaredValues proxy) Map.! declaredValue + +-- | Helper function for defining 'readPrecUndeclared' +-- +-- This helper can be used in the case where @a@ is a newtype wrapper around +-- the underlying @CEnumZ a@. +readPrecWrappedUndeclared + :: forall a. (CEnum a, Read (CEnumZ a)) => String -> ReadPrec a +readPrecWrappedUndeclared constructorName = Read.parens $ ReadPrec.prec appPrec $ do + ReadPrec.lift $ expect $ Ident constructorName + n <- Read.step (Read.readPrec :: ReadPrec (CEnumZ a)) + pure $ toCEnum n + +-- | Read a 'CEnum' from string +-- +-- This function may be used in the definition of a 'Read' instance for a +-- @newtype@ representation of a C enumeration. +readPrec :: forall a. CEnum a => ReadPrec a +readPrec = readPrecDeclaredValue (Proxy :: Proxy a) +++ readPrecUndeclared + +-- | Determine if the specified value is declared +-- +-- This implementation is optimized for 'SequentialCEnum'. +seqIsDeclared :: forall a. SequentialCEnum a => a -> Bool +seqIsDeclared x = i >= minZ && i <= maxZ + where + minZ, maxZ, i :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromCEnum x + +-- | Construct a value only if it is declared +-- +-- This implementation is optimized for 'SequentialCEnum'. +seqMkDeclared :: forall a. SequentialCEnum a => CEnumZ a -> Maybe a +seqMkDeclared i + | i >= minZ && i <= maxZ = Just (toCEnum i) + | otherwise = Nothing + where + minZ, maxZ :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + +{------------------------------------------------------------------------------- + Deriving via support +-------------------------------------------------------------------------------} + +-- | Type used to derive classes using @DerivingVia@ a type with a 'CEnum' +-- instance +-- +-- When the values are sequential, 'AsSequentialCEnum' provides better +-- performance and should therefore be used instead. +-- +-- The following classes may be derived: +-- +-- * 'Bounded' may be derived using the bounds of the declared values. This is +-- /not/ derived by default. +-- * 'Enum' may be derived using the bounds of the declared values. This +-- instance assumes that only the declared values are valid and throws a +-- 'CEnumException' if passed a value that is not declared. This is /not/ +-- derived by default. +-- +-- For /declared/ values we have +-- +-- prop> toEnum === coerce . toCENum . fromIntegral +-- prop> fromEnum === fromIntegral . fromCEnum . coerce +-- +-- In addition we guarantee that where 'pred' or 'succ' are defined, we have +-- +-- prop> \x -> (pred x < x) && (x < succ x) +newtype AsCEnum a = WrapCEnum { unwrapCEnum :: a } + +instance CEnum a => Bounded (AsCEnum a) where + minBound = WrapCEnum minBoundGen + maxBound = WrapCEnum maxBoundGen + +instance CEnum a => Enum (AsCEnum a) where + succ = WrapCEnum . succGen . unwrapCEnum + pred = WrapCEnum . predGen . unwrapCEnum + + toEnum = WrapCEnum . toEnumGen + fromEnum = fromEnumGen . unwrapCEnum + + enumFrom (WrapCEnum x) = WrapCEnum <$> enumFromGen x + enumFromThen (WrapCEnum x) (WrapCEnum y) = WrapCEnum <$> enumFromThenGen x y + enumFromTo (WrapCEnum x) (WrapCEnum z) = WrapCEnum <$> enumFromToGen x z + enumFromThenTo (WrapCEnum x) (WrapCEnum y) (WrapCEnum z) = + WrapCEnum <$> enumFromThenToGen x y z + +-- | Type used to derive classes using @DerivingVia@ a type with a +-- 'SequentialCEnum' instance +-- +-- The following classes may be derived: +-- +-- * 'Bounded' may be derived using the bounds of the declared values. This is +-- /not/ derived by default. +-- * 'Enum' may be derived using the bounds of the declared values. This +-- instance assumes that only the declared values are valid and throws a +-- 'CEnumException' if passed a value that is not declared. This is /not/ +-- derived by default. +-- +-- 'AsSequentialCEnum' should have the same properties as 'AsCEnum'. +newtype AsSequentialCEnum a = WrapSequentialCEnum { unwrapSequentialCEnum :: a } + +instance SequentialCEnum a => Bounded (AsSequentialCEnum a) where + minBound = WrapSequentialCEnum minBoundSeq + maxBound = WrapSequentialCEnum maxBoundSeq + +instance SequentialCEnum a => Enum (AsSequentialCEnum a) where + succ = WrapSequentialCEnum . succSeq . unwrapSequentialCEnum + pred = WrapSequentialCEnum . predSeq . unwrapSequentialCEnum + + toEnum = WrapSequentialCEnum . toEnumSeq + fromEnum = fromEnumSeq . unwrapSequentialCEnum + + enumFrom (WrapSequentialCEnum x) = WrapSequentialCEnum <$> enumFromSeq x + enumFromThen (WrapSequentialCEnum x) (WrapSequentialCEnum y) = + WrapSequentialCEnum <$> enumFromThenSeq x y + enumFromTo (WrapSequentialCEnum x) (WrapSequentialCEnum z) = + WrapSequentialCEnum <$> enumFromToSeq x z + enumFromThenTo + (WrapSequentialCEnum x) + (WrapSequentialCEnum y) + (WrapSequentialCEnum z) = + WrapSequentialCEnum <$> enumFromThenToSeq x y z + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +-- | Exceptions used by optional C enumeration instances +data CEnumException + = CEnumNotDeclared Integer + | CEnumNoSuccessor Integer + | CEnumNoPredecessor Integer + | CEnumEmpty + | CEnumFromEqThen Integer + deriving stock (Eq, Show) + +instance Exception CEnumException where + displayException = \case + CEnumNotDeclared i -> "C enumeration value not declared: " ++ Prelude.show i + CEnumNoSuccessor i -> + "C enumeration value has no declared successor: " ++ Prelude.show i + CEnumNoPredecessor i -> + "C enumeration value has no declared predecessor: " ++ Prelude.show i + CEnumEmpty -> "C enumeration has no declared values" + CEnumFromEqThen i -> "enumeration from and then values equal: " ++ Prelude.show i + +{------------------------------------------------------------------------------- + Bounded instance implementation +-------------------------------------------------------------------------------} + +minBoundGen :: forall a. CEnum a => a +minBoundGen = case Map.lookupMin (getIntegralToDeclaredValues (Proxy :: Proxy a)) of + Just (i, _names) -> toCEnum i + Nothing -> throw CEnumEmpty + +minBoundSeq :: SequentialCEnum a => a +minBoundSeq = minDeclaredValue + +maxBoundGen :: forall a. CEnum a => a +maxBoundGen = case Map.lookupMax (getIntegralToDeclaredValues (Proxy :: Proxy a)) of + Just (k, _names) -> toCEnum k + Nothing -> throw CEnumEmpty + +maxBoundSeq :: SequentialCEnum a => a +maxBoundSeq = maxDeclaredValue + +{------------------------------------------------------------------------------- + Enum instance implementation +-------------------------------------------------------------------------------} + +succGen :: forall a. CEnum a => a -> a +succGen x = either (throw . CEnumNotDeclared) id $ do + (_ltMap, gtMap) <- splitMap i (getIntegralToDeclaredValues (Proxy :: Proxy a)) + case Map.lookupMin gtMap of + Just (j, _names) -> return $ toCEnum j + Nothing -> throw $ CEnumNoSuccessor (toInteger i) + where + i :: CEnumZ a + i = fromCEnum x + +succSeq :: forall a. SequentialCEnum a => a -> a +succSeq x + | i >= minZ && i < maxZ = toCEnum (i + 1) + | i == maxZ = throw $ CEnumNoSuccessor (toInteger i) + | otherwise = throw $ CEnumNotDeclared (toInteger i) + where + minZ, maxZ, i :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromCEnum x + +predGen :: forall a. CEnum a => a -> a +predGen y = either (throw . CEnumNotDeclared) id $ do + (ltMap, _gtMap) <- splitMap j (getIntegralToDeclaredValues (Proxy :: Proxy a)) + case Map.lookupMax ltMap of + Just (i, _names) -> return $ toCEnum i + Nothing -> throw $ CEnumNoPredecessor (toInteger j) + where + j :: CEnumZ a + j = fromCEnum y + +predSeq :: forall a. SequentialCEnum a => a -> a +predSeq y + | j > minZ && j <= maxZ = toCEnum (j - 1) + | j == minZ = throw $ CEnumNoPredecessor (toInteger j) + | otherwise = throw $ CEnumNotDeclared (toInteger j) + where + minZ, maxZ, j :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + j = fromCEnum y + +toEnumGen :: CEnum a => Int -> a +toEnumGen i = case mkDeclared (fromIntegral i) of + Just x -> x + Nothing -> throw $ CEnumNotDeclared (toInteger i) + +toEnumSeq :: forall a. SequentialCEnum a => Int -> a +toEnumSeq n + | i >= minZ && i <= maxZ = toCEnum i + | otherwise = throw $ CEnumNotDeclared (toInteger i) + where + minZ, maxZ, i :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromIntegral n + +fromEnumGen :: forall a. CEnum a => a -> Int +fromEnumGen x + | i `Map.member` getIntegralToDeclaredValues (Proxy :: Proxy a) = fromIntegral i + | otherwise = throw $ CEnumNotDeclared (toInteger i) + where + i :: CEnumZ a + i = fromCEnum x + +fromEnumSeq :: forall a. SequentialCEnum a => a -> Int +fromEnumSeq x + | i >= minZ && i <= maxZ = fromIntegral i + | otherwise = throw $ CEnumNotDeclared (toInteger i) + where + minZ, maxZ, i :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromCEnum x + +enumFromGen :: forall a. CEnum a => a -> [a] +enumFromGen x = either (throw . CEnumNotDeclared) id $ do + (_ltMap, gtMap) <- splitMap i (getIntegralToDeclaredValues (Proxy :: Proxy a)) + return $ x : map toCEnum (Map.keys gtMap) + where + i :: CEnumZ a + i = fromCEnum x + +enumFromSeq :: forall a. SequentialCEnum a => a -> [a] +enumFromSeq x + | i >= minZ && i <= maxZ = map toCEnum [i .. maxZ] + | otherwise = throw $ CEnumNotDeclared (toInteger i) + where + minZ, maxZ, i :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromCEnum x + +enumFromThenGen :: forall a. CEnum a => a -> a -> [a] +enumFromThenGen x y = case compare i j of + LT -> either (throw . CEnumNotDeclared) id $ do + (_ltIMap, gtIMap) <- splitMap i (getIntegralToDeclaredValues (Proxy :: Proxy a)) + (ltJMap, gtJMap) <- splitMap j gtIMap + let w = Map.size ltJMap + 1 + js = j : Map.keys gtJMap + return $ x : map (toCEnum . NonEmpty.head) (nonEmptyChunksOf w js) + GT -> either (throw . CEnumNotDeclared) id $ do + (ltIMap, _gtIMap) <- splitMap i (getIntegralToDeclaredValues (Proxy :: Proxy a)) + (ltJMap, gtJMap) <- splitMap j ltIMap + let w = Map.size gtJMap + 1 + js = j : reverse (Map.keys ltJMap) + return $ x : map (toCEnum . NonEmpty.head) (nonEmptyChunksOf w js) + EQ -> throw $ CEnumFromEqThen (toInteger i) + where + i, j :: CEnumZ a + i = fromCEnum x + j = fromCEnum y + +enumFromThenSeq :: forall a. SequentialCEnum a => a -> a -> [a] +enumFromThenSeq x y + | i == j = throw $ CEnumFromEqThen (toInteger i) + | i < minZ || i > maxZ = throw $ CEnumNotDeclared (toInteger i) + | j < minZ || j > maxZ = throw $ CEnumNotDeclared (toInteger j) + | i < j = map toCEnum [i, j .. maxZ] + | otherwise = map toCEnum [i, j .. minZ] + where + minZ, maxZ, i, j :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromCEnum x + j = fromCEnum y + +enumFromToGen :: forall a. CEnum a => a -> a -> [a] +enumFromToGen x z = either (throw . CEnumNotDeclared) id $ do + (_ltIMap, gtIMap) <- splitMap i (getIntegralToDeclaredValues (Proxy :: Proxy a)) + if i == k + then return [x] + else do + (ltKMap, _gtKMap) <- splitMap k gtIMap + return $ x : map toCEnum (Map.keys ltKMap) ++ [z] + where + i, k :: CEnumZ a + i = fromCEnum x + k = fromCEnum z + +enumFromToSeq :: forall a. SequentialCEnum a => a -> a -> [a] +enumFromToSeq x z + | i < minZ || i > maxZ = throw $ CEnumNotDeclared (toInteger i) + | k < minZ || k > maxZ = throw $ CEnumNotDeclared (toInteger k) + | otherwise = map toCEnum [i .. k] + where + minZ, maxZ, i, k :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromCEnum x + k = fromCEnum z + +enumFromThenToGen :: forall a. CEnum a => a -> a -> a -> [a] +enumFromThenToGen x y z = case compare i j of + LT -> either (throw . CEnumNotDeclared) id $ do + (_ltIMap, gtIMap) <- splitMap i (getIntegralToDeclaredValues (Proxy :: Proxy a)) + (ltJMap, gtJMap) <- splitMap j gtIMap + (ltKMap, _gtKMap) <- splitMap k gtJMap + let w = Map.size ltJMap + 1 + js = j : Map.keys ltKMap ++ [k] + return $ x : map (toCEnum . NonEmpty.head) (nonEmptyChunksOf w js) + GT -> either (throw . CEnumNotDeclared) id $ do + (ltIMap, _gtIMap) <- splitMap i (getIntegralToDeclaredValues (Proxy :: Proxy a)) + (ltJMap, gtJMap) <- splitMap j ltIMap + (_ltKMap, gtKMap) <- splitMap k ltJMap + let w = Map.size gtJMap + 1 + js = j : reverse (k : Map.keys gtKMap) + return $ x : map (toCEnum . NonEmpty.head) (nonEmptyChunksOf w js) + EQ -> throw $ CEnumFromEqThen (toInteger i) + where + i, j, k :: CEnumZ a + i = fromCEnum x + j = fromCEnum y + k = fromCEnum z + +enumFromThenToSeq :: forall a. SequentialCEnum a => a -> a -> a -> [a] +enumFromThenToSeq x y z + | i == j = throw $ CEnumFromEqThen (toInteger i) + | i < minZ || i > maxZ = throw $ CEnumNotDeclared (toInteger i) + | j < minZ || j > maxZ = throw $ CEnumNotDeclared (toInteger j) + | k < minZ || k > maxZ = throw $ CEnumNotDeclared (toInteger k) + | otherwise = map toCEnum [i, j .. k] + where + minZ, maxZ, i, j, k :: CEnumZ a + minZ = fromCEnum (minDeclaredValue @a) + maxZ = fromCEnum (maxDeclaredValue @a) + i = fromCEnum x + j = fromCEnum y + k = fromCEnum z + +{------------------------------------------------------------------------------- + Auxiliary Functions +-------------------------------------------------------------------------------} + +getIntegralToDeclaredValues :: CEnum a => proxy a -> Map (CEnumZ a) (NonEmpty String) +getIntegralToDeclaredValues = integralToDeclaredValues . declaredValues + +nonEmptyChunksOf :: Int -> [a] -> [NonEmpty a] +nonEmptyChunksOf n xs + | n > 0 = aux xs + | otherwise = error $ "nonEmptyChunksOf: n must be positive, got " ++ Prelude.show n + where + aux :: [a] -> [NonEmpty a] + aux xs' = case first NonEmpty.nonEmpty (List.splitAt n xs') of + (Just ne, rest) -> ne : aux rest + (Nothing, _rest) -> [] + +splitMap :: Integral k => k -> Map k v -> Either Integer (Map k v, Map k v) +splitMap n m = case Map.splitLookup n m of + (ltMap, Just{}, gtMap) -> Right (ltMap, gtMap) + (_ltMap, Nothing, _gtMap) -> Left (toInteger n) diff --git a/src/HsBindgen/Runtime/ConstantArray.hs b/src/HsBindgen/Runtime/ConstantArray.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/ConstantArray.hs @@ -0,0 +1,221 @@ +-- | C arrays of known, constant size +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.ConstantArray qualified as CA +module HsBindgen.Runtime.ConstantArray ( + ConstantArray -- opaque + , toVector + , fromVector + -- * Pointers + -- $pointers + , toPtr + , toFirstElemPtr + -- * Construction + , repeat + , fromList + -- * Query + , toList + ) where + +import Prelude hiding (repeat) + +import Data.Coerce (Coercible, coerce) +import Data.Proxy (Proxy (..)) +import Data.Vector.Storable qualified as VS +import Foreign.ForeignPtr (mallocForeignPtrArray, withForeignPtr) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable (..)) +import GHC.Records (HasField (..)) +import GHC.Stack (HasCallStack) +import GHC.TypeNats (KnownNat, Nat, natVal) + +import HsBindgen.Runtime.IsArray (IsArray (..)) +import HsBindgen.Runtime.Marshal (ReadRaw, StaticSize, WriteRaw) + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | A C array of known size +newtype ConstantArray (n :: Nat) a = CA (VS.Vector a) + deriving stock (Eq, Show) + deriving anyclass (ReadRaw, StaticSize, WriteRaw) + +type role ConstantArray nominal nominal + +-- | /( O(1) /): Get the underlying 'VS.Vector' representation +-- +-- This makes the full 'VS.Vector' API available. +toVector :: + forall a n arrayLike. + Coercible arrayLike (ConstantArray n a) + => arrayLike + -> (Proxy n, VS.Vector a) +toVector (coerce -> xs) = (Proxy @n, xs) + +-- | /( O(1) /): Construct from a 'VS.Vector' representation +-- +-- This makes the full 'VS.Vector' API available. +-- +-- Precondition: the vector must have the right number of elements. +fromVector :: + forall a n arrayLike. ( + Coercible arrayLike (ConstantArray n a) + , Storable a + , KnownNat n + , HasCallStack + ) + => Proxy n + -> VS.Vector a + -> arrayLike +fromVector _ xs + | VS.length xs == n = coerce xs + | otherwise = error $ "fromVector: expected " ++ show n ++ " elements" + where + n = intVal (Proxy @n) + +{------------------------------------------------------------------------------- + Pointers +-------------------------------------------------------------------------------} + +-- $pointers +-- +-- In example C code below, @p1@ points to the array @xs@ as a whole, while @p2@ +-- points to the first element of @xs@. +-- +-- > extern int xs[3]; +-- > void foo () { +-- > int (*p1)[3] = &xs; +-- > int *p2 = &(xs[0]); +-- > } +-- +-- Though the types of @p1@ and @p2@ differ, the /values/ of the pointers (the +-- address they point to) is the same. An array is just a block of contiguous +-- memory storing array elements. @p1@ points to where @xs@ starts, and @p2@ +-- points to where the first element of @xs@ starts, and these addresses are the +-- same. In Haskell, the corresponding types for @p1@ and @p2@ respectively are +-- @'Ptr' ('ConstantArray' n 'Foreign.C.CInt')@ and @'Ptr' 'Foreign.C.CInt'@ +-- respectively. +-- +-- Functions like 'peek' require a @'Ptr' ('ConstantArray' n a)@ argument. If +-- the user only has access to a @'Ptr' a@ but they know that is pointing to the +-- first element in an array, then they can use 'toPtr' to convert the pointer +-- before using 'HsBindgen.Runtime.IncompleteArray.peekArray' on it. Conversely, +-- if the user has access to a @'Ptr' ('ConstantArray' n a)@ but they want to +-- convert it to a @'Ptr' a@, then they can use @'toFirstElemPtr'@. +-- +-- NOTE: with overloaded record dot syntax, syntax like @.toFirstElemPtr@ is +-- also supported. +-- +-- Relevant functions in this module also support pointers of newtypes around +-- 'ConstantArray', hence the addition of 'Coercible' constraints in many +-- places. For example, we can use 'toPtr' at a 'ConstantArray' type +-- or we can use 'toPtr' at a newtype around a 'ConstantArray'. +-- +-- > newtype A n = A (ConstantArray n CInt) +-- > toPtr @(ConstantArray 3 CInt) :: +-- > Proxy 3 -> Ptr CInt -> Ptr (ConstantArray 3 CInt) +-- > toPtr @(A 3) :: +-- > Proxy 3 -> Ptr CInt -> Ptr (A 3) + +-- | 'toFirstElemPtr' for overloaded record dot syntax +instance HasField "toFirstElemPtr" (Ptr (ConstantArray n a)) (Ptr a) where + getField = snd . toFirstElemPtr + +-- | /( O(1) /): Use a pointer to the first element of an array as a pointer to the whole of +-- said array. +-- +-- NOTE: this function does not check that the pointer /is/ actually a pointer +-- to the first element of an array. +toPtr :: + forall arrayLike n a. Coercible arrayLike (ConstantArray n a) + => Proxy n + -> Ptr a + -> Ptr arrayLike +toPtr _ = castPtr + where + -- The 'Coercible' constraint is unused but that is intentional, so we + -- circumvent the @-Wredundant-constraints@ warning by defining @_unused@. + -- + -- Why is it intentional? The constraint adds a little bit of type safety to + -- the use of 'castPtr', which can normally cast pointers arbitrarily. + _unused = coerce @arrayLike @(ConstantArray n a) + +-- | /( O(1) /): Use a pointer to a whole array as a pointer to the first element of said +-- array. +toFirstElemPtr :: + forall arrayLike n a. Coercible arrayLike (ConstantArray n a) + => Ptr arrayLike + -> (Proxy n, Ptr a) +toFirstElemPtr ptr = (Proxy @n, castPtr ptr) + where + -- The 'Coercible' constraint is unused but that is intentional, so we + -- circumvent the @-Wredundant-constraints@ warning by defining @_unused@. + -- + -- Why is it intentional? The constraint adds a little bit of type safety to + -- the use of 'castPtr', which can normally cast pointers arbitrarily. + _unused = coerce @arrayLike @(ConstantArray n a) + +instance (Storable a, KnownNat n) => Storable (ConstantArray n a) where + sizeOf _ = intVal (Proxy @n) * sizeOf (undefined :: a) + + alignment _ = alignment (undefined :: a) + + peek ptr = do + fptr <- mallocForeignPtrArray size + withForeignPtr fptr $ \ptr' -> do + copyBytes ptr' (castPtr ptr) (size * sizeOfA) + vs <- VS.freeze (VS.MVector size fptr) + return (CA vs) + where + size = intVal (Proxy @n) + sizeOfA = sizeOf (undefined :: a) + + poke ptr (CA vs) = do + VS.MVector size fptr <- VS.unsafeThaw vs + withForeignPtr fptr $ \ptr' -> do + copyBytes ptr (castPtr ptr') (size * sizeOfA) + where + sizeOfA = sizeOf (undefined :: a) + +instance IsArray (ConstantArray n a) where + type Elem (ConstantArray n a) = a + -- | /( O(n) /) + withElemPtr (CA v) k = do + -- we copy the data, a e.g. int fun(int xs[3]) may mutate it. + VS.MVector _ fptr <- VS.thaw v + withForeignPtr fptr $ \(ptr :: Ptr a) -> k ptr + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | /( O(n) /) +repeat :: forall n a. (KnownNat n, Storable a) => a -> ConstantArray n a +repeat x = CA (VS.replicate (intVal (Proxy @n)) x) + +-- | /( O(n) /): Construct from a list +-- +-- Precondition: the list must have the right number of elements. +fromList :: forall n a. + (KnownNat n, Storable a, HasCallStack) + => [a] -> ConstantArray n a +fromList xs = fromVector (Proxy @n) (VS.fromList xs) + +{------------------------------------------------------------------------------- + Query +-------------------------------------------------------------------------------} + +-- | /( O(n) /) +toList :: Storable a => ConstantArray n a -> [a] +toList (CA v) = VS.toList v + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +intVal :: forall n. KnownNat n => Proxy n -> Int +intVal p = fromIntegral (natVal p) diff --git a/src/HsBindgen/Runtime/FLAM.hs b/src/HsBindgen/Runtime/FLAM.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/FLAM.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MagicHash #-} + +-- We capitalize module names, but use camelCase/PascalCase in code: +-- +-- - in types names: FlamFoo, FooFlamBar +-- - in variable names: flamFoo, fooFlamBar + +-- | Intended for qualified import. +-- +-- @ +-- import HsBindgen.Runtime.FLAM (WithFlam) +-- import HsBindgen.Runtime.FLAM qualified as FLAM +-- @ +module HsBindgen.Runtime.FLAM ( + -- * Definitions + Offset (..), + NumElems (..), + WithFlam (..), + -- * Exceptions + FlamLengthMismatch (..), +) where + +import Control.Exception (Exception, throwIO) +import Data.Kind (Type) +import Data.Vector.Storable qualified as VS +import Data.Vector.Storable.Mutable qualified as VSM +import Foreign (Ptr, Storable) +import Foreign qualified +import GHC.Exts (Proxy#, proxy#) + +import HsBindgen.Runtime.Marshal + +{------------------------------------------------------------------------------- + Definitions +-------------------------------------------------------------------------------} + +-- | The offset of the FLAM to the beginning of the underlying data structure in +-- bytes +class Offset elem aux | aux -> elem where + offset :: Proxy# aux -> Int + +-- | The number of elements 'elem' of the FLAM contained in structure 'aux' +class Offset elem aux => NumElems elem aux | aux -> elem where + numElems :: aux -> Int + +-- | Data structure with flexible array member +data WithFlam elem aux = WithFlam + { -- Underlying data structure without FLAM + aux :: !aux + -- We use the word "flam" for the flexible array member of the struct. + -- We use the word "vector" to refer to its Haskell representation (as a + -- vector). + , flam :: {-# UNPACK #-} !(VS.Vector elem) + } + deriving stock Show + +instance + (Storable aux, Storable elem, NumElems elem aux) + => ReadRaw (WithFlam elem aux) where + readRaw = peek + +instance + (Storable aux, Storable elem, NumElems elem aux ) + => WriteRaw (WithFlam elem aux) where + writeRaw = poke + +{------------------------------------------------------------------------------- + Peek and poke +-------------------------------------------------------------------------------} + +-- | Peek structure with flexible array member. +peek :: forall aux elem. + (Storable aux , Storable elem, NumElems elem aux) + => Ptr (WithFlam elem aux) -> IO (WithFlam elem aux) +peek ptrStruct = do + aux <- Foreign.peek (ptrToAux ptrStruct) + let Size{sizeNumElems, sizeNumBytes} = flamSize aux + vector <- VSM.unsafeNew sizeNumElems + Foreign.withForeignPtr (fst (VSM.unsafeToForeignPtr0 vector)) $ \ptrVectorElems -> do + Foreign.copyBytes ptrVectorElems (ptrToFlam ptrStruct) sizeNumBytes + vector' <- VS.unsafeFreeze vector + return (WithFlam aux vector') + +-- | Poke structure with flexible array member. +poke :: forall aux elem. + (Storable aux, Storable elem, NumElems elem aux) + => Ptr (WithFlam elem aux) -> WithFlam elem aux -> IO () +poke ptrStruct (WithFlam aux vector) + | sizeNumElems /= VS.length vector = + throwIO $ FlamLengthMismatch sizeNumElems (VS.length vector) + | otherwise = do + Foreign.poke (ptrToAux ptrStruct) aux + VS.unsafeWith vector $ \ptrVectorElems -> do + Foreign.copyBytes (ptrToFlam ptrStruct) ptrVectorElems sizeNumBytes + where + Size{sizeNumElems, sizeNumBytes} = flamSize aux + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +-- | Exception thrown when 'writeRaw' detects a FLAM length mismatch +data FlamLengthMismatch = FlamLengthMismatch { + flamLengthStruct :: Int + , flamLengthProvided :: Int + } + deriving stock (Show) + +instance Exception FlamLengthMismatch + +{------------------------------------------------------------------------------- + Internal helpers +-------------------------------------------------------------------------------} + +ptrToAux :: Ptr (WithFlam elem aux) -> Ptr aux +ptrToAux = Foreign.castPtr + +ptrToFlam :: forall elem aux. + Offset elem aux + => Ptr (WithFlam elem aux) -> Ptr elem +ptrToFlam ptrStruct = Foreign.plusPtr ptrStruct (offset (proxy# @aux)) + +-- Internal. +data Size = Size{ + sizeNumElems :: Int + , sizeNumBytes :: Int + } + +flamSize :: forall (elem :: Type) aux. + (NumElems elem aux, Storable elem) + => aux -> Size +flamSize aux = Size{ + sizeNumElems + , sizeNumBytes = sizeNumElems * Foreign.sizeOf (undefined :: elem) + } + where sizeNumElems = numElems aux diff --git a/src/HsBindgen/Runtime/HasCBitfield.hs b/src/HsBindgen/Runtime/HasCBitfield.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/HasCBitfield.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE MagicHash #-} + +-- | Declarations with C bitfields +-- +-- Most users do not directly need to use @HasCField@, and can use record dot +-- syntax instead. For example, given +-- +-- Given +-- +-- > struct DriverFlags { +-- > unsigned int safe : 1; +-- > unsigned int allocates : 1; +-- > }; +-- +-- @hs-bindgen@ will generate code such that if +-- +-- > flagsPtr :: Ptr DriverFlags +-- +-- then +-- +-- > flagsPtr.driverFlags_allocates :: BitfieldPtr CUInt +-- +-- Module "HsBindgen.Runtime.BitfieldPtr" can be used to interact with +-- these t'BitfieldPtr's; for example: +-- +-- > BitfieldPtr.peek flagsPtr.driverFlags_allocates +-- +-- Bitfields can be chained with regular fields; for example, given +-- +-- > struct Driver { +-- > struct DriverFlags flags; +-- > .. +-- > }; +-- +-- then if +-- +-- > driverPtr :: Ptr Driver +-- +-- then +-- +-- > driverPtr.driver_flags.driverFlags_allocates :: BitfieldPtr CUInt +-- +-- See also "HsBindgen.Runtime.HasCField". +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.HasCBitfield qualified as HasCBitfield +module HsBindgen.Runtime.HasCBitfield ( + HasCBitfield(..) + , offset + , width + , toPtr + , peek + , poke + ) where + +import Data.Kind +import Data.Proxy +import Foreign.Ptr +import GHC.Exts (Proxy#, proxy#) +import GHC.TypeLits + +import HsBindgen.Runtime.BitfieldPtr (BitfieldPtr, mkBitfieldPtr) +import HsBindgen.Runtime.BitfieldPtr qualified as BitfieldPtr +import HsBindgen.Runtime.Marshal qualified as Marshal +import HsBindgen.Runtime.Support.Bitfield (Bitfield) + +-- | Evidence that a C object @a@ has a bit-field with the name @field@. +-- +-- Bit-fields can be part of structs and unions. +-- +-- === Struct +-- +-- If we have the C struct @S@: +-- +-- > struct S { +-- > int x : 2; +-- > int y : 3; +-- > } +-- +-- And an accompanying Haskell datatype @S@: +-- +-- > data S = S { s_x :: CInt, s_y :: CInt } +-- +-- Then we can define two instances +-- +-- > HasCBitfield S "s_x" +-- > HasCBitfield S "s_y" +-- +-- === Union +-- +-- If we have the C union @U@: +-- +-- > union U { +-- > int x : 2; +-- > int y : 3; +-- > } +-- +-- And an accompanying Haskell datatype @U@: +-- +-- > data U = U ... {- details elided -} +-- > ... {- getters and setters elided -} +-- +-- Then we can define two instances +-- +-- > HasCBitfield U "u_x" +-- > HasCBitfield U "u_y" +class HasCBitfield (a :: Type) (field :: Symbol) where + -- | The type of the bit field + type CBitfieldType (a :: Type) (field :: Symbol) :: Type + + -- | The offset (in number of bits) of the bit-field with respect to the parent + -- object. + bitfieldOffset# :: Proxy# a -> Proxy# field -> Int + + -- | The width (in number of bits) of the bit-field. + bitfieldWidth# :: Proxy# a -> Proxy# field -> Int + +{-# INLINE offset #-} +-- | The offset (in number of bits) of the bit-field with respect to the +-- parent object. +offset :: + forall a field. HasCBitfield a field + => Proxy a + -> Proxy field + -> Int +offset = \_ _ -> bitfieldOffset# (proxy# @a) (proxy# @field) + +{-# INLINE width #-} +-- | The width (in number of bits) of the bit-field. +width :: + forall a field. HasCBitfield a field + => Proxy a + -> Proxy field + -> Int +width = \_ _ -> bitfieldWidth# (proxy# @a) (proxy# @field) + +{-# INLINE toPtr #-} +-- | Convert a pointer to a C object to a pointer to one of the object's +-- bit-fields. +toPtr :: + forall a field. ( + Marshal.StaticSize a + , HasCBitfield a field + ) + => Proxy field + -> Ptr a + -> BitfieldPtr (CBitfieldType a field) +toPtr _ ptr = mkBitfieldPtr ptr o w + where + o = bitfieldOffset# (proxy# @a) (proxy# @field) + w = bitfieldWidth# (proxy# @a) (proxy# @field) + +{-# INLINE peek #-} +-- | Using a pointer to a C object, read from one of the object's bit-fields. +peek :: + forall a field. ( + Marshal.StaticSize a + , HasCBitfield a field + , Bitfield (CBitfieldType a field) + ) + => Proxy field + -> Ptr a + -> IO (CBitfieldType a field) +peek field ptr = BitfieldPtr.peek (toPtr field ptr) + +{-# INLINE poke #-} +-- | Using a pointer to a C object, write to one of the object's bit-fields. +poke :: + forall a field. ( + Marshal.StaticSize a + , HasCBitfield a field + , Bitfield (CBitfieldType a field) + ) + => Proxy field + -> Ptr a + -> CBitfieldType a field + -> IO () +poke field ptr val = BitfieldPtr.poke (toPtr field ptr) val diff --git a/src/HsBindgen/Runtime/HasCField.hs b/src/HsBindgen/Runtime/HasCField.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/HasCField.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE MagicHash #-} + +-- | Declarations with C fields +-- +-- Most users do not directly need to use @HasCField@, and can use record dot +-- syntax instead. For example, given +-- +-- > struct DriverInfo { +-- > char* name; +-- > int version; +-- > }; +-- > +-- > struct Driver { +-- > struct DriverInfo info; +-- > }; +-- +-- @hs-bindgen@ will generate code such that if +-- +-- > driverPtr :: Ptr Driver +-- +-- then +-- +-- > driverPtr.driver_version :: Ptr DriverInfo +-- > driverPtr.driver_version.driverInfo_version :: Ptr CInt +-- +-- Note that chaining like this can only be done for nested structs; no actual +-- dereferencing takes place! For example, if we additionally had +-- +-- > struct DriverCode { +-- > .. +-- > }; +-- > +-- > struct Driver { +-- > .. +-- > struct DriverCode* code; +-- > }; +-- > +-- +-- then +-- +-- > driverPtr.driver_code :: Ptr (Ptr DriverCode) +-- +-- (note the double 'Ptr'), which must be dereferenced before any fields of +-- @DriverCode@ can be accessed. +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.HasCField qualified as HasCField +module HsBindgen.Runtime.HasCField ( + -- * Fields + HasCField(..) + , offset + , fromPtr + , peek + , poke + , readRaw + , writeRaw + ) where + +import Data.Kind +import Data.Proxy +import Foreign.Ptr +import Foreign.Storable hiding (peek, poke) +import Foreign.Storable qualified +import GHC.Exts (Proxy#, proxy#) +import GHC.TypeLits + +import HsBindgen.Runtime.Marshal (ReadRaw, WriteRaw) +import HsBindgen.Runtime.Marshal qualified + +-- | Evidence that a C object @a@ has a field with the name @field@. +-- +-- Fields can be part of structs and unions. Typedefs are a degenerate use case. +-- +-- === Struct +-- +-- If we have the C struct @S@: +-- +-- > struct S { +-- > int x; +-- > int y; +-- > } +-- +-- And an accompanying Haskell datatype @S@: +-- +-- > data S = S { s_x :: CInt, s_y :: CInt } +-- +-- Then we can define two instances +-- +-- > HasCField S "s_x" +-- > HasCField S "s_y" +-- +-- === Union +-- +-- If we have the C union @U@: +-- +-- > union U { +-- > int x; +-- > int y; +-- > } +-- +-- And an accompanying Haskell datatype @U@: +-- +-- > data U = U ... {- details elided -} +-- > ... {- getters and setters elided -} +-- +-- Then we can define two instances +-- +-- > HasCField U "u_x" +-- > HasCField U "u_y" +-- +-- === Typedef +-- +-- If we have the C typedef @T@: +-- +-- > typedef int T; +-- +-- And an accompanying Haskell newtype @T@: +-- +-- > newtype T = T { unwrapT :: Int } +-- +-- Then we can define the instance: +-- +-- > HasCField T "unwrapT" +class HasCField (a :: Type) (field :: Symbol) where + type CFieldType (a :: Type) (field :: Symbol) :: Type + + -- | The offset (in number of bytes) of the field with respect to the parent + -- object. + offset# :: Proxy# a -> Proxy# field -> Int + +{-# INLINE offset #-} +-- | The offset (in number of bytes) of the field with respect to the parent +-- object. +offset :: + forall a field. HasCField a field + => Proxy a + -> Proxy field + -> Int +offset = \_ _ -> offset# (proxy# @a) (proxy# @field) + +{-# INLINE fromPtr #-} +-- | Convert a pointer to a C object to a pointer to one of the object's fields. +fromPtr :: + forall a field. HasCField a field + => Proxy field + -> Ptr a + -> Ptr (CFieldType a field) +fromPtr _ ptr = ptr `plusPtr` offset# (proxy# @a) (proxy# @field) + +{-# INLINE peek #-} +-- | Using a pointer to a C object, read from one of the object's fields. +peek :: + (HasCField a field, Storable (CFieldType a field)) + => Proxy field + -> Ptr a + -> IO (CFieldType a field) +peek field ptr = Foreign.Storable.peek (fromPtr field ptr) + +{-# INLINE poke #-} +-- | Using a pointer to a C object, write to one of the object's fields. +poke :: + (HasCField a field, Storable (CFieldType a field)) + => Proxy field + -> Ptr a + -> CFieldType a field + -> IO () +poke field ptr val = Foreign.Storable.poke (fromPtr field ptr) val + +-- | Read a field using a pointer to a C object +{-# INLINE readRaw #-} +readRaw :: + (HasCField a field, ReadRaw (CFieldType a field)) + => Proxy field + -> Ptr a + -> IO (CFieldType a field) +readRaw field ptr = HsBindgen.Runtime.Marshal.readRaw (fromPtr field ptr) + +-- | Write a field using a pointer to a C object +{-# INLINE writeRaw #-} +writeRaw :: + (HasCField a field, WriteRaw (CFieldType a field)) + => Proxy field + -> Ptr a + -> CFieldType a field + -> IO () +writeRaw field ptr = HsBindgen.Runtime.Marshal.writeRaw (fromPtr field ptr) diff --git a/src/HsBindgen/Runtime/HasFFIType.hs b/src/HsBindgen/Runtime/HasFFIType.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/HasFFIType.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP #-} + +module HsBindgen.Runtime.HasFFIType ( + -- * Class + HasFFIType (FFIType, toFFIType, fromFFIType) + -- * Shorthand types + , PtrVoid + , FunPtrVoid + -- * Deriving-via + , ViaIdentity (..) + ) where + +import Prelude as Types (Bool, Char, Double, Float, Int, Word) +import Prelude hiding (Bool, Char, Double, Float, Int, Word) + +import Data.Int as Types (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Void (Void) +import Data.Word as Types (Word16, Word32, Word64, Word8) +import Foreign.C.Error as Types (Errno (..)) +import Foreign.C.Types as Types (CBool (..), CChar (..), CClock (..), + CDouble (..), CFloat (..), CInt (..), + CIntMax (..), CIntPtr (..), CLLong (..), + CLong (..), CPtrdiff (..), CSChar (..), + CSUSeconds (..), CShort (..), CSigAtomic (..), + CSize (..), CTime (..), CUChar (..), + CUInt (..), CUIntMax (..), CUIntPtr (..), + CULLong (..), CULong (..), CUSeconds (..), + CUShort (..), CWchar (..)) +import Foreign.Ptr (castFunPtr, castPtr) +import Foreign.Ptr as Types (FunPtr, IntPtr (..), Ptr, WordPtr (..)) +import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr) +import Foreign.StablePtr as Types (StablePtr) + +import HsBindgen.Runtime.PtrConst as Types (PtrConst, unsafeFromPtr, + unsafeToPtr) + +{------------------------------------------------------------------------------- + Class +-------------------------------------------------------------------------------} + +-- | The 'HasFFIType' class captures Haskell types that can be converted to and +-- from its /FFI type/. +-- +-- A 'HasFFIType' instance declaration for a type @T@, mapping @FFIType T@ to +-- @M.T'@, is valid if @T'@ is legal to appear as an argument or result in +-- @foreign import@ declarations in a context where @M@ is in scope. +-- +-- @foreign import@ declarations only compile if their type is a valid /foreign +-- type/. This depends on the context of which modules are in scope. A @foreign +-- import@ that uses FFI types exclusively will always compile. +-- +-- Foreign types and its sub-kinds are described by the the "Haskell 2010 +-- Language" report. See the "8.4.2 Foreign Types" section of the report for +-- more information: +-- +-- +class HasFFIType a where + type FFIType a :: Type + -- | Convert a type to its FFI type + -- + -- See the 'HasFFIType' class for more information + toFFIType :: a -> FFIType a + -- | Inverse of 'toFFIType' + -- + -- See the 'HasFFIType' class for more information + fromFFIType :: FFIType a -> a + +{------------------------------------------------------------------------------- + Shorthand types +-------------------------------------------------------------------------------} + +-- | 'Ptr' 'Void' +type PtrVoid = Ptr Void + +-- | 'FunPtr' 'Void' +type FunPtrVoid = FunPtr Void + +{------------------------------------------------------------------------------- + Deriving-via +-------------------------------------------------------------------------------} + +type ViaIdentity :: Type -> Type +newtype ViaIdentity a = ViaIdentity a + +instance HasFFIType (ViaIdentity a) where + type FFIType (ViaIdentity a) = a + {-# INLINE toFFIType #-} + toFFIType (ViaIdentity x) = x + {-# INLINE fromFFIType #-} + fromFFIType x = ViaIdentity x + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} + +-- === Prelude === + +deriving via ViaIdentity Char instance HasFFIType Char +deriving via ViaIdentity Int instance HasFFIType Int +deriving via ViaIdentity Double instance HasFFIType Double +deriving via ViaIdentity Float instance HasFFIType Float +deriving via ViaIdentity Bool instance HasFFIType Bool + +-- === Data.Int === + +deriving via ViaIdentity Int8 instance HasFFIType Int8 +deriving via ViaIdentity Int16 instance HasFFIType Int16 +deriving via ViaIdentity Int32 instance HasFFIType Int32 +deriving via ViaIdentity Int64 instance HasFFIType Int64 + +-- === Data.Word === + +deriving via ViaIdentity Word instance HasFFIType Word +deriving via ViaIdentity Word8 instance HasFFIType Word8 +deriving via ViaIdentity Word16 instance HasFFIType Word16 +deriving via ViaIdentity Word32 instance HasFFIType Word32 +deriving via ViaIdentity Word64 instance HasFFIType Word64 + +-- === Foreign.Ptr === + +instance HasFFIType (Ptr a) where + type FFIType (Ptr a) = PtrVoid + {-# INLINE toFFIType #-} + toFFIType = castPtr + {-# INLINE fromFFIType #-} + fromFFIType = castPtr + +instance HasFFIType (FunPtr a) where + type FFIType (FunPtr a) = FunPtrVoid + {-# INLINE toFFIType #-} + toFFIType = castFunPtr + {-# INLINE fromFFIType #-} + fromFFIType = castFunPtr + +deriving via ViaIdentity IntPtr instance HasFFIType IntPtr +deriving via ViaIdentity WordPtr instance HasFFIType WordPtr + +-- === Foreign.StablePtr === + +instance HasFFIType (StablePtr a) where + type FFIType (StablePtr a) = StablePtr Void + {-# INLINE toFFIType #-} + toFFIType = castStablePtr + {-# INLINE fromFFIType #-} + fromFFIType = castStablePtr + +{-# INLINE castStablePtr #-} +castStablePtr :: StablePtr a -> StablePtr b +castStablePtr = castPtrToStablePtr . castStablePtrToPtr + +-- === Foreign.C.ConstPtr === + +instance HasFFIType (PtrConst a) where + type FFIType (PtrConst a) = Ptr Void + {-# INLINE toFFIType #-} + toFFIType = castPtr . unsafeToPtr + {-# INLINE fromFFIType #-} + fromFFIType = unsafeFromPtr . castPtr + +-- === Foreign.C.Error === + +deriving via ViaIdentity Errno instance HasFFIType Errno + +-- === Foreign.C.Types === + +deriving via ViaIdentity CChar instance HasFFIType CChar +deriving via ViaIdentity CSChar instance HasFFIType CSChar +deriving via ViaIdentity CUChar instance HasFFIType CUChar +deriving via ViaIdentity CShort instance HasFFIType CShort +deriving via ViaIdentity CUShort instance HasFFIType CUShort +deriving via ViaIdentity CInt instance HasFFIType CInt +deriving via ViaIdentity CUInt instance HasFFIType CUInt +deriving via ViaIdentity CLong instance HasFFIType CLong +deriving via ViaIdentity CULong instance HasFFIType CULong +deriving via ViaIdentity CPtrdiff instance HasFFIType CPtrdiff +deriving via ViaIdentity CSize instance HasFFIType CSize +deriving via ViaIdentity CWchar instance HasFFIType CWchar +deriving via ViaIdentity CSigAtomic instance HasFFIType CSigAtomic +deriving via ViaIdentity CLLong instance HasFFIType CLLong +deriving via ViaIdentity CULLong instance HasFFIType CULLong +deriving via ViaIdentity CBool instance HasFFIType CBool +deriving via ViaIdentity CIntPtr instance HasFFIType CIntPtr +deriving via ViaIdentity CUIntPtr instance HasFFIType CUIntPtr +deriving via ViaIdentity CIntMax instance HasFFIType CIntMax +deriving via ViaIdentity CUIntMax instance HasFFIType CUIntMax + +-- === Foreign.C.Types : Numeric types === + +deriving via ViaIdentity CClock instance HasFFIType CClock +deriving via ViaIdentity CTime instance HasFFIType CTime +deriving via ViaIdentity CUSeconds instance HasFFIType CUSeconds +deriving via ViaIdentity CSUSeconds instance HasFFIType CSUSeconds + +-- === Foreign.C.Types : Floating types === + +deriving via ViaIdentity CFloat instance HasFFIType CFloat +deriving via ViaIdentity CDouble instance HasFFIType CDouble diff --git a/src/HsBindgen/Runtime/IncompleteArray.hs b/src/HsBindgen/Runtime/IncompleteArray.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/IncompleteArray.hs @@ -0,0 +1,219 @@ +-- | C arrays of unknown size +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.IncompleteArray qualified as IA +module HsBindgen.Runtime.IncompleteArray ( + IncompleteArray -- opaque + , toVector + , fromVector + -- * Pointers + -- $pointers + , toPtr + , toFirstElemPtr + , peekArray + , pokeArray + -- * Construction + , repeat + , fromList + -- * Query + , toList + ) where + +import Prelude hiding (repeat) + +import Data.Coerce (Coercible, coerce) +import Data.Vector.Storable qualified as VS +import Foreign.ForeignPtr (mallocForeignPtrArray, withForeignPtr) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (..)) +import GHC.Records (HasField (..)) + +import HsBindgen.Runtime.IsArray (IsArray (..)) + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | A C array of unknown size +newtype IncompleteArray a = IA (VS.Vector a) + deriving stock (Eq, Show) + +type role IncompleteArray nominal + +-- | /( O(1) /): Get the underlying 'VS.Vector' representation +-- +-- This makes the full 'VS.Vector' API available. +toVector :: + Coercible arrayLike (IncompleteArray a) + => arrayLike + -> VS.Vector a +toVector (coerce -> xs) = xs + +-- | /( O(1) /): Construct from a 'VS.Vector' representation +-- +-- This makes the full 'VS.Vector' API available. +fromVector :: + Coercible arrayLike (IncompleteArray a) + => VS.Vector a + -> arrayLike +fromVector = coerce + +{------------------------------------------------------------------------------- + Pointers +-------------------------------------------------------------------------------} + +-- $pointers +-- +-- In example C code below, @p1@ points to the array @xs@ as a whole, while @p2@ +-- points to the first element of @xs@. +-- +-- > extern int xs[]; +-- > void foo () { +-- > int (*p1)[] = &xs; +-- > int *p2 = &(xs[0]); +-- > } +-- +-- Though the types of @p1@ and @p2@ differ, the /values/ of the pointers (the +-- address they point to) is the same. An array is just a block of contiguous +-- memory storing array elements. @p1@ points to where @xs@ starts, and @p2@ +-- points to where the first element of @xs@ starts, and these addresses are the +-- same. In Haskell, the corresponding types for @p1@ and @p2@ respectively are +-- @'Ptr' ('IncompleteArray' 'Foreign.C.CInt')@ and @'Ptr' 'Foreign.C.CInt'@ +-- respectively. +-- +-- Functions like 'peekArray' require a @'Ptr' ('IncompleteArray' a)@ argument. +-- If the user only has access to a @'Ptr' a@ but they know that is pointing to +-- the first element in an array, then they can use 'toPtr' to convert the +-- pointer before using 'peekArray' on it. Conversely, if the user has access to +-- a @'Ptr' ('IncompleteArray' a)@ but they want to convert it to a @'Ptr' a@, +-- then they can use @'toFirstElemPtr'@. +-- +-- NOTE: with overloaded record dot syntax, syntax like @.toFirstElemPtr@ is +-- also supported. +-- +-- Relevant functions in this module also support pointers of newtypes around +-- 'IncompleteArray', hence the addition of 'Coercible' constraints in many +-- places. For example, we can use 'toPtr' at an 'IncompleteArray' type or we +-- can use 'toPtr' at a newtype around an 'IncompleteArray'. +-- +-- > newtype A = A (IncompleteArray CInt) +-- > toPtr @(IncompleteArray CInt) :: Ptr CInt -> Ptr (IncompleteArray CInt) +-- > toPtr @A :: Ptr CInt -> Ptr A + +-- | 'toFirstElemPtr' for overloaded record dot syntax +instance HasField "toFirstElemPtr" (Ptr (IncompleteArray a)) (Ptr a) where + getField = toFirstElemPtr + +-- | /( O(1) /): Use a pointer to the first element of an array as a pointer to the whole of +-- said array. +-- +-- NOTE: this function does not check that the pointer /is/ actually a pointer +-- to the first element of an array. +toPtr :: + forall arrayLike a. Coercible arrayLike (IncompleteArray a) + => Ptr a + -> Ptr arrayLike +toPtr = castPtr + where + -- The 'Coercible' constraint is unused but that is intentional, so we + -- circumvent the @-Wredundant-constraints@ warning by defining @_unused@. + -- + -- Why is it intentional? The constraint adds a little bit of type safety to + -- the use of 'castPtr', which can normally cast pointers arbitrarily. + _unused = coerce @arrayLike @(IncompleteArray a) + +-- | /( O(1) /): Use a pointer to a whole array as a pointer to the first element of said +-- array. +toFirstElemPtr :: + forall arrayLike a. Coercible arrayLike (IncompleteArray a) + => Ptr arrayLike + -> Ptr a +toFirstElemPtr ptr = castPtr ptr + where + -- The 'Coercible' constraint is unused but that is intentional, so we + -- circumvent the @-Wredundant-constraints@ warning by defining @_unused@. + -- + -- Why is it intentional? The constraint adds a little bit of type safety to + -- the use of 'castPtr', which can normally cast pointers arbitrarily. + _unused = coerce @arrayLike @(IncompleteArray a) + +-- | /( O(n) /): Peek a number of elements from a pointer to an incomplete array. +peekArray :: + forall a arrayLike. (Coercible arrayLike (IncompleteArray a), Storable a) + => Int + -> Ptr arrayLike + -> IO arrayLike +peekArray = peekArrayOff 0 + +-- | /( O(n) /): Peek a number of elements from a pointer to an incomplete array, starting +-- at an offset in terms of a number of array elements into the array pointer. +peekArrayOff :: + forall a arrayLike. (Coercible arrayLike (IncompleteArray a), Storable a) + => Int + -> Int + -> Ptr arrayLike + -> IO arrayLike +peekArrayOff off size ptr = do + fptr <- mallocForeignPtrArray @a size + withForeignPtr fptr $ \(ptr' :: Ptr a) -> do + copyBytes ptr' (castPtr ptr `plusPtr` offBytes) (size * sizeOfA) + vs <- VS.freeze (VS.MVector size fptr) + return $ coerce (IA vs) + where + sizeOfA = sizeOf (undefined :: a) + offBytes = sizeOfA * off + +-- | /( O(n) /): Poke a number of elements to a pointer to an incomplete array. +pokeArray :: + forall a arrayLike. (Coercible arrayLike (IncompleteArray a), Storable a) + => Ptr arrayLike + -> arrayLike + -> IO () +pokeArray = pokeArrayOff 0 + +-- | /( O(n) /): Poke a number of elements to a pointer to an incomplete array, starting at +-- an offset in terms of a number of array elements into the array pointer. +pokeArrayOff :: + forall a arrayLike. (Coercible arrayLike (IncompleteArray a), Storable a) + => Int + -> Ptr arrayLike + -> arrayLike + -> IO () +pokeArrayOff off ptr (coerce -> IA vs) = do + VS.MVector size fptr <- VS.unsafeThaw vs + withForeignPtr fptr $ \(ptr' :: Ptr a) -> + copyBytes (castPtr ptr) (ptr' `plusPtr` offBytes) (size * sizeOfA) + where + sizeOfA = sizeOf (undefined :: a) + offBytes = sizeOfA * off + +instance IsArray (IncompleteArray a) where + type Elem (IncompleteArray a) = a + -- | /( O(n) /) + withElemPtr (IA v) k = do + -- we copy the data, as e.g. @int fun(int xs[])@ may mutate it. + VS.MVector _ fptr <- VS.thaw v + withForeignPtr fptr $ \(ptr :: Ptr a) -> k ptr + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | /( O(n) /) +repeat :: Storable a => Int -> a -> IncompleteArray a +repeat n x = IA (VS.replicate n x) + +-- | /( O(n) /) +fromList :: Storable a => [a] -> IncompleteArray a +fromList xs = IA (VS.fromList xs) + +{------------------------------------------------------------------------------- + Query +-------------------------------------------------------------------------------} + +-- | /( O(n) /) +toList :: Storable a => IncompleteArray a -> [a] +toList (IA v) = VS.toList v diff --git a/src/HsBindgen/Runtime/IsArray.hs b/src/HsBindgen/Runtime/IsArray.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/IsArray.hs @@ -0,0 +1,17 @@ +-- | Class for C arrays (of known or unknown size) +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.IsArray qualified as IsA +module HsBindgen.Runtime.IsArray ( + IsArray (..) + ) where + +import Data.Kind (Type) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) + +class IsArray a where + type Elem a :: Type + withElemPtr :: Storable (Elem a) => a -> (Ptr (Elem a) -> IO r) -> IO r diff --git a/src/HsBindgen/Runtime/LibC.hs b/src/HsBindgen/Runtime/LibC.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/LibC.hs @@ -0,0 +1,348 @@ +-- | Types used by the C standard library external binding specification +-- +-- Intended for qualified import. +-- +-- > import HsBindgen.Runtime.LibC qualified as LibC +module HsBindgen.Runtime.LibC ( + -- * Primitive types + -- $PrimitiveTypes + Foreign.C.CChar(..) + , Foreign.C.CUChar(..) + , Foreign.C.CShort(..) + , Foreign.C.CUShort(..) + , Foreign.C.CInt(..) + , Foreign.C.CUInt(..) + , Foreign.C.CLong(..) + , Foreign.C.CULong(..) + , Foreign.C.CLLong(..) + , Foreign.C.CULLong(..) + , Foreign.C.CFloat(..) + , Foreign.C.CDouble(..) + , Foreign.C.CString + + -- * Boolean types + -- $BooleanTypes + , Foreign.C.CBool(..) + + -- * Integral types + -- $IntegralTypes + , Data.Int.Int8 + , Data.Int.Int16 + , Data.Int.Int32 + , Data.Int.Int64 + , Data.Word.Word8 + , Data.Word.Word16 + , Data.Word.Word32 + , Data.Word.Word64 + , Foreign.C.CIntMax(..) + , Foreign.C.CUIntMax(..) + , Foreign.C.CIntPtr(..) + , Foreign.C.CUIntPtr(..) + + -- * Floating types + -- $FloatingTypes + , LibC.CFenvT + , LibC.CFexceptT + + -- * Standard definitions + -- $StandardDefinitions + , Foreign.C.CSize(..) + , Foreign.C.CPtrdiff(..) + + -- * Non-local jump types + -- $NonLocalJumpTypes + , Foreign.C.CJmpBuf + + -- * Wide character types + -- $WideCharacterTypes + , Foreign.C.CWchar(..) + , LibC.CWintT(..) + , LibC.CMbstateT + , LibC.CWctransT(..) + , LibC.CWctypeT(..) + , LibC.CChar16T(..) + , LibC.CChar32T(..) + + -- * Localization types + -- $LocalizationTypes + + -- * Time types + -- $TimeTypes + , Foreign.C.CTime(..) + , Foreign.C.CClock(..) + , LibC.CTm(..) + + -- * File types + -- $FileTypes + , Foreign.C.CFile + , Foreign.C.CFpos + + -- * Signal types + -- $SignalTypes + , Foreign.C.CSigAtomic(..) + ) where + +import Data.Int qualified +import Data.Word qualified +import Foreign.C qualified + +import HsBindgen.Runtime.Support.LibC.Auxiliary as LibC + +{- + The binding specification for the types in this module is defined in + @HsBindgen.BindingSpec.Private.Stdlib@ in the @hs-bindgen:internal@ library, + in the same order. + + References in chronological order: + - https://github.com/well-typed/hs-bindgen/issues/293 + - https://github.com/well-typed/hs-bindgen/issues/478 + - https://github.com/well-typed/hs-bindgen/pull/957 + - https://github.com/well-typed/hs-bindgen/issues/1123 +-} + +{------------------------------------------------------------------------------- + Primitive types +-------------------------------------------------------------------------------} + +-- $PrimitiveTypes +-- +-- The following types are available in all C standards. The corresponding +-- Haskell types are defined in @base@ with platform-specific implementations. +-- +-- Integral types: +-- +-- * @char@ corresponds to Haskell type 'Foreign.C.CChar'. +-- * @unsigned char@ corresponds to Haskell type 'Foreign.C.CUChar'. +-- * @short@ corresponds to Haskell type 'Foreign.C.CShort'. +-- * @unsigned short@ corresponds to Haskell type 'Foreign.C.CUShort'. +-- * @int@ corresponds to Haskell type 'Foreign.C.CInt'. +-- * @unsigned int@ corresponds to Haskell type 'Foreign.C.CUInt'. +-- * @long@ corresponds to Haskell type 'Foreign.C.CLong'. +-- * @unsigned long@ corresponds to Haskell type 'Foreign.C.CULong'. +-- * @long long@ corresponds to Haskell type 'Foreign.C.CLLong'. +-- * @unsigned long long@ corresponds to Haskell type 'Foreign.C.CULLong'. +-- +-- Floating types: +-- +-- * @float@ corresponds to Haskell type 'Foreign.C.CFloat'. +-- * @double@ corresponds to Haskell type 'Foreign.C.CDouble'. +-- * @long double@ is not yet supported. +-- +-- Other types: +-- +-- * @char*@ corresponds to Haskell type 'Foreign.C.CString'. + +{------------------------------------------------------------------------------- + Boolean types +-------------------------------------------------------------------------------} + +-- $BooleanTypes +-- +-- Boolean data types have integral representations where @0@ represents 'False' +-- and @1@ represents 'True'. +-- +-- C standards prior to C99 did not include a boolean type. C99 defined +-- @_Bool@, which was deprecated in C23. C23 defines a @bool@ type. Relevant +-- macros are defined in the @stdbool.h@ header file. +-- +-- 'Foreign.C.CBool' is defined in @base@ with a platform-specific +-- implementation. It should be compatible with boolean types across all of the +-- C standards. Only values @0@ and @1@ may be used even though the +-- representation allows for other values. + +{------------------------------------------------------------------------------- + Integral types +-------------------------------------------------------------------------------} + +-- $IntegralTypes +-- +-- The following C types are available since C99 and are provided by the +-- @stdint.h@ and @inttypes.h@ header files. +-- +-- * @int8_t@ is a signed integral type with exactly 8 bits. 'Data.Int.Int8' is +-- the corresponding Haskell type. +-- * @int16_t@ is a signed integral type with exactly 16 bits. 'Data.Int.Int16' +-- is the corresponding Haskell type. +-- * @int32_t@ is a signed integral type with exactly 32 bits. 'Data.Int.Int32' +-- is the corresponding Haskell type. +-- * @int64_t@ is a signed integral type with exactly 64 bits. 'Data.Int.Int64' +-- is the corresponding Haskell type. +-- * @uint8_t@ is an unsigned integral type with exactly 8 bits. +-- 'Data.Word.Word8' is the corresponding Haskell type. +-- * @uint16_t@ is an unsigned integral type with exactly 16 bits. +-- 'Data.Word.Word16' is the corresponding Haskell type. +-- * @uint32_t@ is an unsigned integral type with exactly 32 bits. +-- 'Data.Word.Word32' is the corresponding Haskell type. +-- * @uint64_t@ is an unsigned integral type with exactly 64 bits. +-- 'Data.Word.Word64' is the corresponding Haskell type. +-- * @int_least8_t@ is a signed integral type with at least 8 bits, such that no +-- other signed integral type exists with a smaller size and at least 8 bits. +-- 'Data.Int.Int8' is the corresponding Haskell type. +-- * @int_least16_t@ is a signed integral type with at least 16 bits, such that +-- no other signed integral type exists with a smaller size and at least 16 +-- bits. 'Data.Int.Int16' is the corresponding Haskell type. +-- * @int_least32_t@ is a signed integral type with at least 32 bits, such that +-- no other signed integral type exists with a smaller size and at least 32 +-- bits. 'Data.Int.Int32' is the corresponding Haskell type. +-- * @int_least64_t@ is a signed integral type with at least 64 bits, such that +-- no other signed integral type exists with a smaller size and at least 64 +-- bits. 'Data.Int.Int64' is the corresponding Haskell type. +-- * @uint_least8_t@ is an unsigned integral type with at least 8 bits, such +-- that no other unsigned integral type exists with a smaller size and at +-- least 8 bits. 'Data.Word.Word8' is the corresponding Haskell type. +-- * @uint_least16_t@ is an unsigned integral type with at least 16 bits, such +-- that no other unsigned integral type exists with a smaller size and at +-- least 16 bits. 'Data.Word.Word16' is the corresponding Haskell type. +-- * @uint_least32_t@ is an unsigned integral type with at least 32 bits, such +-- that no other unsigned integral type exists with a smaller size and at +-- least 32 bits. 'Data.Word.Word32' is the corresponding Haskell type. +-- * @uint_least64_t@ is an unsigned integral type with at least 64 bits, such +-- that no other unsigned integral type exists with a smaller size and at +-- least 64 bits. 'Data.Word.Word64' is the corresponding Haskell type. +-- * @int_fast8_t@ is a signed integral type with at least 8 bits, such that it +-- is at least as fast as any other signed integral type that has at least 8 +-- bits. 'Data.Int.Int8' is the corresponding Haskell type. +-- * @int_fast16_t@ is a signed integral type with at least 16 bits, such that +-- it is at least as fast as any other signed integral type that has at least +-- 16 bits. 'Data.Int.Int16' is the corresponding Haskell type. +-- * @int_fast32_t@ is a signed integral type with at least 32 bits, such that +-- it is at least as fast as any other signed integral type that has at least +-- 32 bits. 'Data.Int.Int32' is the corresponding Haskell type. +-- * @int_fast64_t@ is a signed integral type with at least 64 bits, such that +-- it is at least as fast as any other signed integral type that has at least +-- 64 bits. 'Data.Int.Int64' is the corresponding Haskell type. +-- * @uint_fast8_t@ is an unsigned integral type with at least 8 bits, such that +-- it is at least as fast as any other unsigned integral type that has at +-- least 8 bits. 'Data.Word.Word8' is the corresponding Haskell type. +-- * @uint_fast16_t@ is an unsigned integral type with at least 16 bits, such +-- that it is at least as fast as any other unsigned integral type that has at +-- least 16 bits. 'Data.Word.Word16' is the corresponding Haskell type. +-- * @uint_fast32_t@ is an unsigned integral type with at least 32 bits, such +-- that it is at least as fast as any other unsigned integral type that has at +-- least 32 bits. 'Data.Word.Word32' is the corresponding Haskell type. +-- * @uint_fast64_t@ is an unsigned integral type with at least 64 bits, such +-- that it is at least as fast as any other unsigned integral type that has at +-- least 64 bits. 'Data.Word.Word64' is the corresponding Haskell type. +-- * @intmax_t@ is the signed integral type with the maximum width supported. +-- 'Foreign.C.CIntMax', defined in @base@ with a platform-specific +-- implementation, is the corresponding Haskell type. +-- * @uintmax_t@ is the unsigned integral type with the maximum width supported. +-- 'Foreign.C.CUIntMax', defined in @base@ with a platform-specific +-- implementation, is the corresponding Haskell type. +-- * @intptr_t@ is a signed integral type capable of holding a value converted +-- from a void pointer and then be converted back to that type with a value +-- that compares equal to the original pointer. 'Foreign.C.CIntPtr', defined +-- in @base@ with a platform-specific implementation, is the corresponding +-- Haskell type. +-- * @uintptr_t@ is an unsigned integral type capable of holding a value +-- converted from a void pointer and then be converted back to that type with +-- a value that compares equal to the original pointer. 'Foreign.C.CUIntPtr', +-- defined in @base@ with a platform-specific implementation, is the +-- corresponding Haskell type. + +{------------------------------------------------------------------------------- + Floating types +-------------------------------------------------------------------------------} + +-- $FloatingTypes +-- +-- @float_t@, defined in the @math.h@ header file, is not supported yet because +-- it uses @long double@. +-- +-- @double_t@, defined in the @math.h@ header file, is not supported yet because +-- it uses @long double@. + +{------------------------------------------------------------------------------- + Standard definitions +-------------------------------------------------------------------------------} + +-- $StandardDefinitions +-- +-- @size_t@ is an unsigned integral type used to represent the size of objects +-- in memory and dereference elements of an array. It is defined in the +-- @stddef.h@ header file, and it is made available in many other header files +-- that use it. 'Foreign.C.CSize', defined in @base@ with a platform-specific +-- implementation, is the corresponding Haskell type. +-- +-- @ptrdiff_t@ is a type that represents the result of pointer subtraction. It +-- is defined in the @stddef.h@ header file. 'Foreign.C.CPtrdiff`, defined in +-- @base@ with a platform-specific implementation, is the corresponding Haskell +-- type. +-- +-- @max_align_t@, defined in the @stddef.h@ header from C11, is not supported +-- yet because it uses @long double@. + +{------------------------------------------------------------------------------- + Non-local jump types +-------------------------------------------------------------------------------} + +-- $NonLocalJumpTypes +-- +-- @jmp_buf@ holds information to restore the calling environment. It is +-- defined in the @setjmp.h@ header file. 'Foreign.C.CJmpBuf', defined in +-- @base@ as an opaque type, may only be used with a 'Foreign.Ptr.Ptr'. + +{------------------------------------------------------------------------------- + Wide character types +-------------------------------------------------------------------------------} + +-- $WideCharacterTypes +-- +-- @wchar_t@ represents wide characters. It is available since C95. It is +-- defined in the @stddef.h@ and @wchar.h@ header files, and it is made +-- available in other header files that use it. 'Foreign.C.CWchar', defined in +-- @base@ with a platform-specific implementation, is the corresponding Haskell +-- type. + +{------------------------------------------------------------------------------- + Localization types +-------------------------------------------------------------------------------} + +-- $LocalizationTypes +-- +-- @struct lconv@, defined in the @locale.h@ header file, is not supported yet +-- because fields differ across C standards. + +{------------------------------------------------------------------------------- + Time types +-------------------------------------------------------------------------------} + +-- $TimeTypes +-- +-- @time_t@ represents a point in time. It is not portable, as libraries may +-- use different time representations. It is defined in the @time.h@ header +-- file, and it is made available in other header files that use it. +-- 'Foreign.C.CTime', defined in @base@ with a platform-specific implementation, +-- is the corresponding Haskell type. +-- +-- @clock_t@ represents clock tick counts, in units of time of a constant but +-- system-specific duration. It is defined in the @time.h@ header file, and it +-- is made available in other header files that use it. 'Foreign.C.CClock', +-- defined in @base@ with a platform-specific implementation, is the +-- corresponding Haskell type. + +{------------------------------------------------------------------------------- + File types +-------------------------------------------------------------------------------} + +-- $FileTypes +-- +-- @FILE@ identifies and contains information that controls a stream. It is +-- defined in the @stdio.h@ header file, and it is made available in other +-- header files that use it. 'Foreign.C.CFile', defined in @base@ as an opaque +-- type, may only be used with a 'Foreign.Ptr.Ptr'. +-- +-- @fpos_t@ contains information that specifies a position within a file. It is +-- defined in the @stdio.h@ header file. 'Foreign.C.CFpos', defined in @base@ +-- as an opaque type, may only be used with a 'Foreign.Ptr.Ptr'. + +{------------------------------------------------------------------------------- + Signal types +-------------------------------------------------------------------------------} + +-- $SignalTypes +-- +-- @sig_atomic_t@ is an integral type that represents an object that can be +-- accessed as an atomic entity even in the presence of asynchronous signals. +-- It is defined in the @signal.h@ header file. 'Foreign.C.CSigAtomic', defined +-- in @base@ with a platform-specific implementation. diff --git a/src/HsBindgen/Runtime/Macro.hs b/src/HsBindgen/Runtime/Macro.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Macro.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Raw macros: C macros kept as their token spelling, untyped. +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Macro qualified as Macro +module HsBindgen.Runtime.Macro ( + -- * Type + Raw (..) + , Params (..) + , Variadic (..) + -- * Construction + , objectLike + , functionLike + , variadic + , variadicNamed + -- * Rendering + , render + ) where + +import Data.List qualified as List + +{------------------------------------------------------------------------------- + Type +-------------------------------------------------------------------------------} + +-- | A macro that was not typechecked; only its token spellings are known. +-- +-- The name is part of the value so that 'render' can produce a definition +-- rather than just a body. +-- +-- @a@ is the representation of a single token. +-- +-- Generated code uses @'Raw' 'String'@. +data Raw a = Raw { + name :: a + , params :: Params a + , body :: [a] + } + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | The parameter list of a macro. +data Params a = + -- | Object-like macro: no parameter list at all. + -- + -- Note that this differs from @'Params' [] 'NotVariadic'@, the empty + -- parameter list of @#define NOW() 0@. + NoParams + -- | Function-like macro: the named parameters, and how the list ends. + | Params [a] (Variadic a) + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | How the parameter list of a function-like macro ends. +-- +-- Variadic macros are technically a C99 feature, but @libclang@ has backported +-- them to C89 as well. We follow @libclang@ behaviour here, and support +-- variadic macros regardless of the C standard that is configured (C89 is the +-- first standard). +-- +-- +data Variadic a = + -- | @#define F(x, y)@: the macro takes exactly its named parameters. + NotVariadic + -- | @#define F(x, ...)@: the trailing arguments are @__VA_ARGS__@. + | Ellipsis + -- | @#define F(x, args...)@: the trailing arguments are named. + -- + -- This is the GNU named-variadic extension; the name replaces + -- @__VA_ARGS__@ in the body. It is a distinct constructor because it is + -- /not/ equivalent to 'Ellipsis' with the name as its last parameter: + -- @#define F(args...) g(args)@ passes every argument to @g@, whereas + -- @#define F(args, ...) g(args)@ passes only the first. + -- + -- + | NamedEllipsis a + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Construct an object-like macro from its name and body token spellings. +objectLike :: String -> [String] -> Raw String +objectLike name body = Raw { + name = name + , params = NoParams + , body = body + } + +-- | Construct a function-like macro from its name, parameter names, and body +-- token spellings. +functionLike :: String -> [String] -> [String] -> Raw String +functionLike name params body = + mkFunctionLike name params NotVariadic body + +-- | Like 'functionLike', but for a macro whose parameter list ends in @...@. +variadic :: String -> [String] -> [String] -> Raw String +variadic name params body = + mkFunctionLike name params Ellipsis body + +-- | Like 'variadic', but for the GNU named-variadic form: the third argument +-- is the name that stands for the trailing arguments. +-- +-- @#define LOG(fmt, args...) printf(fmt, args)@ is +-- +-- > variadicNamed "LOG" ["fmt"] "args" +-- > ["printf", "(", "fmt", ",", "args", ")"] +variadicNamed :: String -> [String] -> String -> [String] -> Raw String +variadicNamed name params ellipsisName body = + mkFunctionLike name params (NamedEllipsis ellipsisName) body + +mkFunctionLike :: String -> [String] -> Variadic String -> [String] -> Raw String +mkFunctionLike name params variadicity body = Raw { + name = name + , params = Params params variadicity + , body = body + } + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +-- | Render a macro as a @#define@ directive. +-- +-- >>> render (functionLike "ADD" ["x", "y"] ["x", "+", "y"]) +-- "#define ADD(x, y) x + y" +-- +-- Whitespace is not stored, so the result is canonical: tokens are separated by +-- a single space, parameters by a comma and a space. @#define ADD(x,y) x+y@ +-- renders as above. +render :: Raw String -> String +render raw = + "#define " <> raw.name <> renderParams raw.params <> renderBody raw.body + +renderParams :: Params String -> String +renderParams NoParams = "" +renderParams (Params names variadicity) = + "(" <> List.intercalate ", " (names ++ renderVariadic variadicity) <> ")" + +-- | Render the end of a parameter list, as the names that follow the named +-- parameters. +renderVariadic :: Variadic String -> [String] +renderVariadic = \case + NotVariadic -> [] + Ellipsis -> ["..."] + NamedEllipsis nm -> [nm <> "..."] + +-- | Render a body, including the space separating it from what precedes it. +-- +-- An empty body renders as the empty text, so that @#define FOO@ does not gain +-- a trailing space. +renderBody :: [String] -> String +renderBody [] = "" +renderBody ts = " " <> unwords ts diff --git a/src/HsBindgen/Runtime/Marshal.hs b/src/HsBindgen/Runtime/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Marshal.hs @@ -0,0 +1,471 @@ +-- | Marshaling and serialization +-- +-- 'Storable' requires that values can be read and written. This module +-- generalizes 'Storable' into three classes: 'ReadRaw' (read functions), +-- 'WriteRaw' (write functions), and 'StaticSize' (size and alignment). This +-- allows defining read-only and write-only instances, which is not possible +-- with just 'Storable'. +-- +-- [Read-only instances] might be necessary if the C struct is larger than the +-- Haskell struct. In this case we can read it but not write it, unless there +-- is a way to compute the missing C fields, or unless writes are allowed to +-- be partial. +-- +-- [Write-only instances] might be necessary if the Haskell struct is larger +-- than the C struct. In this case we can write it but not read it, unless +-- there is a way to compute the missing Haskell fields. +-- +-- One example of a read-only struct is 'HsBindgen.Runtime.LibC.CTm'. The +-- Haskell datatype only defines the fields that are described in the C language +-- standard, but there are often implementation-defined additional fields. As +-- the C struct is larger than the Haskell struct, the Haskell struct has +-- read-only marshalling instances only. +-- +-- For more details, see https://github.com/well-typed/hs-bindgen/issues/649. +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.Marshal qualified as Marshal +module HsBindgen.Runtime.Marshal ( + -- * Type Classes + StaticSize(..) + , ReadRaw(..) + , WriteRaw(..) + , EquivStorable(..) + + -- * Utility Functions + , readRawByteOff + , writeRawByteOff + , readRawElemOff + , writeRawElemOff + , maybeReadRaw + , with + , withZero + , new + , newZero + ) where + +import Data.Complex (Complex ((:+))) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Proxy (Proxy (Proxy)) +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign.C qualified as C +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Marshal.Alloc qualified as Alloc +import Foreign.Marshal.Utils qualified as Utils +import Foreign.Ptr (FunPtr, Ptr) +import Foreign.Ptr qualified as Ptr +import Foreign.StablePtr (StablePtr) +import Foreign.Storable (Storable) +import Foreign.Storable qualified as Storable +import GHC.ForeignPtr (mallocForeignPtrAlignedBytes) + +import HsBindgen.Runtime.PtrConst (PtrConst) + +{------------------------------------------------------------------------------- + Type Classes +-------------------------------------------------------------------------------} + +-- | Size and alignment for values that have a static size in memory +-- +-- Types that are instances of 'Storable' can derive this instance. +class StaticSize a where + + -- | Storage requirements (bytes) + staticSizeOf :: Proxy a -> Int + + default staticSizeOf :: Storable a => Proxy a -> Int + staticSizeOf _proxy = Storable.sizeOf @a undefined + + -- | Alignment (bytes) + staticAlignment :: Proxy a -> Int + + default staticAlignment :: Storable a => Proxy a -> Int + staticAlignment _proxy = Storable.alignment @a undefined + +-- | Values that can be read from memory +-- +-- Types that are instances of 'Storable' can derive this instance. +class ReadRaw a where + + -- | Read a value from the given memory location + -- + -- This function might require a properly aligned address to function + -- correctly, depending on the architecture. + readRaw :: Ptr a -> IO a + + default readRaw :: Storable a => Ptr a -> IO a + readRaw = Storable.peek + +-- | Values that can be written to memory +-- +-- Types that are instances of 'Storable' can derive this instance. +class WriteRaw a where + + -- | Write a value to the given memory location + -- + -- This function might require a properly aligned address to function + -- correctly, depending on the architecture. + writeRaw :: Ptr a -> a -> IO () + + default writeRaw :: Storable a => Ptr a -> a -> IO () + writeRaw = Storable.poke + +-- | Type used to derive a 'Storable' instance when the type has 'StaticSize', +-- 'ReadRaw', and 'WriteRaw' instances +-- +-- Use the @DerivingVia@ GHC extension as follows: +-- +-- @ +-- {-# LANGUAGE DerivingVia #-} +-- +-- data Foo = Foo { ... } +-- deriving Storable via EquivStorable Foo +-- @ +newtype EquivStorable a = EquivStorable a + +instance + (ReadRaw a, StaticSize a, WriteRaw a) + => Storable (EquivStorable a) + where + sizeOf _ = staticSizeOf @a undefined + alignment _ = staticAlignment @a undefined + + peek ptr = EquivStorable <$> readRaw (Ptr.castPtr ptr) + + poke ptr (EquivStorable x) = writeRaw (Ptr.castPtr ptr) x + +{------------------------------------------------------------------------------- + Utility Functions +-------------------------------------------------------------------------------} + +-- | Read a value from the given memory location, given by a base address and an +-- offset +readRawByteOff :: ReadRaw a => Ptr b -> Int -> IO a +readRawByteOff ptr off = readRaw (ptr `Ptr.plusPtr` off) + +-- | Write a value to the given memory location, given by a base address and an +-- offset +writeRawByteOff :: WriteRaw a => Ptr b -> Int -> a -> IO () +writeRawByteOff ptr off = writeRaw (ptr `Ptr.plusPtr` off) + +-- | Read a value from a memory area regarded as an array of values of the same +-- kind +-- +-- The first argument specifies the start address of the array. The second +-- specifies the (zero-based) index into the array. +readRawElemOff :: forall a. (ReadRaw a, StaticSize a) => Ptr a -> Int -> IO a +readRawElemOff ptr off = readRawByteOff ptr $ off * staticSizeOf @a Proxy + +-- | Write a value to a memory area regarded as an array of values of the same +-- kind +-- +-- The first argument specifies the start address of the array. The second +-- specifies the (zero-based) index into the array. +writeRawElemOff :: forall a. + (StaticSize a, WriteRaw a) + => Ptr a + -> Int + -> a + -> IO () +writeRawElemOff ptr off = writeRawByteOff ptr $ off * staticSizeOf @a Proxy + +-- | Read a value from memory when passed a non-null pointer +maybeReadRaw :: ReadRaw a => Ptr a -> IO (Maybe a) +maybeReadRaw ptr + | ptr == Ptr.nullPtr = return Nothing + | otherwise = Just <$> readRaw ptr + +-- | Allocate local memory, write the specified value, and call a function with +-- the pointer +-- +-- The allocated memory is aligned. +-- +-- Memory that is not written to by 'Storable.poke' may contain arbitrary data. +-- +-- The allocated memory is freed when the function terminates, either normally +-- or via an exception. The passed pointer must therefore /not/ be used after +-- this. +with :: forall a b. + (StaticSize a, WriteRaw a) + => a + -> (Ptr a -> IO b) + -> IO b +with x f = Alloc.allocaBytesAligned size align$ \ptr -> do + writeRaw ptr x + f ptr + where + size, align :: Int + size = staticSizeOf @a Proxy + align = staticAlignment @a Proxy + +-- | Allocate local memory, write the specified value, and call a function with +-- the pointer +-- +-- The allocated memory is aligned. +-- +-- The memory is filled with bytes of value zero before the value is written. +-- Memory that is not written to by 'Storable.poke' contains zeros, not +-- arbitrary data. +-- +-- The allocated memory is freed when the function terminates, either normally +-- or via an exception. The passed pointer must therefore /not/ be used after +-- this. +withZero :: forall a b. + (StaticSize a, WriteRaw a) + => a + -> (Ptr a -> IO b) + -> IO b +withZero x f = Alloc.allocaBytesAligned size align$ \ptr -> do + Utils.fillBytes ptr 0 size + writeRaw ptr x + f ptr + where + size, align :: Int + size = staticSizeOf @a Proxy + align = staticAlignment @a Proxy + +-- | Allocate memory, write the specified value, and the 'ForeignPtr' +-- +-- The allocated memory is aligned. +-- +-- Memory that is not written to by 'writeRaw' may contain arbitrary data. +new :: forall a. + (StaticSize a, WriteRaw a) + => a + -> IO (ForeignPtr a) +new x = do + fptr <- mallocForeignPtrAlignedBytes size align + withForeignPtr fptr $ \ptr -> writeRaw ptr x + return fptr + where + size, align :: Int + size = staticSizeOf @a Proxy + align = staticAlignment @a Proxy + +-- | Allocate memory, write the specified value, and the 'ForeignPtr' +-- +-- The allocated memory is aligned. +-- +-- The memory is filled with bytes of value zero before the value is written. +-- Memory that is not written to by 'writeRaw' contains zeros, not arbitrary +-- data. +newZero :: forall a. + (StaticSize a, WriteRaw a) + => a + -> IO (ForeignPtr a) +newZero x = do + fptr <- mallocForeignPtrAlignedBytes size align + withForeignPtr fptr $ \ptr -> do + Utils.fillBytes ptr 0 size + writeRaw ptr x + return fptr + where + size, align :: Int + size = staticSizeOf @a Proxy + align = staticAlignment @a Proxy + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} + +instance StaticSize C.CChar +instance ReadRaw C.CChar +instance WriteRaw C.CChar + +instance StaticSize C.CSChar +instance ReadRaw C.CSChar +instance WriteRaw C.CSChar + +instance StaticSize C.CUChar +instance ReadRaw C.CUChar +instance WriteRaw C.CUChar + +instance StaticSize C.CShort +instance ReadRaw C.CShort +instance WriteRaw C.CShort + +instance StaticSize C.CUShort +instance ReadRaw C.CUShort +instance WriteRaw C.CUShort + +instance StaticSize C.CInt +instance ReadRaw C.CInt +instance WriteRaw C.CInt + +instance StaticSize C.CUInt +instance ReadRaw C.CUInt +instance WriteRaw C.CUInt + +instance StaticSize C.CLong +instance ReadRaw C.CLong +instance WriteRaw C.CLong + +instance StaticSize C.CULong +instance ReadRaw C.CULong +instance WriteRaw C.CULong + +instance StaticSize C.CPtrdiff +instance ReadRaw C.CPtrdiff +instance WriteRaw C.CPtrdiff + +instance StaticSize C.CSize +instance ReadRaw C.CSize +instance WriteRaw C.CSize + +instance StaticSize C.CWchar +instance ReadRaw C.CWchar +instance WriteRaw C.CWchar + +instance StaticSize C.CSigAtomic +instance ReadRaw C.CSigAtomic +instance WriteRaw C.CSigAtomic + +instance StaticSize C.CLLong +instance ReadRaw C.CLLong +instance WriteRaw C.CLLong + +instance StaticSize C.CULLong +instance ReadRaw C.CULLong +instance WriteRaw C.CULLong + +instance StaticSize C.CBool +instance ReadRaw C.CBool +instance WriteRaw C.CBool + +instance StaticSize C.CIntPtr +instance ReadRaw C.CIntPtr +instance WriteRaw C.CIntPtr + +instance StaticSize C.CUIntPtr +instance ReadRaw C.CUIntPtr +instance WriteRaw C.CUIntPtr + +instance StaticSize C.CIntMax +instance ReadRaw C.CIntMax +instance WriteRaw C.CIntMax + +instance StaticSize C.CUIntMax +instance ReadRaw C.CUIntMax +instance WriteRaw C.CUIntMax + +instance StaticSize C.CClock +instance ReadRaw C.CClock +instance WriteRaw C.CClock + +instance StaticSize C.CTime +instance ReadRaw C.CTime +instance WriteRaw C.CTime + +instance StaticSize C.CUSeconds +instance ReadRaw C.CUSeconds +instance WriteRaw C.CUSeconds + +instance StaticSize C.CSUSeconds +instance ReadRaw C.CSUSeconds +instance WriteRaw C.CSUSeconds + +instance StaticSize C.CFloat +instance ReadRaw C.CFloat +instance WriteRaw C.CFloat + +instance StaticSize C.CDouble +instance ReadRaw C.CDouble +instance WriteRaw C.CDouble + +instance StaticSize (Ptr a) +instance ReadRaw (Ptr a) +instance WriteRaw (Ptr a) + +instance StaticSize (PtrConst a) +instance ReadRaw (PtrConst a) +instance WriteRaw (PtrConst a) + +instance StaticSize (FunPtr a) +instance ReadRaw (FunPtr a) +instance WriteRaw (FunPtr a) + +instance StaticSize (StablePtr a) +instance ReadRaw (StablePtr a) +instance WriteRaw (StablePtr a) + +instance StaticSize Int8 +instance ReadRaw Int8 +instance WriteRaw Int8 + +instance StaticSize Int16 +instance ReadRaw Int16 +instance WriteRaw Int16 + +instance StaticSize Int32 +instance ReadRaw Int32 +instance WriteRaw Int32 + +instance StaticSize Int64 +instance ReadRaw Int64 +instance WriteRaw Int64 + +instance StaticSize Word8 +instance ReadRaw Word8 +instance WriteRaw Word8 + +instance StaticSize Word16 +instance ReadRaw Word16 +instance WriteRaw Word16 + +instance StaticSize Word32 +instance ReadRaw Word32 +instance WriteRaw Word32 + +instance StaticSize Word64 +instance ReadRaw Word64 +instance WriteRaw Word64 + +instance StaticSize Int +instance ReadRaw Int +instance WriteRaw Int + +instance StaticSize Word +instance ReadRaw Word +instance WriteRaw Word + +instance StaticSize Float +instance ReadRaw Float +instance WriteRaw Float + +instance StaticSize Double +instance ReadRaw Double +instance WriteRaw Double + +instance StaticSize Char +instance ReadRaw Char +instance WriteRaw Char + +instance StaticSize Bool +instance ReadRaw Bool +instance WriteRaw Bool + +instance StaticSize () +instance ReadRaw () +instance WriteRaw () + +-------------------------------------------------------------------------------- + +-- The instances for 'Complex' follow the 'Storable' instance. It is rewritten +-- so that they only rely on the classes defined in this module, not 'Storable'. + +instance StaticSize a => StaticSize (Complex a) where + staticSizeOf _ = 2 * staticSizeOf (Proxy @a) + staticAlignment _ = staticAlignment (Proxy @a) + +instance (ReadRaw a, StaticSize a) => ReadRaw (Complex a) where + readRaw ptrComplex = + let ptrPart = Ptr.castPtr ptrComplex + in (:+) <$> readRaw ptrPart <*> readRawElemOff ptrPart 1 + +instance (StaticSize a, WriteRaw a) => WriteRaw (Complex a) where + writeRaw ptrComplex (r :+ i) = do + let ptrPart = Ptr.castPtr ptrComplex + writeRaw ptrPart r + writeRawElemOff ptrPart 1 i diff --git a/src/HsBindgen/Runtime/Overloading.hs b/src/HsBindgen/Runtime/Overloading.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Overloading.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} + +-- | Restore the default environment when using @RebindableSyntax@ +-- +-- The @RebindableSyntax@ extension is currently required when using +-- @OverloadedRecordUpdate@, but when using this extension, a number of +-- functions are suddenly no longer in scope that normally are. This module +-- restores those functions to their standard definition. +module HsBindgen.Runtime.Overloading ( + module Prelude + , Control.Arrow.app + , Control.Arrow.arr + , Control.Arrow.first + , Control.Arrow.loop + , (Control.Arrow.>>>) + , (Control.Arrow.|||) + , Data.String.fromString + , GHC.OverloadedLabels.fromLabel + , GHC.Records.getField + -- * New definitions + , ifThenElse + , setField + ) where + +import Control.Arrow qualified +import Data.String qualified +import GHC.OverloadedLabels qualified +import GHC.Records qualified +import GHC.Records.Compat qualified + +{------------------------------------------------------------------------------- + Other exports +-------------------------------------------------------------------------------} + +ifThenElse :: Bool -> a -> a -> a +ifThenElse b x y = if b then x else y + +-- | Set a field in a record. +-- +-- NOTE: the order of arguments is GHC version dependent. +#if __GLASGOW_HASKELL__ >=914 +setField :: forall x r a. GHC.Records.Compat.HasField x r a => a -> r -> r +setField = flip (fst . GHC.Records.Compat.hasField @x) +#else +setField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a -> r +setField = fst . GHC.Records.Compat.hasField @x +#endif diff --git a/src/HsBindgen/Runtime/Prelude.hs b/src/HsBindgen/Runtime/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Prelude.hs @@ -0,0 +1,69 @@ +-- | Common definitions for interfacing with @hs-bindgen@ generated code. +-- +-- This prelude re-exports every runtime definition that is safe to use +-- unqualified, /including/ definitions from modules that are otherwise intended +-- for qualified import (e.g. 'WithFlam' from "HsBindgen.Runtime.FLAM"). +module HsBindgen.Runtime.Prelude ( + -- * C enumerations + CEnum(..) + , SequentialCEnum(..) + , AsCEnum(..) + , AsSequentialCEnum(..) + + -- * Fields and bit-fields + , HasCField(..) + , HasCBitfield(..) + , BitfieldPtr + , mkBitfieldPtr + + -- * Function pointers and instances + , ToFunPtr (..) + , FromFunPtr (..) + , withFunPtr + + -- * Pointers + , plusPtrElem + , safeCastFunPtr + + -- * Arrays + , ConstantArray -- opaque + , IncompleteArray -- opaque + , IsArray (Elem) + + -- * Flexible array members + , WithFlam -- opaque + + -- * Unions + , IsUnion + + -- * Struct + , IsStruct + + -- * Marshaling and serialization + , StaticSize(..) + , ReadRaw(..) + , WriteRaw(..) + , EquivStorable(..) + + -- Blocks + , Block(..) + + -- * Read-only pointers + , PtrConst -- type synonym or opaque, depending on version of @base@ + ) where + +import HsBindgen.Runtime.BitfieldPtr +import HsBindgen.Runtime.Block +import HsBindgen.Runtime.CEnum +import HsBindgen.Runtime.ConstantArray +import HsBindgen.Runtime.FLAM (WithFlam) +import HsBindgen.Runtime.HasCBitfield +import HsBindgen.Runtime.HasCField +import HsBindgen.Runtime.IncompleteArray +import HsBindgen.Runtime.IsArray +import HsBindgen.Runtime.Marshal +import HsBindgen.Runtime.PtrConst +import HsBindgen.Runtime.Struct (IsStruct) +import HsBindgen.Runtime.Support.FunPtr +import HsBindgen.Runtime.Support.Ptr +import HsBindgen.Runtime.Union (IsUnion) diff --git a/src/HsBindgen/Runtime/PtrConst.hs b/src/HsBindgen/Runtime/PtrConst.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/PtrConst.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} + +-- | Read-only pointers +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.PtrConst qualified as PtrConst +module HsBindgen.Runtime.PtrConst ( + PtrConst -- type synonym or opaque, depending on version of @base@ + , peek + , unsafeToPtr + , unsafeFromPtr + -- * Relationship with t'ConstPtr' + -- $constptr + ) where + +#if MIN_VERSION_base(4,18,0) +import Foreign.C.ConstPtr (ConstPtr(..)) +#endif + +import Data.Kind (Type) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) +import Foreign.Storable qualified as F + +-- | A read-only pointer. +-- +-- A @'PtrConst' a@ is a pointer to a type @a@ with a C @const@ qualifier. For +-- instance, the Haskell type @PtrConst CInt@ is equivalent to the C type @const +-- int*@. @const@-qualified contents of a pointer should not be modified, but +-- reading the contents is okay. +type PtrConst :: Type -> Type +#if MIN_VERSION_base(4,18,0) +type PtrConst a = ConstPtr a +#else +type role PtrConst phantom +newtype PtrConst a = Wrap { unwrap :: Ptr a } + deriving stock (Eq, Ord) + deriving newtype Storable + +-- doesn't use record syntax +instance Show (PtrConst a) where + showsPrec d (Wrap p) = showParen (d > 10) $ showString "PtrConst " . showsPrec 11 p +#endif + +{------------------------------------------------------------------------------- + Internal +-------------------------------------------------------------------------------} + +unPtrConst :: PtrConst a -> Ptr a +#if MIN_VERSION_base(4,18,0) +unPtrConst = unConstPtr +#else +unPtrConst = unwrap +#endif + +mkPtrConst :: Ptr a -> PtrConst a +#if MIN_VERSION_base(4,18,0) +mkPtrConst = ConstPtr +#else +mkPtrConst = Wrap +#endif + +{------------------------------------------------------------------------------- + Public +-------------------------------------------------------------------------------} + +-- | Like 'F.peek' +peek :: Storable a => PtrConst a -> IO a +peek ptrc = F.peek (unPtrConst ptrc) + +-- | Unsafe: convert a 'PtrConst' to a 'Ptr'. +-- +-- NOTE: use the output pointer only with read access. +unsafeToPtr :: PtrConst a -> Ptr a +unsafeToPtr ptrc = unPtrConst ptrc + +-- | Unsafe: convert a 'Ptr' to a 'PtrConst'. +-- +-- NOTE: use the input pointer only with read access. +unsafeFromPtr :: Ptr a -> PtrConst a +unsafeFromPtr ptr = mkPtrConst ptr + +{------------------------------------------------------------------------------- + Relationship with t'ConstPtr' +-------------------------------------------------------------------------------} + +{- $constptr + +'PtrConst' is a pointer-to-const-data, but t'ConstPtr' is too. They are mostly +equivalent, so why a new type? For two main reasons: + +1. t'ConstPtr' is actually a misnomer: it is a pointer-to-const-data, not a + const-pointer-to-data. +2. t'ConstPtr' can be freely converted to a 'Ptr', even though its contents + should be considered to be read-only. + +'PtrConst' is arguably a better name, and it goes further in ensuring that +the pointer only has read access. + +On @base-4.18@ and up, 'PtrConst' is a type synonym around t'ConstPtr', while on +earlier @base@ versions it is a custom, opaque datatype. If you care about +compatibility with all @base@ versions that @hs-bindgen-runtime@ support, then +you should treat 'PtrConst' as its own type distinct from t'ConstPtr' using only +the functions in the "HsBindgen.Runtime.PtrConst" module rather than the +"Foreign.C.ConstPtr" module. +-} + diff --git a/src/HsBindgen/Runtime/Struct.hs b/src/HsBindgen/Runtime/Struct.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Struct.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Class for C structs +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.Struct qualified as Struct +module HsBindgen.Runtime.Struct ( + IsStruct (..) + , IsStructViaReadRaw (..) + ) where + +import Data.Primitive.ByteArray qualified as BA +import Data.Proxy (Proxy (..)) +import Data.Word (Word8) +import Foreign.Ptr (Ptr, castPtr) +import System.IO.Unsafe (unsafePerformIO) + +import HsBindgen.Runtime.Marshal (ReadRaw (..), StaticSize (staticSizeOf)) + +class IsStruct s where + -- | A 'zero' struct value is a struct value that is read from a zeroed-out + -- byte array + zero :: s + +-- | Helper type for deriving 'IsStruct' via 'ReadRaw' (and 'StaticSize') +newtype IsStructViaReadRaw s = IsStructViaReadRaw s + +-- | Helper instance for deriving 'IsStruct' via 'ReadRaw' (and 'StaticSize') +instance (StaticSize s, ReadRaw s) => IsStruct (IsStructViaReadRaw s) where + zero = + unsafePerformIO $ + BA.withByteArrayContents zeroBytes $ \(ptr :: Ptr Word8) -> + IsStructViaReadRaw <$> readRaw (castPtr ptr :: Ptr s) + where + n = staticSizeOf (Proxy @s) + zeroBytes = BA.byteArrayFromListN n $ replicate n (0 :: Word8) diff --git a/src/HsBindgen/Runtime/Support.hs b/src/HsBindgen/Runtime/Support.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support.hs @@ -0,0 +1,151 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE MagicHash #-} + +-- | Support prelude of generated bindings +-- +-- Re-exports the definitions that generated code needs from modules meant for +-- unqualified import, be they in @base@, in other libraries, or in +-- @hs-bindgen-runtime@. Generated code imports modules meant for qualified +-- import, such as "HsBindgen.Runtime.Marshal", directly instead, and imports a +-- curated set of "Prelude" names unqualified; see @dev\/generated-code.md@. +-- +-- This module also bridges differences between GHC and @base@ versions. +-- +-- We maintain minimal lists of explicit imports and exports. Exports are +-- grouped like the constructors of @BindgenGlobalType@ and +-- @BindgenGlobalTerm@ in @HsBindgen.Backend.Global@ (package @hs-bindgen@). +-- +-- Intended for qualified import. +-- +-- @ +-- import HsBindgen.Runtime.Support qualified as BG +-- @ +module HsBindgen.Runtime.Support ( + -- * Function pointers + ToFunPtr(toFunPtr) + , FromFunPtr(fromFunPtr) + + -- * Foreign function interface + , Ptr(Ptr) + , FunPtr + , StablePtr + , plusPtr + , castFunPtr + , getUnionPayload + , setUnionPayload + , getUnionPayloadBits + , setUnionPayloadBits + , with + , allocaAndPeek + , Generic + + -- * 'Storable' + , Storable(sizeOf, alignment, peekByteOff, pokeByteOff, peek, poke) + + -- * 'HasField' + , HasField(getField) + + -- * Proxy + , Proxy(Proxy) + + -- * 'HasFFIType' + , HasFFIType(fromFFIType, toFFIType) + , PtrVoid + , FunPtrVoid + + -- * Unsafe + , unsafePerformIO + + -- * Primitive + , Prim(sizeOf#, alignment#, indexByteArray#, readByteArray#, writeByteArray#, indexOffAddr#, readOffAddr#, writeOffAddr#) + , (+#) + , (*#) + + -- * Other type classes + , Bitfield + , Bits + , FiniteBits + , Ix + , readPrec + , readList + , readListPrec + , readListDefault + , readListPrecDefault + , showsPrec + + -- Floating point numbers + , castWord32ToFloat + , castWord64ToDouble + -- The CFloat and CDouble constructors are exported below, together with + -- their types. + + -- Non-empty lists + , NonEmpty((:|)) + , singleton + + -- Arrays + , ByteArray + , SizedByteArray(SizedByteArray) + + -- ByteString + , BS.ByteString + , BS.pack + + -- Complex numbers + , Complex + + -- C types + , Void + , Int8, Int16, Int32, Int64 + , Word8, Word16, Word32, Word64 + , CChar(CChar), CSChar(CSChar), CUChar(CUChar) + , CShort(CShort), CUShort(CUShort) + , CInt(CInt), CUInt(CUInt) + , CLong(CLong), CULong(CULong) + , CLLong(CLLong), CULLong(CULLong) + , CBool(CBool) + , CFloat(CFloat), CDouble(CDouble) + , CStringLen + , CPtrdiff + ) where + +import Data.Array.Byte (ByteArray) +import Data.Bits (Bits, FiniteBits) +import Data.ByteString qualified as BS (ByteString, pack) +import Data.Complex (Complex) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Ix (Ix) +import Data.List.NonEmpty (NonEmpty ((:|)), singleton) +import Data.Primitive.Types (Prim (alignment#, indexByteArray#, indexOffAddr#, readByteArray#, readOffAddr#, sizeOf#, writeByteArray#, writeOffAddr#)) +import Data.Proxy (Proxy (Proxy)) +import Data.Void (Void) +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign (Storable (alignment, peek, peekByteOff, poke, pokeByteOff, sizeOf), + castFunPtr, with) +import Foreign.C (CBool (CBool), CChar (CChar), CDouble (CDouble), + CFloat (CFloat), CInt (CInt), CLLong (CLLong), CLong (CLong), + CPtrdiff, CSChar (CSChar), CShort (CShort), CUChar (CUChar), + CUInt (CUInt), CULLong (CULLong), CULong (CULong), + CUShort (CUShort)) +import Foreign.C.String (CStringLen) +import Foreign.StablePtr (StablePtr) +import GHC.Base ((*#), (+#)) +import GHC.Float (castWord32ToFloat, castWord64ToDouble) +import GHC.Generics (Generic) +import GHC.Ptr (FunPtr, Ptr (Ptr), plusPtr) +import GHC.Records (HasField (getField)) +import System.IO.Unsafe (unsafePerformIO) +import Text.Read (readListDefault, readListPrec, readListPrecDefault, readPrec) + +import HsBindgen.Runtime.HasFFIType (FunPtrVoid, + HasFFIType (fromFFIType, toFFIType), + PtrVoid) +import HsBindgen.Runtime.Support.Bitfield (Bitfield) +import HsBindgen.Runtime.Support.ByteArray (getUnionPayload, + getUnionPayloadBits, + setUnionPayload, + setUnionPayloadBits) +import HsBindgen.Runtime.Support.CAPI (allocaAndPeek) +import HsBindgen.Runtime.Support.FunPtr (FromFunPtr (fromFunPtr), + ToFunPtr (toFunPtr)) +import HsBindgen.Runtime.Support.SizedByteArray (SizedByteArray (SizedByteArray)) diff --git a/src/HsBindgen/Runtime/Support/Bitfield.hs b/src/HsBindgen/Runtime/Support/Bitfield.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/Bitfield.hs @@ -0,0 +1,662 @@ +{-# OPTIONS_HADDOCK hide #-} + +module HsBindgen.Runtime.Support.Bitfield ( + -- * Bitfield + Bitfield(..) + , defaultNarrow + , signedExtend + , unsignedExtend + , loMask + , hiMask + -- * Storable + , peekBitOffWidth + , pokeBitOffWidth + -- * Auxiliary functions (exported for testing) + , getBitfield + , getBitfieldLE + , getBitfieldBE + , putBitfield + , putBitfieldLE + , putBitfieldBE +) where + +-- $setup +-- >>> import Data.Word +-- >>> import Numeric +-- >>> import Foreign.C.Types + +import Data.Bits +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Proxy +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (peekArray, pokeArray) +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe (unsafePerformIO) + +import HsBindgen.Runtime.Marshal qualified as Marshal + +{------------------------------------------------------------------------------- + Bitfield +-------------------------------------------------------------------------------} + +-- | Types which can be a bit-field in a C @struct@ or @union@ +-- +-- The members convert to/from 'Word64' to make the use in the implementation of +-- bitfields in @hs-bindgen@ easier. We could not convert or have a smallest +-- @WordN@ that best fits the type, but doing so would complicate usage for +-- little benefit. +-- +-- >>> let width = 5 :: Int +-- >>> extend (narrow (3 :: CSChar) width) width :: CSChar +-- 3 +-- +-- >>> let width = 5 :: Int +-- >>> extend (narrow (-7 :: CSChar) width) width :: CSChar +-- -7 +-- +-- overflow case, the result is undefined behavior: +-- +-- >>> let width = 5 :: Int +-- >>> extend (narrow (-100 :: CSChar) width) width :: CSChar +-- -4 +class Bitfield a where + -- | Narrow the value so that only @width@ lowest bits are set + narrow :: a -> Int -> Word64 + default narrow :: Integral a => a -> Int -> Word64 + narrow = defaultNarrow + + -- | Extend the value from only @width@ lowest bits representation + -- + -- This should extend the sign for signed types. + extend :: Word64 -> Int -> a + +-- NOTE We could get away without a type class, using 'defaultNarrow', +-- 'signedExtend', and 'unsignedExtend' directly, but we would still need to +-- encode the signedness of a target type somewhere anyway. + +-- Instances for "Data.Int" signed integral types +instance Bitfield Int where extend = signedExtend +instance Bitfield Int8 where extend = signedExtend +instance Bitfield Int16 where extend = signedExtend +instance Bitfield Int32 where extend = signedExtend +instance Bitfield Int64 where extend = signedExtend + +-- Instances for "Data.Word" unsigned integral types +instance Bitfield Word where extend = unsignedExtend +instance Bitfield Word8 where extend = unsignedExtend +instance Bitfield Word16 where extend = unsignedExtend +instance Bitfield Word32 where extend = unsignedExtend +instance Bitfield Word64 where extend = unsignedExtend + +-- Instances for "Foreign.C.Types" signed integral types +instance Bitfield CChar where extend = signedExtend +instance Bitfield CSChar where extend = signedExtend +instance Bitfield CShort where extend = signedExtend +instance Bitfield CInt where extend = signedExtend +instance Bitfield CLong where extend = signedExtend +instance Bitfield CPtrdiff where extend = signedExtend +instance Bitfield CWchar where extend = signedExtend +instance Bitfield CSigAtomic where extend = signedExtend +instance Bitfield CLLong where extend = signedExtend +instance Bitfield CIntPtr where extend = signedExtend +instance Bitfield CIntMax where extend = signedExtend + +-- Instances for "Foreign.C.Types" unsigned integral types +instance Bitfield CUChar where extend = unsignedExtend +instance Bitfield CUShort where extend = unsignedExtend +instance Bitfield CUInt where extend = unsignedExtend +instance Bitfield CULong where extend = unsignedExtend +instance Bitfield CSize where extend = unsignedExtend +instance Bitfield CULLong where extend = unsignedExtend +instance Bitfield CBool where extend = unsignedExtend +instance Bitfield CUIntPtr where extend = unsignedExtend +instance Bitfield CUIntMax where extend = unsignedExtend + +-- | Default 'narrow' implementation +-- +-- This function takes the lowest @width@ bits. +defaultNarrow :: + Integral a + => a -- ^ Value of the bit-field + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> Word64 +defaultNarrow x width = fromIntegral x .&. loMask width + +-- | Unsigned extend, just converts types +unsignedExtend :: + Num a + => Word64 -- ^ Value of the bit-field + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> a +unsignedExtend x _width = fromIntegral x + +-- | Signed extend, performs +-- [sign extension](https://en.wikipedia.org/wiki/Sign_extension) +signedExtend :: + Num a + => Word64 -- ^ Value of the bit-field + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> a +signedExtend x width + -- Negative: extend the sign + | testBit x (width - 1) = fromIntegral $ hiMask width .|. x + -- Non-negative: just convert + | otherwise = fromIntegral x + +-- | Generate a low mask +-- +-- The argument essentially specifies the number of least significant bits that +-- are one. It should be in range @[0 .. typeWidth]@, where @typeWidth@ is the +-- width of the type. +-- +-- >>> map (flip showBin "" . loMask @Word16) [0, 1, 2, 5, 8, 16] +-- ["0","1","11","11111","11111111","1111111111111111"] +loMask :: forall a. (FiniteBits a, Num a) => Int -> a +loMask n + | n >= 0 && n < finiteBitSize @a 0 = unsafeShiftL 1 n - 1 + -- For other values of @n@, 'unsafeShiftL' has undefined behavior. Shifting + -- an 'Int64' by 64 bits is particularly problematic. + | otherwise = complement 0 + +-- | Generate a high mask +-- +-- The argument essentially specifies the number of least significant bits that +-- are zero. It should be in range @[0 .. typeWidth]@, where @typeWidth@ is +-- the width of the type. +-- +-- >>> map (flip showBin "" . hiMask @Word16) [0, 1, 2, 5, 8, 16] +-- ["1111111111111111","1111111111111110","1111111111111100","1111111111100000","1111111100000000","0"] +hiMask :: (FiniteBits a, Num a) => Int -> a +hiMask = complement . loMask + +{------------------------------------------------------------------------------ + Storable +------------------------------------------------------------------------------} + +-- | Read a bit-field from memory +-- +-- This function only uses aligned reads, so that it is safe to use on any +-- architecture. +-- +-- A bit-field is read using a single peek when possible, as determined by +-- alignment and the passed memory bounds. This should always be the case with +-- normal @struct@s and @union@s. +-- +-- When it is not possible to read a bit-field using a single peek, multiple +-- peeks are used to read the bytes of the bit-field. This may happen with +-- (poorly-designed) packed @struct@s\/@unions@. +-- +-- The memory bounds should generally be the bounds of the @struct@ or @union@ +-- object. In this case, concurrent access to different objects (in an array) is +-- safe. Concurrent access to bit-fields within a single @struct@ or @union@ +-- object is generally unsafe. +peekBitOffWidth :: forall a. + Bitfield a + => Ptr () -- ^ Pointer to the byte where the bit-field starts + -> Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> (Ptr (), Ptr ()) -- ^ Memory bounds, must contain the bit-field + -> IO a +peekBitOffWidth ptrB off width bounds@(ptrL, ptrH) + | off < 0 || off > 7 = fail' "invalid offset" + | width < 1 || width > 64 = fail' "invalid width" + | ptrB < ptrL || ptrBH > ptrH = fail' "out of bounds" + | Just (ptr8, _, r) <- getAligned @Word8 (ptrB, ptrBH) off width bounds = + readAligned ptr8 r + | Just (ptr16, _, r) <- getAligned @Word16 (ptrB, ptrBH) off width bounds = + readAligned ptr16 r + | Just (ptr32, _, r) <- getAligned @Word32 (ptrB, ptrBH) off width bounds = + readAligned ptr32 r + | Just (ptr64, _, r) <- getAligned @Word64 (ptrB, ptrBH) off width bounds = + readAligned ptr64 r + | otherwise = readBytes + where + -- Minimum number of bytes that must be read + minBytes :: Int + minBytes = case (off + width) `quotRem` 8 of + (bytes, 0) -> bytes + (bytes, _) -> bytes + 1 + + -- High bound of bytes that must be read + ptrBH :: Ptr () + ptrBH = ptrB `plusPtr` minBytes + + -- Read the bit-field using a single, aligned word + readAligned :: + (FiniteBits w, Integral w, Marshal.ReadRaw w) + => Ptr w -- ^ Pointer to aligned word + -> Int -- ^ Right offset (bits) + -> IO a + readAligned ptr roff = do + w <- Marshal.readRaw ptr + let w' = unsafeShiftR w roff .&. loMask width + return $! extend (fromIntegral w') width + + -- Read the bit-field using bytes + readBytes :: IO a + readBytes = do + w8s <- peekArray minBytes (castPtr ptrB) + case getBitfield off width w8s of + Right w64 -> return $! extend w64 width + Left msg -> fail' msg + + fail' :: String -> IO a + fail' msg = fail $ concat [ + "peekBitOffWidth " + , show ptrB, " " + , show off, " " + , show width, " (" + , show ptrL, ", " + , show ptrH, "): " + , msg + ] + +-- | Write a bit-field to memory +-- +-- This function only uses aligned reads and writes, so that it is safe to use +-- on any architecture. +-- +-- When a bit-field can be written using a single poke, as determined by +-- alignment and the passed memory bounds, a single peek reads any extra bits +-- when necessary, and then a single poke writes the bit-field. This should +-- always be the case with normal @struct@s and @union@s. +-- +-- When it is not possible to write a bit-field using a single poke, the byte(s) +-- containing any extra bits are read when necessary, and then multiple pokes +-- are used to write the bytes of the bit-field. This may happen with +-- (poorly-designed) packed @struct@s\/@union@s. +-- +-- The memory bounds should generally be the bounds of the @struct@ or @union@ +-- object. In this case, concurrent access to different objects (in an array) is +-- safe. Concurrent access to bit-fields within a single @struct@ or @union@ +-- object is generally unsafe. +pokeBitOffWidth :: forall a. + Bitfield a + => Ptr () -- ^ Pointer to the byte where the bit-field starts + -> Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> (Ptr (), Ptr ()) -- ^ Memory bounds, must contain the bit-field + -> a -- ^ Bit-field value + -> IO () +pokeBitOffWidth ptrB off width bounds@(ptrL, ptrH) x + | off < 0 || off > 7 = fail' "invalid offset" + | width < 1 || width > 64 = fail' "invalid width" + | ptrB < ptrL || ptrBH > ptrH = fail' "out of bounds" + | Just (ptr8, l, r) <- getAligned @Word8 (ptrB, ptrBH) off width bounds = + writeAligned ptr8 l r + | Just (ptr16, l, r) <- getAligned @Word16 (ptrB, ptrBH) off width bounds = + writeAligned ptr16 l r + | Just (ptr32, l, r) <- getAligned @Word32 (ptrB, ptrBH) off width bounds = + writeAligned ptr32 l r + | Just (ptr64, l, r) <- getAligned @Word64 (ptrB, ptrBH) off width bounds = + writeAligned ptr64 l r + | otherwise = writeBytes + where + -- Minimum number of bytes that must be written + minBytes :: Int + minBytes = case (off + width) `quotRem` 8 of + (bytes, 0) -> bytes + (bytes, _) -> bytes + 1 + + -- High bound of bytes that must be written + ptrBH :: Ptr () + ptrBH = ptrB `plusPtr` minBytes + + -- Write the bit-field using a single, aligned word + writeAligned :: + (FiniteBits w, Integral w, Marshal.ReadRaw w, Marshal.WriteRaw w) + => Ptr w -- ^ Pointer to aligned word + -> Int -- ^ Left offset (bits) + -> Int -- ^ Right offset (bits) + -> IO () + writeAligned ptr loff roff + | loff == 0 && roff == 0 = + Marshal.writeRaw ptr (fromIntegral (narrow x width)) + | otherwise = do + w <- Marshal.readRaw ptr + let x' = unsafeShiftL (fromIntegral (narrow x width)) roff + mask = unsafeShiftL (loMask width) roff + Marshal.writeRaw ptr ((w .&. complement mask) .|. x') + + -- Write the bit-field using bytes + writeBytes :: IO () + writeBytes = do + let ptrL8 = castPtr ptrB + ptrH8 = castPtr (ptrBH `plusPtr` (-1)) + l8 <- + if off == 0 + then return 0x00 + else Marshal.readRaw ptrL8 + h8 <- + if 8 * minBytes - width - off == 0 + then return 0x00 + else if ptrH8 == ptrL8 then return l8 else Marshal.readRaw ptrH8 + pokeArray ptrL8 $ putBitfield off width l8 h8 (narrow x width) + + fail' :: String -> IO () + fail' msg = fail $ concat [ + "pokeBitOffWidth " + , show ptrB, " " + , show off, " " + , show width, " (" + , show ptrL, ", " + , show ptrH, ") x: " + , msg + ] + +{------------------------------------------------------------------------------- + Auxiliary functions +-------------------------------------------------------------------------------} + +-- | Is the system little endian? +-- +-- This value is computed (once) by allocating two bytes of memory, writing a +-- @1 :: 'Word16'@, and checking the value of the first byte. With a little +-- endian architecture, we get @01 00@ byte order, and the first byte is 1. +-- With a big endian architecture, we get a @00 01@ byte order, and the first +-- byte is 0. +-- +-- Reference: +isLittleEndian :: Bool +isLittleEndian = unsafePerformIO $ alloca $ \ptr -> do + poke @Word16 ptr 1 + (== 1) <$> peekByteOff @Word8 ptr 0 +{-# NOINLINE isLittleEndian #-} + +-- | Get a pointer to an aligned word that spans the whole bit-field, when +-- possible +-- +-- This function also returns the number of bits to the left and right of the +-- bit-field within the aligned word. +getAligned :: forall w. + Marshal.StaticSize w + => (Ptr (), Ptr ()) -- ^ Minimal bit-field bounds + -> Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> (Ptr (), Ptr ()) -- ^ Memory bounds, must contain the bit-field + -> Maybe (Ptr w, Int, Int) +getAligned (ptrB, ptrBH) off width (ptrL, ptrH) + | ptrA < ptrL = Nothing -- Lower bound of the word is out of bounds + | ptrAH < ptrBH = Nothing -- Whole bit-field is not within the word + | ptrAH > ptrH = Nothing -- Higher bound of the word is out of bounds + | otherwise = Just (castPtr ptrA, lBits, rBits) + where + wSize, wAlign :: Int + wSize = Marshal.staticSizeOf @w Proxy + wAlign = Marshal.staticAlignment @w Proxy + + -- Aligned word bounds, where @ptrA@ is a pointer to the highest aligned + -- word of the specified size such that @ptrA <= ptrB@ + ptrA, ptrAH :: Ptr () + (ptrA, ptrAH) = case alignPtr ptrB wAlign of + ptr + | ptr == ptrB -> (ptr, ptr `plusPtr` wSize) + | otherwise -> (ptr `plusPtr` negate wSize, ptr) + + -- Number of bits to the left and right of the bit-field within the aligned + -- word + -- + -- Example @struct@: + -- + -- * a:10 1000000011 + -- * b:24 000000000000000000000000 + -- * c:24 110000000000000000000111 + lBits, rBits :: Int + (lBits, rBits) + -- Little endian: bit-field offsets are from the least significant bit + -- + -- Field @b@ has an offset of 2, shown as @xx@ in this memory diagram: + -- + -- bbbbbbxx bbbbbbbb bbbbbbbb bb + -- 00000011 00000010 00000000 00000000 00011100 00000000 00000000 00000011 + -- | | | + -- ptrA ptrB ptrBH + -- + -- Left bits are shown as @l@s and right bits are shown as @r@s in this + -- 'Word64' diagram: + -- + -- llllllll llllllll llllllll llllllbb bbbbbbbb bbbbbbbb bbbbbbrr rrrrrrrr + -- 00000011 00000000 00000000 00011100 00000000 00000000 00000010 00000011 + | isLittleEndian = + let r = off + 8 * (ptrB `minusPtr` ptrA) + in (wSize * 8 - width - r, r) + + -- Big endian: bit-field offsets are from the most significant bit + -- + -- Field @b@ has an offset of 2, shown as @xx@ in this memory diagram: + -- + -- xxbbbbbb bbbbbbbb bbbbbbbb bb + -- 10000000 11000000 00000000 00000000 00110000 00000000 00000001 11000000 + -- | | | + -- ptrA ptrB ptrBH + -- + -- Left bits are shown as @l@s and right bits are shown as @r@s in this + -- 'Word64' diagram: + -- + -- llllllll llbbbbbb bbbbbbbb bbbbbbbb bbrrrrrr rrrrrrrr rrrrrrrr rrrrrrrr + -- 10000000 11000000 00000000 00000000 00110000 00000000 00000001 11000000 + | otherwise = + let l = 8 * (ptrB `minusPtr` ptrA) + off + in (l, wSize * 8 - width - l) + +-- | Get a bit-field value from a list of bytes (native byte order) +getBitfield :: + Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> [Word8] -- ^ Bytes as read from memory + -> Either String Word64 +getBitfield + | isLittleEndian = getBitfieldLE + | otherwise = getBitfieldBE + +-- | Get a bit-field value from a list of bytes (little endian) +getBitfieldLE :: + Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> [Word8] -- ^ Bytes as read from memory + -> Either String Word64 +getBitfieldLE off width = auxFirst + where + -- With little endian, @struct@s and @union@s are stored in reverse byte + -- order, and bit-field offsets are from the least significant bit. + -- + -- * Single byte: @| loff? | numFieldBits | off? |@ + -- + -- * First byte: @| numFieldBits | off? |@ + -- * Middle byte: @| numFieldBits = 8 |@ + -- * Last byte: @| loff? | numFieldBits |@ + + auxFirst :: + [Word8] -- ^ Bytes as read from memory + -> Either String Word64 + auxFirst = \case + -- First byte or single byte + (b:bs) -> + let numFieldBits = min width (8 - off) + fieldByte = unsafeShiftR b off .&. loMask numFieldBits + fieldWord = fromIntegral fieldByte + in auxNext fieldWord numFieldBits (width - numFieldBits) bs + [] -> Left "not enough bytes" + + auxNext :: + Word64 -- ^ Bit-field value accumulator + -> Int -- ^ Number of bit-field bits in the accumulator + -> Int -- ^ Remaining number of bits in the bit-field + -> [Word8] -- ^ Remaining bytes as read from memory + -> Either String Word64 + auxNext !acc numAccBits width' = \case + (b:bs) + -- Middle byte + | width' >= 8 -> + let fieldWord = unsafeShiftL (fromIntegral b) numAccBits + in auxNext (fieldWord .|. acc) (numAccBits + 8) (width' - 8) bs + -- Last byte + | width' > 0 -> + let fieldByte = b .&. loMask width' + fieldWord = unsafeShiftL (fromIntegral fieldByte) numAccBits + in auxNext (fieldWord .|. acc) (numAccBits + width') 0 bs + | otherwise -> Left "too many bytes" + [] + | width' == 0 -> Right acc + | otherwise -> Left "not enough bytes" + +-- | Get a bit-field value from a list of bytes (big endian) +getBitfieldBE :: + Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> [Word8] -- ^ Bytes as read from memory + -> Either String Word64 +getBitfieldBE off width = auxFirst + where + -- With big endian, @struct@s and @union@s are stored in byte order, and + -- bit-field offsets are from the most significant bit. + -- + -- * Single byte: @| off? | numFieldBits | roff? |@ + -- + -- * First byte: @| off? | numFieldBits |@ + -- * Middle byte: @| numFieldBits = 8 |@ + -- * Last byte: @| numFieldBits | roff? |@ + + off8 :: Int + off8 = 8 - off + + auxFirst :: + [Word8] -- ^ Bytes as read from memory + -> Either String Word64 + auxFirst = \case + (b:bs) + -- First byte + | width >= off8 -> + let width' = width - off8 + fieldByte = b .&. loMask off8 + fieldWord = unsafeShiftL (fromIntegral fieldByte) width' + in auxNext fieldWord width' bs + -- Single byte + | otherwise -> + let fieldByte = unsafeShiftR (b .&. loMask off8) (off8 - width) + fieldWord = fromIntegral fieldByte + in auxNext fieldWord 0 bs + [] -> Left "not enough bytes" + + auxNext :: + Word64 -- ^ Bit-field value accumulator + -> Int -- ^ Remaining number of bits in the bit-field + -> [Word8] -- ^ Remaining bytes as read from memory + -> Either String Word64 + auxNext !acc width' = \case + (b:bs) + -- Middle byte + | width' >= 8 -> + let width'' = width' - 8 + x = unsafeShiftL (fromIntegral b) width'' + in auxNext (acc .|. x) width'' bs + -- Last byte + | width' > 0 -> + let b' = unsafeShiftR b (8 - width') + x = fromIntegral b' + in auxNext (acc .|. x) 0 bs + | otherwise -> Left "too many bytes" + [] + | width' == 0 -> Right acc + | otherwise -> Left "not enough bytes" + +-- | Put a bit-field value into a list of bytes (native byte order) +putBitfield :: + Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> Word8 -- ^ Existing low byte, not used when not needed + -> Word8 -- ^ Existing high byte, not used when not needed + -> Word64 -- ^ Bit-field value + -> [Word8] +putBitfield + | isLittleEndian = putBitfieldLE + | otherwise = putBitfieldBE + +-- | Put a bit-field value into a list of bytes (little endian) +putBitfieldLE :: + Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> Word8 -- ^ Existing low byte, not used when not needed + -> Word8 -- ^ Existing high byte, not used when not needed + -> Word64 -- ^ Bit-field value + -> [Word8] +putBitfieldLE off width l8 h8 = auxFirst + where + auxFirst :: + Word64 -- ^ Bit-field value + -> [Word8] + auxFirst x = + -- Handle low offset of single/first byte + let b' = fromIntegral (x .&. 0xFF) + b | off > 0 = unsafeShiftL b' off .|. (l8 .&. loMask off) + | otherwise = b' -- optimization + acc = NonEmpty.singleton b + numFieldBits = min width (8 - off) + in auxNext acc (width + off - 8) (unsafeShiftR x numFieldBits) + + auxNext :: + NonEmpty Word8 -- ^ Accumulator (reverse order) + -> Int -- ^ Remaining number of bits (may be negative) + -> Word64 -- ^ Remaining bit-field value + -> [Word8] + auxNext acc width' x + -- Middle/last byte + | width' > 0 = + let b = fromIntegral (x .&. 0xFF) + in auxNext (NonEmpty.cons b acc) (width' - 8) (unsafeShiftR x 8) + -- Handle high offset of single/last byte + | otherwise = + let hoff = negate width' + b' = NonEmpty.head acc + b | hoff > 0 = + let mask = unsafeShiftL (loMask hoff) (8 - hoff) + in (h8 .&. mask) .|. (b' .&. complement mask) + | otherwise = b' -- optimization + in reverse (b : NonEmpty.tail acc) + +-- | Put a bit-field value into a list of bytes (big endian) +putBitfieldBE :: + Int -- ^ Offset of the bit-field (0 to 7 bits) + -> Int -- ^ Width of the bit-field (1 to 64 bits) + -> Word8 -- ^ Existing low byte, not used when not needed + -> Word8 -- ^ Existing high byte, not used when not needed + -> Word64 -- ^ Bit-field value + -> [Word8] +putBitfieldBE off width l8 h8 = auxFirst + where + auxFirst :: + Word64 -- ^ Bit-field value + -> [Word8] + auxFirst x = + -- Handle high offset of single/last byte + let hoff = (8 - ((width + off) `mod` 8)) `mod` 8 + b' = fromIntegral (x .&. 0xFF) + b | hoff > 0 = unsafeShiftL b' hoff .|. (h8 .&. loMask hoff) + | otherwise = b' -- optimization + acc = NonEmpty.singleton b + numFieldBits = min width (8 - hoff) + in auxNext acc (width + hoff - 8) (unsafeShiftR x numFieldBits) + + auxNext :: + NonEmpty Word8 -- ^ Accumulator + -> Int -- ^ Remaining number of bits (may be negative) + -> Word64 -- ^ Remaining bit-field value + -> [Word8] + auxNext acc width' x + -- Middle/first byte + | width' > 0 = + let b = fromIntegral (x .&. 0xFF) + in auxNext (NonEmpty.cons b acc) (width' - 8) (unsafeShiftR x 8) + -- Handle low offset of single/first byte + | otherwise = -- off == negate width' + let b' = NonEmpty.head acc + b | off > 0 = + let mask = unsafeShiftL (loMask off) (8 - off) + in (l8 .&. mask) .|. (b' .&. complement mask) + | otherwise = b' -- optimization + in b : NonEmpty.tail acc diff --git a/src/HsBindgen/Runtime/Support/ByteArray.hs b/src/HsBindgen/Runtime/Support/ByteArray.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/ByteArray.hs @@ -0,0 +1,217 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | Utilities for dealing with 'ByteArray', 'Storable', and 'Bitfield'. +-- +-- The additional copying we have to do here is a bit annoying, but in the end +-- an FFI implementation based on 'Storable' is never going to be /extremely/ +-- fast, as we are effectively (de)serializing. A few additional @memcpy@ +-- operations are therefore not going to be a huge difference. +-- +-- We /could/ choose to use pinned bytearrays. This would avoid /some/ copying, +-- but by no means all: we'd still need one copy (instead of two) in +-- 'peekByteArray' and 'pokeByteArray', and the calls to 'peek' and 'poke' in +-- 'peekFromByteArray' and 'pokeToByteArray' will (likely) do copying of their +-- own as well. +module HsBindgen.Runtime.Support.ByteArray ( + -- * Support for defining 'Storable' instances for union types + peekByteArray + , pokeByteArray + -- * Support for defining setters and getters for union types + , setUnionPayload + , getUnionPayload + , setUnionPayloadBits + , getUnionPayloadBits + ) where + +import Control.Exception +import Control.Monad.Primitive (RealWorld) +import Data.Coerce (Coercible, coerce) +import Data.Primitive.ByteArray (ByteArray, MutableByteArray) +import Data.Primitive.ByteArray qualified as BA +import Foreign (Ptr, Storable (peek, poke), castPtr, copyBytes, plusPtr, sizeOf) +import System.IO.Unsafe (unsafePerformIO) + +import HsBindgen.Runtime.Support.Bitfield (Bitfield) +import HsBindgen.Runtime.Support.Bitfield qualified as Bitfield + +{------------------------------------------------------------------------------- + Support for defining 'Storable' instances for union types +-------------------------------------------------------------------------------} + +peekByteArray :: Int -> Ptr a -> IO ByteArray +peekByteArray n src = do + pinnedCopy <- BA.newPinnedByteArray n + BA.withMutableByteArrayContents pinnedCopy $ \dest -> + copyBytes dest (castPtr src) n + BA.freezeByteArray pinnedCopy 0 n + +pokeByteArray :: Ptr a -> ByteArray -> IO () +pokeByteArray dest bytes = do + pinnedCopy <- thawToPinned bytes + BA.withMutableByteArrayContents pinnedCopy $ \src -> + copyBytes dest (castPtr src) n + where + n = BA.sizeofByteArray bytes + +{------------------------------------------------------------------------------- + Support for defining setters and getters for union types +-------------------------------------------------------------------------------} + +setUnionPayload :: forall payload union. + ( Storable payload + , Coercible union ByteArray + ) + => payload -> union -> union +setUnionPayload x u = coerce (pokeToByteArray x (coerce u)) + +getUnionPayload :: forall payload union. + ( Storable payload + , Coercible union ByteArray + ) + => union -> payload +getUnionPayload = peekFromByteArray . coerce + +setUnionPayloadBits :: forall payload union. + ( Bitfield payload + , Coercible union ByteArray + ) + => Int -> Int -> payload -> union -> union +setUnionPayloadBits bitOffset bitWidth x u = + coerce $ pokeBitsToByteArray bitOffset bitWidth x (coerce u) + +getUnionPayloadBits :: forall payload union. + ( Bitfield payload + , Coercible union ByteArray + ) + => Int -> Int -> union -> payload +getUnionPayloadBits bitOffset bitWidth = + peekBitsFromByteArray bitOffset bitWidth . coerce + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- | Read a 'Storable' value from a 'ByteArray' +-- +-- Precondition: +-- +-- > sizeOf (undefined :: a) <= sizeofByteArray bytes +-- +-- It may well be the case that the ByteArray is /larger/ than the @a@ value; +-- 'peekFromByteArray' is intended to be used for reading values from otherwise +-- opaque unions (where @a@ is one such possible value), and so the bytearray +-- will be large enough to store the entire union. +peekFromByteArray :: forall a. Storable a => ByteArray -> a +peekFromByteArray bytes = + assert (sizeOf (undefined :: a) <= BA.sizeofByteArray bytes) $ + unsafePerformIO $ do + pinnedCopy <- thawToPinned bytes + BA.withMutableByteArrayContents pinnedCopy $ \ptr -> + peek (castPtr ptr) + +-- | Write a 'Storable' value to a 'ByteArray' +-- +-- Precondition: +-- +-- > sizeOf (undefined :: a) <= sizeOfByteArray bytes +-- +-- It may well be the case that the ByteArray is /larger/ than the @a@ value; +-- see also 'peekFromByteArray'. +pokeToByteArray :: + forall a. Storable a + => a + -> ByteArray + -> ByteArray +pokeToByteArray x bytes = + assert (sizeOf (undefined :: a) <= bytesSize) $ + unsafePerformIO $ do + pinnedCopy <- thawToPinned bytes + BA.withMutableByteArrayContents pinnedCopy $ \ptr -> + poke (castPtr ptr) x + -- The copy constructed by 'freezeByteArray' is /not/ pinned. + BA.freezeByteArray pinnedCopy 0 bytesSize + where + bytesSize = BA.sizeofByteArray bytes + +-- | @'peekBitsFromByteArray' o w bs@ reads a range of bits of a 'Storable' +-- value from a 'ByteArray' +-- +-- Preconditions: +-- +-- > o >= 0 +-- > w >= 1 && w <= 64 +-- > w <= 'sizeOf' (undefined :: a) * 8 +-- > o + w <= 'sizeofByteArray' bs * 8 +-- +-- It may well be the case that the ByteArray is /larger/ than the @union@ that +-- it represents; see also 'peekFromByteArray'. +peekBitsFromByteArray :: + forall a. Bitfield a + -- | Bit offset + => Int + -- | Bit width + -> Int + -> ByteArray + -> a +peekBitsFromByteArray o w bs = + unsafePerformIO $ do + pinnedCopy <- thawToPinned bs + BA.withMutableByteArrayContents pinnedCopy $ \ptr -> do + let bounds = (ptrL, ptrR) + ptrL = castPtr ptr + ptrR = ptrL `plusPtr` BA.sizeofByteArray bs + -- peekBitOffWidth assumes that the bit offset is in the inclusive + -- range @\[0, 7\]@, so we move the pointer and update the bit + -- offset accordingly + ptr' = ptr `plusPtr` (o `div` 8) + o' = o - ((o `div` 8) * 8) + Bitfield.peekBitOffWidth ptr' o' w bounds + +-- | @'pokeBitsToByteArray' o w v bs@ Write a range of bits from a 'Storable' +-- value to a 'ByteArray' +-- +-- Preconditions: +-- +-- > o >= 0 +-- > w >= 1 && w <= 64 +-- > w <= 'sizeOf' v * 8 +-- > o + w <= 'sizeofByteArray' bs * 8 +-- +-- It may well be the case that the ByteArray is /larger/ than the @union@ that +-- it represents; see also 'peekFromByteArray'. +pokeBitsToByteArray :: + forall a. Bitfield a + -- | Bit offset + => Int + -- | Bit width + -> Int + -> a + -> ByteArray + -> ByteArray +pokeBitsToByteArray o w v bs = + unsafePerformIO $ do + pinnedCopy <- thawToPinned bs + BA.withMutableByteArrayContents pinnedCopy $ \ptr -> do + let bounds = (ptrL, ptrR) + ptrL = castPtr ptr + ptrR = ptrL `plusPtr` bsSz + -- pokeBitOffWidth assumes that the bit offset is in the inclusive + -- range @\[0, 7\]@, so we move the pointer and update the bit + -- offset accordingly + ptr' = ptr `plusPtr` (o `div` 8) + o' = o - ((o `div` 8) * 8) + Bitfield.pokeBitOffWidth ptr' o' w bounds v + -- The copy constructed by 'freezeByteArray' is /not/ pinned. + BA.freezeByteArray pinnedCopy 0 bsSz + where + bsSz = BA.sizeofByteArray bs + +-- | Like 'Data.Primiteve.ByteArray.thawByteArray', but the new +-- | 'MutableByteArray' is pinned +thawToPinned :: ByteArray -> IO (MutableByteArray RealWorld) +thawToPinned src = do + dest <- BA.newPinnedByteArray n + BA.copyByteArray dest 0 src 0 n + return dest + where + n = BA.sizeofByteArray src diff --git a/src/HsBindgen/Runtime/Support/CAPI.hs b/src/HsBindgen/Runtime/Support/CAPI.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/CAPI.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- We capitalize module names, but use camelCase/PascalCase in code: +-- +-- - in types names: CapiFoo, FooCapiBar +-- - in variable names: capiFoo, fooCapiBar +module HsBindgen.Runtime.Support.CAPI ( + addCSource + , allocaAndPeek + -- * Auxiliary + , Data.List.unlines +) where + +import Data.List qualified +import Foreign (Ptr, Storable, alloca, peek) +import Language.Haskell.TH (DecsQ) +import Language.Haskell.TH.Syntax (ForeignSrcLang (LangC), addForeignSource) + +addCSource :: String -> DecsQ +addCSource src = do + addForeignSource LangC src + return [] + +allocaAndPeek :: Storable a => (Ptr a -> IO ()) -> IO a +allocaAndPeek k = alloca $ \ptr -> k ptr >> peek ptr diff --git a/src/HsBindgen/Runtime/Support/CompatHasField.hs b/src/HsBindgen/Runtime/Support/CompatHasField.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/CompatHasField.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Prelude required by generated bindings. +-- +-- This is a sub-mobule of "HsBindgen.Runtime.Support" that only exports +-- definitions from the @record-hasfield@ package. We do this because the +-- 'HasField' name is not unique. The name is used for two separate classes the +-- "GHC.Records" and "GHC.Records.Compat" modules, and we can't export the same +-- name from the "HsBindgen.Runtime.Support" twice. +module HsBindgen.Runtime.Support.CompatHasField ( + -- * 'HasField' + HasField(hasField) + , getField + , setField + , modifyField + ) where + +import GHC.Records.Compat (HasField (..), getField, setField) + +-- | Modify a field in a record. +modifyField :: forall x r a. (HasField x r a) => r -> (a -> a) -> r +modifyField r f = gen $ f val + where + (gen, val) = hasField @x r diff --git a/src/HsBindgen/Runtime/Support/FunPtr.hs b/src/HsBindgen/Runtime/Support/FunPtr.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/FunPtr.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | Function pointer utilities and type classes with pre-generated instances. +-- +-- This module provides the 'ToFunPtr' and 'FromFunPtr' type classes along with +-- Template Haskell generated instances for common function signatures. +-- +-- NOTE: For now, this module is classified "Support" because the definitions +-- are re-exported from the runtime prelude. Should we add definitions intended +-- for qualified import, we need to add a public module. +module HsBindgen.Runtime.Support.FunPtr ( + -- * Re-exports from "HsBindgen.Runtime.FunPtr.Class" + ToFunPtr (..) + , FromFunPtr (..) + , withFunPtr + , withFunPtrAs + ) where + +import HsBindgen.Runtime.Support.FunPtr.Class +import HsBindgen.Runtime.Support.TH.Instances () diff --git a/src/HsBindgen/Runtime/Support/FunPtr/Class.hs b/src/HsBindgen/Runtime/Support/FunPtr/Class.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/FunPtr/Class.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | Function pointer utilities and type class for converting Haskell functions +-- to C function pointers. +-- +-- This module provides a type class 'ToFunPtr' that allows for a uniform +-- interface to convert Haskell functions to C function pointers. +module HsBindgen.Runtime.Support.FunPtr.Class ( + -- * Type class + ToFunPtr(..) + , FromFunPtr(..) + + -- * Utilities + , withFunPtr + , withFunPtrAs + ) where + +import Control.Exception (bracket) +import Data.Coerce (Coercible, coerce) +import Foreign qualified as F +import GHC.Ptr qualified as Ptr + +-- | Type class for converting Haskell functions to C function pointers. +-- +class ToFunPtr a where + -- | Convert a Haskell function to a C function pointer. + -- + -- The caller is responsible for freeing the function pointer using + -- 'F.freeHaskellFunPtr' when it is no longer needed. + -- + toFunPtr :: a -> IO (F.FunPtr a) + +-- | Type class for converting C function pointers to Haskell functions. +-- +class FromFunPtr a where + -- | Convert C function pointer into a Haskell function. + fromFunPtr :: F.FunPtr a -> a + +-- | This function makes sure that 'F.freeHaskellFunPtr' is called after +-- 'toFunPtr' has allocated memory for a 'Ptr.FunPtr'. +-- +withFunPtr :: ToFunPtr a => a -> (Ptr.FunPtr a -> IO b) -> IO b +withFunPtr x = bracket (toFunPtr x) F.freeHaskellFunPtr + +-- | Useful for callbacks whose own type has no 'ToFunPtr' instance. Calls +-- 'withFunPtr' provided the callback is 'Coercible' to a signature @b@ that has one. +-- +-- Most users will never need this: when bindings are generated with @hs-bindgen@, +-- 'ToFunPtr' and 'FromFunPtr' instances are generated for their function types. +-- +-- The instances cover the raw C types, so @b@ is normally the same signature with your +-- own pointer tags and newtypes replaced by what they wrap: +-- +-- @ +-- data Node -- our own pointer tag +-- newtype Result = Result CInt -- our own status type +-- +-- onNode :: Ptr Node -> IO Result +-- +-- -- Ptr Node -> IO Result has no instance; Ptr Void -> IO CInt does. +-- withFunPtrAs \@(Ptr Void -> IO CInt) onNode $ \\fp -> c_walk tree fp +-- @ +-- +withFunPtrAs :: + forall b a r. (Coercible a b, ToFunPtr b) + => a -> (Ptr.FunPtr b -> IO r) -> IO r +withFunPtrAs f = withFunPtr (coerce f :: b) diff --git a/src/HsBindgen/Runtime/Support/LibC/Auxiliary.hsc b/src/HsBindgen/Runtime/Support/LibC/Auxiliary.hsc new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/LibC/Auxiliary.hsc @@ -0,0 +1,360 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | C standard library types that are not in @base@ +-- +-- These are re-exported in the public-facing module "HsBindgen.Runtime.LibC". +module HsBindgen.Runtime.Support.LibC.Auxiliary ( + -- * Floating Types + CFenvT + , CFexceptT + + -- * Wide Character Types + , CWintT(..) + , CMbstateT + , CWctransT(..) + , CWctypeT(..) + , CChar16T(..) + , CChar32T(..) + + -- * Time Types + , CTm(..) + ) where + +import Data.Bits (Bits, FiniteBits) +import Data.Ix (Ix) +import Data.Primitive.Types (Prim) +import Data.Proxy (Proxy (..)) +import Data.Word (Word16, Word32) +import Foreign.C.Types qualified as C +import Foreign.Ptr (Ptr) +import Foreign.Storable +import GHC.Records (HasField (..)) + +import HsBindgen.Runtime.HasCField (HasCField (..)) +import HsBindgen.Runtime.HasCField qualified as HasCField +import HsBindgen.Runtime.Support.Bitfield (Bitfield) +import HsBindgen.Runtime.HasFFIType (HasFFIType, ViaIdentity(..)) +import HsBindgen.Runtime.Marshal + +#include +#include +#include +#include + +{------------------------------------------------------------------------------- + Integral Types +-------------------------------------------------------------------------------} + +-- NOTE The \"least\" and \"fast\" types (such as @int_least32_t@) /cannot/ be +-- defined in the standard library because their implementations differ across +-- different @libc@ implementations, and users may choose which @libc@ to use +-- when running @hs-bindgen@. + +{------------------------------------------------------------------------------- + Floating Types +-------------------------------------------------------------------------------} + +-- TODO +-- +-- TODO CFloatT @float_t@ (arch, uses long double, math.h) + +-- TODO +-- +-- TODO CDoubleT @double_t@ (arch, uses long double, math.h) + +-------------------------------------------------------------------------------- + +-- | C @fenv_t@ type +-- +-- @fenv_t@ represents the entire floating-point environment. It is +-- implementation-specific, so this representation is opaque and may only be +-- used with a 'Ptr'. It is available since C99. It is defined in the @fenv.h@ +-- header file. +data CFenvT + +-------------------------------------------------------------------------------- + +-- | C @fexcept_t@ type +-- +-- @fexcept_t@ represents the floating-point status flags collectively, +-- including any status the implementation associates with the flags. It is +-- implementation-specific, so this representation is opaque and may only be +-- used with a 'Ptr'. It is available since C99. It is defined in the @fenv.h@ +-- header file. +data CFexceptT + +{------------------------------------------------------------------------------- + Standard Definitions +-------------------------------------------------------------------------------} + +-- TODO +-- +-- TODO CMaxAlignT @max_align_t@ (uses long double, C11, stddef.h) + +{------------------------------------------------------------------------------- + Wide Character Types +-------------------------------------------------------------------------------} + +-- | C @wint_t@ type +-- +-- @wint_t@ represents wide integers. It is available since C95. It is defined +-- in the @wchar.h@ and @wctype.h@ header files. +newtype CWintT = CWintT C.CUInt + deriving newtype ( + Bitfield + , Bits + , Bounded + , Enum + , Eq + , FiniteBits + , Integral + , Ix + , Num + , Ord + , Prim + , Read + , ReadRaw + , Real + , Show + , StaticSize + , Storable + , WriteRaw + ) + +deriving via ViaIdentity CWintT instance HasFFIType CWintT + +-------------------------------------------------------------------------------- + +-- | C @mbstate_t@ type +-- +-- @mbstate_t@ is a complete object type other than an array type that can hold +-- the conversion state information necessary to convert between sequences of +-- multibyte characters and wide characters. It is implementation-specific, so +-- this representation is opaque and may only be used with a 'Ptr'. It is +-- available since C95. It is defined in the @wchar.h@ and @uchar.h@ header +-- files. +data CMbstateT + +-------------------------------------------------------------------------------- + +-- | C @wctrans_t@ type +-- +-- @wctrans_t@ is a scalar type that can hold values which represent +-- locale-specific character transformations. It is available since C95. It is +-- defined in the @wctype.h@ header file. +newtype CWctransT = CWctransT (Ptr C.CInt) + deriving newtype ( + Eq + , Prim + , ReadRaw + , Show + , StaticSize + , Storable + , WriteRaw + ) + +deriving via ViaIdentity CWctransT instance HasFFIType CWctransT + +-------------------------------------------------------------------------------- + +-- | C @wctype_t@ type +-- +-- @wctype_t@ is a scalar type that can hold values which represent +-- locale-specific character classification categories. It is available since +-- C95. It is defined in the @wctype.h@ and @wchar.h@ header files. +newtype CWctypeT = CWctypeT C.CULong + deriving newtype ( + Eq + , Prim + , ReadRaw + , Show + , StaticSize + , Storable + , WriteRaw + ) + +deriving via ViaIdentity CWctypeT instance HasFFIType CWctypeT + +-------------------------------------------------------------------------------- + +-- | C @char16_t@ type +-- +-- @char16_t@ represents a 16-bit Unicode character. It is available since C11. +-- It is defined in the @uchar.h@ header file. +newtype CChar16T = CChar16T Word16 + deriving newtype ( + Bitfield + , Bits + , Bounded + , Enum + , Eq + , FiniteBits + , Integral + , Ix + , Num + , Ord + , Prim + , Read + , ReadRaw + , Real + , Show + , StaticSize + , Storable + , WriteRaw + ) + +deriving via ViaIdentity CChar16T instance HasFFIType CChar16T + +-------------------------------------------------------------------------------- + +-- | C @char32_t@ type +-- +-- @char32_t@ represents a 32-bit Unicode character. It is available since C11. +-- It is defined in the @uchar.h@ header file. +newtype CChar32T = CChar32T Word32 + deriving newtype ( + Bitfield + , Bits + , Bounded + , Enum + , Eq + , FiniteBits + , Integral + , Ix + , Num + , Ord + , Prim + , Read + , ReadRaw + , Real + , Show + , StaticSize + , Storable + , WriteRaw + ) + +deriving via ViaIdentity CChar32T instance HasFFIType CChar32T + +{------------------------------------------------------------------------------- + Localization Types +-------------------------------------------------------------------------------} + +-- TODO +-- +-- CLconv @struct lconv@ (fields added in C99, locale.h) + +{------------------------------------------------------------------------------- + Time Types +-------------------------------------------------------------------------------} + +-- | C @struct tm@ type +-- +-- @struct tm@ holds the components of a calendar time, called the +-- /broken-down time/. Note that only the fields defined in the standard are +-- represented here. It is defined in the @time.h@ header file, and it is made +-- available in other header files that use it. +data CTm = CTm { + tm_sec :: C.CInt -- ^ Seconds after the minute (@[0, 61]@) + , tm_min :: C.CInt -- ^ Minutes after the hour (@[0, 59]@) + , tm_hour :: C.CInt -- ^ Hours since midnight (@[0, 23]@) + , tm_mday :: C.CInt -- ^ Day of the month (@[1, 31]@) + , tm_mon :: C.CInt -- ^ Months since January (@[0, 11]@) + , tm_year :: C.CInt -- ^ Years since 1900 + , tm_wday :: C.CInt -- ^ Days since Sunday (@[0, 6]@) + , tm_yday :: C.CInt -- ^ Days since January 1 (@[0, 365]@) + , tm_isdst :: C.CInt -- ^ Daylight Saving Time flag + } + deriving stock (Eq, Show) + +instance HasCField CTm "tm_sec" where + type CFieldType CTm "tm_sec" = C.CInt + offset## _ _ = #offset struct tm, tm_sec + +instance HasCField CTm "tm_min" where + type CFieldType CTm "tm_min" = C.CInt + offset## _ _ = #offset struct tm, tm_min + +instance HasCField CTm "tm_hour" where + type CFieldType CTm "tm_hour" = C.CInt + offset## _ _ = #offset struct tm, tm_hour + +instance HasCField CTm "tm_mday" where + type CFieldType CTm "tm_mday" = C.CInt + offset## _ _ = #offset struct tm, tm_mday + +instance HasCField CTm "tm_mon" where + type CFieldType CTm "tm_mon" = C.CInt + offset## _ _ = #offset struct tm, tm_mon + +instance HasCField CTm "tm_year" where + type CFieldType CTm "tm_year" = C.CInt + offset## _ _ = #offset struct tm, tm_year + +instance HasCField CTm "tm_wday" where + type CFieldType CTm "tm_wday" = C.CInt + offset## _ _ = #offset struct tm, tm_wday + +instance HasCField CTm "tm_yday" where + type CFieldType CTm "tm_yday" = C.CInt + offset## _ _ = #offset struct tm, tm_yday + +instance HasCField CTm "tm_isdst" where + type CFieldType CTm "tm_isdst" = C.CInt + offset## _ _ = #offset struct tm, tm_isdst + +instance ( ty ~ (CFieldType CTm "tm_sec") + ) => HasField "tm_sec" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_sec") + +instance ( ty ~ (CFieldType CTm "tm_min") + ) => HasField "tm_min" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_min") + +instance ( ty ~ (CFieldType CTm "tm_hour") + ) => HasField "tm_hour" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_hour") + +instance ( ty ~ (CFieldType CTm "tm_mday") + ) => HasField "tm_mday" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_mday") + +instance ( ty ~ (CFieldType CTm "tm_mon") + ) => HasField "tm_mon" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_mon") + +instance ( ty ~ (CFieldType CTm "tm_year") + ) => HasField "tm_year" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_year") + +instance ( ty ~ (CFieldType CTm "tm_wday") + ) => HasField "tm_wday" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_wday") + +instance ( ty ~ (CFieldType CTm "tm_yday") + ) => HasField "tm_yday" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_yday") + +instance ( ty ~ (CFieldType CTm "tm_isdst") + ) => HasField "tm_isdst" (Ptr CTm) (Ptr ty) where + getField = HasCField.fromPtr (Proxy @"tm_isdst") + +instance ReadRaw CTm where + readRaw ptr = do + tm_sec <- (#peek struct tm, tm_sec) ptr + tm_min <- (#peek struct tm, tm_min) ptr + tm_hour <- (#peek struct tm, tm_hour) ptr + tm_mday <- (#peek struct tm, tm_mday) ptr + tm_mon <- (#peek struct tm, tm_mon) ptr + tm_year <- (#peek struct tm, tm_year) ptr + tm_wday <- (#peek struct tm, tm_wday) ptr + tm_yday <- (#peek struct tm, tm_yday) ptr + tm_isdst <- (#peek struct tm, tm_isdst) ptr + return CTm{..} + +instance StaticSize CTm where + staticSizeOf _ = #size struct tm + staticAlignment _ = #alignment struct tm diff --git a/src/HsBindgen/Runtime/Support/Ptr.hs b/src/HsBindgen/Runtime/Support/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/Ptr.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- NOTE: For now, this module is classified "Support" because the definitions +-- are re-exported from the runtime prelude. Should we add definitions intended +-- for qualified import, we need to add a public module. + +-- | Pointer utilities +module HsBindgen.Runtime.Support.Ptr ( + plusPtrElem + , safeCastFunPtr + ) where + +import Data.Coerce (Coercible, coerce) +import Foreign.Ptr +import Foreign.Storable + +-- | Advances the given address by the given offset in number of elements of +-- type @a@. +-- +-- Examples: +-- +-- > plusPtr (_ :: Ptr Word32) 2 -- moves the pointer by 2 bytes +-- > plusPtrElem (_ :: Ptr Word32) 2 -- moves the pointer by 2*4=8 bytes +-- +-- NOTE: if @a@ is an instance of 'Data.Primitive.Types.Prim', then you can +-- alternatively use 'Data.Primitive.Ptr.advancePtr'. +plusPtrElem :: forall a. Storable a => Ptr a -> Int -> Ptr a +plusPtrElem ptr i = ptr `plusPtr` (i * sizeOf (undefined :: a)) + +-- | Safely casts a 'FunPtr' to a 'FunPtr' of a different type. +safeCastFunPtr :: + forall a b. Coercible a b => FunPtr a -> FunPtr b +safeCastFunPtr = castFunPtr + where + _unused :: a -> b + _unused = coerce diff --git a/src/HsBindgen/Runtime/Support/SizedByteArray.hs b/src/HsBindgen/Runtime/Support/SizedByteArray.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/SizedByteArray.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_HADDOCK hide #-} + +module HsBindgen.Runtime.Support.SizedByteArray ( + SizedByteArray(..) + , zeroUnionValue + ) where + +import Data.Coerce (Coercible, coerce) +import Data.Primitive.ByteArray (ByteArray (..)) +import Data.Primitive.ByteArray qualified as BA +import Data.Proxy (Proxy (..)) +import Data.Word (Word8) +import Foreign (Storable (..)) +import Foreign.Ptr (Ptr, castPtr) +import GHC.TypeNats qualified as GHC + +import HsBindgen.Runtime.Marshal + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | t'SizedByteArray's provide deriving-via support for t'ByteArray'. +-- +-- Intended usage: +-- +-- > newtype Foo = Foo ByteArray +-- > deriving (Storable, Prim) via SizedByteArray 16 4 +-- +-- == Size +-- +-- In this example, the v'ByteArray' must have size 16. +-- +-- == Storable +-- +-- The derived 'Storable' instance does /not/ declare that the t'ByteArray' +-- /itself/ is memory aligned in any way (indeed, the t'ByteArray' may well not +-- be pinned). It merely states that if we use 'Storable' to pass the +-- t'ByteArray' to a C function, we must +-- +-- * allocate a temporary buffer (typically using 'Foreign.alloca') +-- * copy the v'ByteArray' into that buffer +-- * call the C function, passing a pointer to this buffer +-- +-- where /that temporary buffer/ must be memory aligned. +newtype SizedByteArray (size :: GHC.Nat) (alignment :: GHC.Nat) = + SizedByteArray ByteArray + deriving Storable via EquivStorable (SizedByteArray size alignment) + +{------------------------------------------------------------------------------- + StaticSize, ReadRaw, WriteRaw +-------------------------------------------------------------------------------} + +instance (GHC.KnownNat n, GHC.KnownNat m) => StaticSize (SizedByteArray n m) where + staticSizeOf _ = fromIntegral (GHC.natVal (Proxy @n)) + staticAlignment _ = fromIntegral (GHC.natVal (Proxy @m)) + +instance GHC.KnownNat n => ReadRaw (SizedByteArray n m) where + readRaw ptrSBA = do + let ptr = castPtr ptrSBA :: Ptr Word8 + size = fromIntegral $ GHC.natVal (Proxy @n) + arr <- BA.newByteArray size + BA.copyPtrToMutableByteArray arr 0 ptr size + SizedByteArray <$> BA.unsafeFreezeByteArray arr + +-- | Write a t'SizedByteArray' to the specified location, which must have the +-- correct alignment (matching @m@) +instance GHC.KnownNat n => WriteRaw (SizedByteArray n m) where + writeRaw ptrSBA (SizedByteArray arr) = do + let ptr = castPtr ptrSBA :: Ptr Word8 + size = fromIntegral $ GHC.natVal (Proxy @n) + BA.copyByteArrayToAddr ptr arr 0 size + +{-# DEPRECATED zeroUnionValue "Use HsBindgen.Runtime.Union.zero instead" #-} +-- | Create a value of a C union with all bytes initialized to zero. +zeroUnionValue :: forall a. (Coercible a ByteArray, StaticSize a) => a +zeroUnionValue = coerce $ BA.byteArrayFromListN n $ replicate n (0 :: Word8) + where + n = staticSizeOf (Proxy :: Proxy a) diff --git a/src/HsBindgen/Runtime/Support/TH/Instances.hs b/src/HsBindgen/Runtime/Support/TH/Instances.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/TH/Instances.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +-- | Generate FFI wrappers and 'ToFunPtr' class instances for 287 types. +module HsBindgen.Runtime.Support.TH.Instances () where + +import Foreign.C.Types + +import HsBindgen.Runtime.Support.FunPtr.Class +import HsBindgen.Runtime.Support.TH.Types + +-- | Generate instances for all @IO a@ functions +-- +-- > 17 FFI wrappers +-- > 17 FFI dynamic +-- > 17 ToFunPtr instances +-- > 17 FromFunPtr instances +-- +-- Total = 68 +-- +$(do + decls <- sequence + [ generateInstance retTy + | retTy <- allIOTypes + ] + return $ concat decls) + +-- | Generate instances for all @a -> IO b@ functions +-- +-- > (17 + 17) * 2 = 70 FFI wrappers +-- > (17 + 17) * 2 = 70 FFI dynamic +-- > (17 + 17) * 2 = 70 ToFunPtr instances +-- > (17 + 17) * 2 = 70 FromFunPtr instances +-- +-- Total = 280 +-- +$(do + decls <- sequence + [ generateInstance [t| $argTy -> $retTy |] + | argTy <- allPrimTypes ++ allPtrTypes + , retTy <- commonReturnTypes + ] + return $ concat decls) + +-- | Generate instances for @a -> b -> IO c@ functions. +-- +-- We can't generate all binary functions because that would mean +-- +-- > (17 + 18) * (17 + 18) * 18 = 22050 instances +-- +-- Instead we only generate instances for the most common C callback +-- signatures. +-- +-- > (5 + 5) * (5 + 5) * 2 = 200 FFI wrappers +-- > (5 + 5) * (5 + 5) * 2 = 200 FFI dynamic +-- > (5 + 5) * (5 + 5) * 2 = 200 ToFunPtr instances +-- > (5 + 5) * (5 + 5) * 2 = 200 FromFunPtr instances +-- +-- Total = 800 +-- +$(do + decls <- sequence + [ generateInstance [t| $argTy1 -> $argTy2 -> $retTy |] + | argTy1 <- commonPrimTypes ++ commonPtrTypes + , argTy2 <- commonPrimTypes ++ commonPtrTypes + , retTy <- commonReturnTypes + ] + return $ concat decls) diff --git a/src/HsBindgen/Runtime/Support/TH/Types.hs b/src/HsBindgen/Runtime/Support/TH/Types.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Support/TH/Types.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module provides TH splices that generate FFI wrappers and +-- 'ToFunPtr' instances that are called in different modules to paralellize +-- compilation and compile time code generation. +-- +module HsBindgen.Runtime.Support.TH.Types ( + -- * Types + allPrimTypes + , allPtrTypes + , allIOTypes + -- * Common Types + , commonPrimTypes + , commonPtrTypes + , commonReturnTypes + -- * Generate the instances + , generateInstance + ) where + +import Data.Void (Void) +import Foreign qualified as F +import Foreign.C.Types +import GHC.Ptr qualified as Ptr +import Language.Haskell.TH + +import HsBindgen.Runtime.Support.FunPtr.Class + +-- | Get primitive marshallable types +-- +allPrimTypes :: [Q Type] +allPrimTypes = + [ [t| CChar |] + , [t| CSChar |] + , [t| CUChar |] + , [t| CInt |] + , [t| CUInt |] + , [t| CShort |] + , [t| CUShort |] + , [t| CLong |] + , [t| CULong |] + , [t| CPtrdiff |] + , [t| CSize |] + , [t| CLLong |] + , [t| CULLong |] + , [t| CBool |] + , [t| CFloat |] + , [t| CDouble |] + , [t| Int |] + ] + +-- | Get pointer types for all primitive types +-- +allPtrTypes :: [Q Type] +allPtrTypes = [t| Ptr.Ptr Void |] + : [ [t| Ptr.Ptr $t |] + | t <- allPrimTypes + ] + +-- | Get IO types for all primitive types +-- +allIOTypes :: [Q Type] +allIOTypes = [t| IO () |] + : [ [t| IO $t |] + | t <- allPrimTypes + ] + +-- | A list of the most common primitive types found in C callbacks. +-- +commonPrimTypes :: [Q Type] +commonPrimTypes = + [ [t| CChar |] + , [t| CInt |] + , [t| CUInt |] + , [t| CDouble |] + , [t| CFloat |] + ] + +-- | Common pointer types, including the crucial @void*@ and @char*@. +-- +commonPtrTypes :: [Q Type] +commonPtrTypes = + [ [t| Ptr.Ptr Void |] + , [t| Ptr.Ptr CChar |] + , [t| Ptr.Ptr CInt |] + ] + +-- | The most common return types for callbacks are @void@ and integer status +-- codes. +-- +commonReturnTypes :: [Q Type] +commonReturnTypes = + [ [t| IO () |] + , [t| IO CInt |] + ] + +-- | Generate a foreign import wrapper and 'ToFunPtr' instance for a +-- particular type +-- +generateInstance :: Q Type -> Q [Dec] +generateInstance funTyQ = do + funTy <- funTyQ + + wrapperName <- newName ("wrapper_" ++ sanitizeTypeName (show funTy)) + dynamicName <- newName ("dynamic_" ++ sanitizeTypeName (show funTy)) + + foreignImportWrapper <- forImpD CCall + Safe + "wrapper" + wrapperName + [t| $funTyQ -> IO (F.FunPtr $funTyQ) |] + + foreignImportDynamic <- forImpD CCall + Safe + "dynamic" + dynamicName + [t| F.FunPtr $funTyQ -> $funTyQ |] + + toFunPtrInstance <- instanceD (return []) + [t| ToFunPtr $funTyQ |] + [ funD (mkName "toFunPtr") + [ clause [] (normalB (varE wrapperName)) [] + ] + ] + + fromFunPtrInstance <- instanceD (return []) + [t| FromFunPtr $funTyQ |] + [ funD (mkName "fromFunPtr") + [ clause [] (normalB (varE dynamicName)) [] + ] + ] + return [ foreignImportWrapper + , foreignImportDynamic + , toFunPtrInstance + , fromFunPtrInstance + ] + where + -- | Sanitize type name for use in generated names + sanitizeTypeName :: String -> String + sanitizeTypeName = concatMap sanitizeChar + where + sanitizeChar c + | c `elem` (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']) = [c] + | otherwise = "_" + diff --git a/src/HsBindgen/Runtime/Union.hs b/src/HsBindgen/Runtime/Union.hs new file mode 100644 --- /dev/null +++ b/src/HsBindgen/Runtime/Union.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Class for C unions +-- +-- This module is intended to be imported qualified. +-- +-- > import HsBindgen.Runtime.Prelude +-- > import HsBindgen.Runtime.Union qualified as Union +module HsBindgen.Runtime.Union ( + IsUnion (..) + , IsUnionViaReadRaw (..) + , get + , set + ) where + +import Data.Coerce (coerce) +import Data.Primitive.ByteArray qualified as BA +import Data.Proxy (Proxy (..)) +import Data.Word (Word8) +import Foreign.Ptr (Ptr, castPtr) +import GHC.Records.Compat qualified as Compat +import GHC.TypeNats (KnownNat) +import System.IO.Unsafe (unsafePerformIO) + +import HsBindgen.Runtime.Marshal (ReadRaw (..), StaticSize (staticSizeOf)) +import HsBindgen.Runtime.Support.SizedByteArray (SizedByteArray (..)) + +class IsUnion u where + -- | A 'zero' union value is a union value that is read from a zeroed-out byte + -- array + zero :: u + +-- | Helper type for deriving 'IsUnion' via 'ReadRaw' (and 'StaticSize') +-- +-- This helper type exists mainly for user convenience so that they can define +-- instances in cases where newtype-deriving is not possible. +newtype IsUnionViaReadRaw u = IsUnionViaReadRaw u + +-- | Helper instance for deriving 'IsUnion' via 'ReadRaw' (and 'StaticSize') +-- +-- This instance equivalent to the helper instance for newtype-deriving, but the +-- latter is probably more performant. +instance (StaticSize u, ReadRaw u) => IsUnion (IsUnionViaReadRaw u) where + zero = + unsafePerformIO $ + BA.withByteArrayContents zeroBytes $ \(ptr :: Ptr Word8) -> + IsUnionViaReadRaw <$> readRaw (castPtr ptr :: Ptr u) + where + n = staticSizeOf (Proxy @u) + zeroBytes = BA.byteArrayFromListN n $ replicate n (0 :: Word8) + +-- | Helper instance for newtype-deriving 'IsUnion' +-- +-- This instance is equivalent to the helper instance for deriving via +-- 'ReadRaw', but the former is probably more performant. +instance (KnownNat n, KnownNat m) => IsUnion (SizedByteArray n m) where + zero = coerce zeroBytes + where + n = staticSizeOf (Proxy :: Proxy (SizedByteArray n m)) + zeroBytes = BA.byteArrayFromListN n $ replicate n (0 :: Word8) + +get :: + forall field union a. Compat.HasField field union a + => union + -> a +get = Compat.getField @field + +set :: + forall field union a. (Compat.HasField field union a, IsUnion union) + => a + -> union +set = Compat.setField @field zero diff --git a/test/Test/HsBindgen/Runtime/Bitfield.hs b/test/Test/HsBindgen/Runtime/Bitfield.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/Bitfield.hs @@ -0,0 +1,327 @@ +-- Record fields are just used to make QuickCheck failures easy to read. +{-# LANGUAGE DuplicateRecordFields #-} + +module Test.HsBindgen.Runtime.Bitfield (tests) where + +import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Int +import Data.Proxy +import Data.Word +import Foreign qualified +import Test.QuickCheck ((===)) +import Test.QuickCheck qualified as QC +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import HsBindgen.Runtime.BitfieldPtr qualified as BitfieldPtr +import HsBindgen.Runtime.Marshal qualified as Marshal +import HsBindgen.Runtime.Support.Bitfield (Bitfield) +import HsBindgen.Runtime.Support.Bitfield qualified as Bitfield + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "HsBindgen.Runtime.Support.Bitfield" [ + testGroup "extend . narrow" [ + testProperty "Word8" (unsigned_extend_narrow_prop @Word8) + , testProperty "Word16" (unsigned_extend_narrow_prop @Word16) + , testProperty "Word32" (unsigned_extend_narrow_prop @Word32) + , testProperty "Word64" (unsigned_extend_narrow_prop @Word64) + , testProperty "Int8" (signed_extend_narrow_prop @Int8) + , testProperty "Int16" (signed_extend_narrow_prop @Int16) + , testProperty "Int32" (signed_extend_narrow_prop @Int32) + , testProperty "Int64" (signed_extend_narrow_prop @Int64) + ] + , testGroup "peek . poke" [ + testProperty "Struct1" (peek_poke_prop @Struct1) + , testProperty "Struct2" (peek_poke_prop @Struct2) + , testProperty "Struct3" (peek_poke_prop @Struct3) + , testProperty "Struct4" (peek_poke_prop @Struct4) + , testProperty "Struct5" (peek_poke_prop @Struct5) + , testProperty "Struct8" (peek_poke_prop @Struct8) + , testProperty "Struct11" (peek_poke_prop @Struct11) + ] + , testProperty + "getBitfieldLE . putBitfieldLE" + getBitfieldLE_putBitfieldLE_prop + , testProperty + "getBitfieldBE . putBitfieldBE" + getBitfieldBE_putBitfieldBE_prop + ] + +{------------------------------------------------------------------------------- + extend . narrow tests +-------------------------------------------------------------------------------} + +-- | Unsigned value with a given bit-width +-- +-- Constraints: +-- +-- * @width@ is in range @[1, typeWidth]@ +-- * Non-bit-field bits in @x@ are cleared +data UnsignedValue a = UnsignedValue { + x :: a + , width :: Int + } + deriving stock Show + +-- | Construct an 'UnsignedValue' +mkUnsignedValue :: (FiniteBits a, Num a) => a -> Int -> UnsignedValue a +mkUnsignedValue x' width = + let x = x' .&. Bitfield.loMask width + in UnsignedValue x width + +instance + (Bounded a, FiniteBits a, Integral a, QC.Arbitrary a) + => QC.Arbitrary (UnsignedValue a) + where + arbitrary = do + let typeWidth = finiteBitSize @a 0 + width <- QC.chooseInt (1, typeWidth) + x' <- QC.arbitrarySizedBoundedIntegral + return $ mkUnsignedValue x' width + + -- Shrinks value, keeping width + shrink (UnsignedValue x width) = + map (`mkUnsignedValue` width) (QC.shrink x) + +-- | Narrowing and then extending an unsigned value results in the same value +unsigned_extend_narrow_prop :: + (Bitfield a, Eq a, Show a) + => UnsignedValue a + -> QC.Property +unsigned_extend_narrow_prop (UnsignedValue x width) = + Bitfield.extend (Bitfield.narrow x width) width === x + +-- | Signed value with a given bit-width +-- +-- Constraints: +-- +-- * @width@ is in range @[1, typeWidth]@ +-- * Non-bit-field bits in @x@ are filled/cleared, depending on the sign +data SignedValue a = SignedValue { + x :: a + , width :: Int + } + deriving stock Show + +-- | Construct a 'SignedValue' +-- +-- The most significant bit of the bit-field determines the sign. +mkSignedValue :: (FiniteBits a, Num a) => a -> Int -> SignedValue a +mkSignedValue x' width = + let negative = testBit x' (width - 1) + x | negative = x' .|. Bitfield.hiMask width + | otherwise = x' .&. Bitfield.loMask width + in SignedValue x width + +instance + (Bounded a, FiniteBits a, Integral a, QC.Arbitrary a) + => QC.Arbitrary (SignedValue a) + where + arbitrary = do + let typeWidth = finiteBitSize @a 0 + width <- QC.chooseInt (1, typeWidth) + x' <- QC.arbitrarySizedBoundedIntegral + return $ mkSignedValue x' width + + -- Shrinks value, keeping width and sign + shrink (SignedValue x width) = + let negative = x < 0 + sameSign (SignedValue x' _) = (x' < 0) == negative + in filter sameSign $ map (`mkSignedValue` width) (QC.shrink x) + +-- | Narrowing and then extending a signed value results in the same value +signed_extend_narrow_prop :: + (Bitfield a, Num a, Ord a, Show a) + => SignedValue a + -> QC.Property +signed_extend_narrow_prop (SignedValue x width) = + QC.label (if x < 0 then "negative" else "non-negative") $ + Bitfield.extend (Bitfield.narrow x width) width === x + +{------------------------------------------------------------------------------- + peek . poke tests +-------------------------------------------------------------------------------} + +-- | Bit-field offset (bits) and width (bits) within @struct@ @a@ +-- +-- These parameters are mutually dependent on the size of the @struct@. +-- +-- Constraints: +-- +-- * @off@ is in range @[0, structWidth)@ +-- * @width@ is in range @[1, min structWidth 64]@ +-- * @off + width <= structWidth@ +data BitfieldParams a = BitfieldParams { + off :: Int + , width :: Int + } + deriving stock Show + +instance Marshal.StaticSize a => QC.Arbitrary (BitfieldParams a) where + arbitrary = do + let structWidth = 8 * Marshal.staticSizeOf @a Proxy + width <- QC.chooseInt (1, min structWidth 64) + off <- QC.chooseInt (0, structWidth - width) + return $ BitfieldParams off width + + -- Shrinks offset then width one at a time to ensure minimal counterexample + shrink (BitfieldParams off width) = + let shrinkOffs + | off == 0 = [] + | otherwise = [BitfieldParams o width | o <- [0 .. off - 1]] + shrinkWidths + | width == 1 = [] + | otherwise = [BitfieldParams off w | w <- [1 .. width - 1]] + in shrinkOffs ++ shrinkWidths + +-- | Poking and then peeking gets the same value (when narrowed) +peek_poke_prop :: forall a. + Marshal.StaticSize a + => BitfieldParams a -- ^ Bitfield offset and width + -> QC.Large Word64 -- ^ Test value + -> QC.Property +peek_poke_prop (BitfieldParams off width) (QC.Large x) = + QC.label label . QC.ioProperty $ do + y <- Foreign.allocaBytesAligned @a size 8 $ \ptr -> do + Foreign.fillBytes ptr 0xAA size + let bitfieldPtr = BitfieldPtr.mkBitfieldPtr ptr off width + BitfieldPtr.poke bitfieldPtr x + BitfieldPtr.peek bitfieldPtr + return $ y === Bitfield.narrow x width + where + size, structWidth :: Int + size = Marshal.staticSizeOf @a Proxy + structWidth = 8 * size + + -- This is a simplification that assumes the following alignment: + -- + -- > Marshal.staticAlignment @Word8 Proxy == 1 + -- > Marshal.staticAlignment @Word16 Proxy == 2 + -- > Marshal.staticAlignment @Word32 Proxy == 4 + -- > Marshal.staticAlignment @Word64 Proxy == 8 + -- + -- This is only possible because the test ensures that the @struct@ pointer + -- is 64-bit aligned. + -- + -- Labels may be inaccurate if run on an architecture where the alignment + -- differs, but the actual implementation does /not/ make such assumptions. + label :: String + label + | rem8 + width <= 8 = "aligned:1" + | rem16 + width <= 16 && 16 * quot16 + 16 <= structWidth = "aligned:2" + | rem32 + width <= 32 && 32 * quot32 + 32 <= structWidth = "aligned:4" + | rem64 + width <= 64 && 64 * quot64 + 64 <= structWidth = "aligned:8" + | otherwise = "bytes:" ++ show minBytes + + rem8, quot16, rem16, quot32, rem32, quot64, rem64 :: Int + rem8 = rem off 8 + (quot16, rem16) = quotRem off 16 + (quot32, rem32) = quotRem off 32 + (quot64, rem64) = quotRem off 64 + + minBytes :: Int + minBytes = case quotRem (rem8 + width) 8 of + (bytes, 0) -> bytes + (bytes, _) -> bytes + 1 + +{------------------------------------------------------------------------------- + getBitfield?E . putBitfield?E tests +-------------------------------------------------------------------------------} + +-- | Bit-field value, normalized offset (bits), and width (bits) +-- +-- Constraints: +-- +-- * @off@ is in range @[0, 7)@ +-- * @width@ is in range @[1, 64]@ +-- * Non-bit-field bits in @x@ are cleared +data BitfieldEndianParams = BitfieldEndianParams { + x :: Word64 + , off :: Int + , width :: Int + } + deriving stock Show + +-- | Construct a 'BitfieldEndianParams' +mkBitfieldEndianParams :: Word64 -> Int -> Int -> BitfieldEndianParams +mkBitfieldEndianParams x' off width = + let x = x' .&. Bitfield.loMask width + in BitfieldEndianParams x off width + +instance QC.Arbitrary BitfieldEndianParams where + arbitrary = do + off <- QC.chooseInt (0, 7) + width <- QC.chooseInt (1, 64) + x' <- QC.arbitrarySizedBoundedIntegral + return $ mkBitfieldEndianParams x' off width + + -- Shrinks value, then offset then width one at a time to ensure minimal + -- counterexample + shrink (BitfieldEndianParams x off width) = + let shrinkValues + | x == 0 = [] + | otherwise = + map (\x' -> mkBitfieldEndianParams x' off width) (QC.shrink x) + shrinkOffs + | off == 0 = [] + | otherwise = + map (\o -> mkBitfieldEndianParams x o width) [0 .. off - 1] + shrinkWidths + | width == 1 = [] + | otherwise = + map (\w -> mkBitfieldEndianParams x off w) [1 .. width - 1] + in shrinkValues ++ shrinkOffs ++ shrinkWidths + +-- | Encoding a bit-field as bytes and then decoding the bytes results in the +-- same value (little endian) +getBitfieldLE_putBitfieldLE_prop :: BitfieldEndianParams -> QC.Property +getBitfieldLE_putBitfieldLE_prop (BitfieldEndianParams x off width) = + let bytes = Bitfield.putBitfieldLE off width 0xAA 0xAA x + eey = Bitfield.getBitfieldLE off width bytes + in eey === Right x + +-- | Encoding a bit-field as bytes and then decoding the bytes results in the +-- same value (big endian) +getBitfieldBE_putBitfieldBE_prop :: BitfieldEndianParams -> QC.Property +getBitfieldBE_putBitfieldBE_prop (BitfieldEndianParams x off width) = + let bytes = Bitfield.putBitfieldBE off width 0xAA 0xAA x + eey = Bitfield.getBitfieldBE off width bytes + in eey === Right x + +{------------------------------------------------------------------------------- + Auxiliary types + + These types are needed in order to use the "HsBindgen.Runtime.BitfieldPtr" + API. They are just used to specify the size of a @struct@ that contains a + bit-field. +-------------------------------------------------------------------------------} + +type Struct1 = Word8 + +type Struct2 = Word16 + +data Struct3 + +instance Marshal.StaticSize Struct3 where + staticSizeOf _ = 3 + staticAlignment _ = 1 + +type Struct4 = Word32 + +data Struct5 + +instance Marshal.StaticSize Struct5 where + staticSizeOf _ = 5 + staticAlignment _ = 1 + +type Struct8 = Word64 + +data Struct11 + +instance Marshal.StaticSize Struct11 where + staticSizeOf _ = 11 + staticAlignment _ = 1 diff --git a/test/Test/HsBindgen/Runtime/CBool.hs b/test/Test/HsBindgen/Runtime/CBool.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/CBool.hs @@ -0,0 +1,134 @@ +module Test.HsBindgen.Runtime.CBool (tests) where + +import Control.Monad.Trans.Writer.Strict (Writer, execWriter, tell) +import Data.Monoid (Sum (getSum)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@=?)) + +import HsBindgen.Runtime.CBool qualified as CBool + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "HsBindgen.Runtime.CBool" [ + testTrue + , testFalse + , testIsTrue + , testIsFalse + , testFromBool + , testToBool + , testAnd + , testOr + , testNot + , testBool + , testIf_ + , testWhen + , testUnless + ] + +newtype TestBool = TestBool Int + deriving newtype (Eq, Num, Show) -- do not add any more instances + +testTrue :: TestTree +testTrue = testCase "true" $ TestBool 1 @=? CBool.true + +testFalse :: TestTree +testFalse = testCase "false" $ TestBool 0 @=? CBool.false + +testIsTrue :: TestTree +testIsTrue = testGroup "isTrue" [ + testCase "0" $ False @=? CBool.isTrue @TestBool 0 + , testCase "1" $ True @=? CBool.isTrue @TestBool 1 + , testCase "2" $ True @=? CBool.isTrue @TestBool 2 + , testCase "0.1" $ True @=? CBool.isTrue @Float 0.1 + ] + +testIsFalse :: TestTree +testIsFalse = testGroup "isFalse" [ + testCase "0" $ True @=? CBool.isFalse @TestBool 0 + , testCase "1" $ False @=? CBool.isFalse @TestBool 1 + , testCase "2" $ False @=? CBool.isFalse @TestBool 2 + , testCase "0.1" $ False @=? CBool.isFalse @Float 0.1 + ] + +testFromBool :: TestTree +testFromBool = testGroup "fromBool" [ + testCase "True" $ TestBool 1 @=? CBool.fromBool True + , testCase "False" $ TestBool 0 @=? CBool.fromBool False + ] + +testToBool :: TestTree +testToBool = testGroup "toBool" [ + testCase "0" $ False @=? CBool.toBool @TestBool 0 + , testCase "1" $ True @=? CBool.toBool @TestBool 1 + , testCase "2" $ True @=? CBool.toBool @TestBool 2 + , testCase "0.1" $ True @=? CBool.toBool @Float 0.1 + ] + +testAnd :: TestTree +testAnd = testGroup "(&&)" [ + testCase "bothT" $ TestBool 1 @=? TestBool 2 CBool.&& TestBool 3 + , testCase "leftF" $ TestBool 0 @=? TestBool 0 CBool.&& undefined + , testCase "rightF" $ TestBool 0 @=? TestBool 1 CBool.&& TestBool 0 + ] + +testOr :: TestTree +testOr = testGroup "(||)" [ + testCase "bothF" $ TestBool 0 @=? TestBool 0 CBool.|| TestBool 0 + , testCase "leftT" $ TestBool 1 @=? TestBool 2 CBool.|| undefined + , testCase "rightT" $ TestBool 1 @=? TestBool 0 CBool.|| TestBool 2 + ] + +testNot :: TestTree +testNot = testGroup "not" [ + testCase "0" $ TestBool 1 @=? CBool.not @TestBool 0 + , testCase "1" $ TestBool 0 @=? CBool.not @TestBool 1 + , testCase "2" $ TestBool 0 @=? CBool.not @TestBool 2 + , testCase "0.1" $ 0.0 @=? CBool.not @Float 0.1 + ] + +testBool :: TestTree +testBool = testGroup "bool" [ + testCase "0" $ 'f' @=? CBool.bool @TestBool 'f' 't' 0 + , testCase "1" $ 't' @=? CBool.bool @TestBool 'f' 't' 1 + , testCase "2" $ 't' @=? CBool.bool @TestBool 'f' 't' 2 + , testCase "0.1" $ 't' @=? CBool.bool @Float 'f' 't' 0.1 + ] + +testIf_ :: TestTree +testIf_ = testGroup "if_" [ + testCase "0" $ 'f' @=? CBool.if_ @TestBool 0 't' 'f' + , testCase "1" $ 't' @=? CBool.if_ @TestBool 1 't' 'f' + , testCase "2" $ 't' @=? CBool.if_ @TestBool 2 't' 'f' + , testCase "0.1" $ 't' @=? CBool.if_ @Float 0.1 't' 'f' + ] + +testWhen :: TestTree +testWhen = testGroup "when" [ + testCase "0" $ 0 @=? aux (CBool.when @TestBool 0 act) + , testCase "1" $ 1 @=? aux (CBool.when @TestBool 1 act) + , testCase "2" $ 1 @=? aux (CBool.when @TestBool 1 act) + , testCase "0.1" $ 1 @=? aux (CBool.when @Float 0.1 act) + ] + where + aux :: Writer (Sum Int) () -> Int + aux = getSum . execWriter + + act :: Writer (Sum Int) () + act = tell (pure 1) + +testUnless :: TestTree +testUnless = testGroup "unless" [ + testCase "0" $ 1 @=? aux (CBool.unless @TestBool 0 act) + , testCase "1" $ 0 @=? aux (CBool.unless @TestBool 1 act) + , testCase "2" $ 0 @=? aux (CBool.unless @TestBool 1 act) + , testCase "0.1" $ 0 @=? aux (CBool.unless @Float 0.1 act) + ] + where + aux :: Writer (Sum Int) () -> Int + aux = getSum . execWriter + + act :: Writer (Sum Int) () + act = tell (pure 1) diff --git a/test/Test/HsBindgen/Runtime/CEnum.hs b/test/Test/HsBindgen/Runtime/CEnum.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/CEnum.hs @@ -0,0 +1,1081 @@ +module Test.HsBindgen.Runtime.CEnum (tests) where + +import Control.Monad (forM_) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NonEmpty +import Foreign.C qualified as FC +import GHC.Show (appPrec1) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.ExpectedFailure (expectFail) +import Test.Tasty.HUnit (testCase, (@=?)) +import Test.Tasty.QuickCheck (Arbitrary (arbitrary), Property, chooseInt, + counterexample, testProperty, (===)) +import Text.Read (Read (readPrec), minPrec, readMaybe) + +import HsBindgen.Runtime.CEnum (AsCEnum (..), AsSequentialCEnum (..), + CEnum (CEnumZ), CEnumException (..), + SequentialCEnum) +import HsBindgen.Runtime.CEnum qualified as CEnum + +import Test.HsBindgen.Runtime.CEnumArbitrary () +import Test.Util.Tasty + +read_show_prop :: forall a. (Show a, Read a, Eq a) => a -> Property +read_show_prop x = read (show x) === x + +newtype Precedence = MkPrecedence Int + deriving stock Show + +instance Arbitrary Precedence where + arbitrary = MkPrecedence <$> chooseInt (minPrec, appPrec1) + +readsPrec_showsPrec_prop + :: forall a. (Show a, Read a, Eq a) + => a -> Precedence -> Property +readsPrec_showsPrec_prop x (MkPrecedence d) = counterexample errMsg isElem + where + parsedValues = readsPrec d (showsPrec d x "") + isElem = (x,"") `elem` parsedValues + errMsg = "expected element " <> show x + <> " not found in possible parsed values " <> show parsedValues + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "HsBindgen.Runtime.CEnum" [ + testGroup "CEnum" [ + testNoValue + , testGenSingleValue + , testGenPosValue + , testGenNegValue + ] + , testGroup "SequentialCEnum" [ + testSeqSingleValue + , testSeqPosValue + , testSeqNegValue + , testNastyValue + ] + ] + +{------------------------------------------------------------------------------- + CEnum: no values +-------------------------------------------------------------------------------} + +newtype NoValue = NoValue { + _unwrapNoValue :: FC.CUInt + } + deriving newtype Eq + +instance CEnum NoValue where + type CEnumZ NoValue = FC.CUInt + + declaredValues _ = CEnum.declaredValuesFromList [] + showsUndeclared = CEnum.showsWrappedUndeclared "NoValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "NoValue" + +instance Show NoValue where + showsPrec = CEnum.shows + +instance Read NoValue where + readPrec = CEnum.readPrec + +deriving via AsCEnum NoValue instance Bounded NoValue + +deriving via AsCEnum NoValue instance Enum NoValue + +deriving via AsCEnum NoValue instance Arbitrary NoValue + +testNoValue :: TestTree +testNoValue = testGroup "NoValue" [ + testCase "isDeclared" $ False @=? CEnum.isDeclared v1 + , testCase "mkDeclared" $ Nothing @=? CEnum.mkDeclared @NoValue 1 + , testCase "Show" $ "NoValue 1" @=? show v1 + , testGroup "Read" [ + testCase "!declared/pos" $ (Just v1) @=? readMaybe "NoValue 1" + -- We inherit the behavior of downstream Read instances. For example, + -- we parse negative values even for unsigned types such as + -- 'FC.CUInt'. + , expectFail + $ testCase "!declared/neg" $ Nothing @=? readMaybe @NoValue "NoValue (-1)" + , testCase "noparse" $ Nothing @=? readMaybe @NoValue "noparse" + -- Similarly, we parse invalid Haskell; the same is true for derived + -- instances, + , expectFail + $ testCase "noparse/neg" $ Nothing @=? readMaybe @NoValue "NoValue -1" + , testProperty "read . show" (read_show_prop @NoValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @NoValue) + ] + , testCase "getNames" $ [] @=? CEnum.getNames v1 + , testGroup "Bounded" [ + testCase "minBound" $ CEnumEmpty @=?! minBound @NoValue + , testCase "maxBound" $ CEnumEmpty @=?! maxBound @NoValue + ] + , testGroup "Enum" [ + testCase "succ" $ CEnumNotDeclared 1 @=?! succ v1 + , testCase "pred" $ CEnumNotDeclared 1 @=?! pred v1 + , testCase "toEnum" $ CEnumNotDeclared 1 @=?! toEnum @NoValue 1 + , testCase "fromEnum" $ CEnumNotDeclared 1 @=?! fromEnum v1 + , testCase "enumFrom" $ CEnumNotDeclared 1 @=?! enumFrom v1 + , testGroup "enumFromThen" [ + testCase "from==then" $ + CEnumFromEqThen 1 @=?! enumFromThen v1 v1 + , testCase "!declared" $ + CEnumNotDeclared 1 @=?! enumFromThen v1 v2 + ] + , testCase "enumFromTo" $ CEnumNotDeclared 1 @=?! enumFromTo v1 v2 + , testGroup "enumFromThenTo" [ + testCase "from==then" $ + CEnumFromEqThen 1 @=?! enumFromThenTo v1 v1 v2 + , testCase "!declared" $ + CEnumNotDeclared 1 @=?! enumFromThenTo v1 v2 v2 + ] + ] + ] + where + v1, v2 :: NoValue + v1 = NoValue 1 + v2 = NoValue 2 + +{------------------------------------------------------------------------------- + CEnum: single value +-------------------------------------------------------------------------------} + +newtype GenSingleValue = GenSingleValue { + _unwrapGenSingleValue :: FC.CUInt + } + deriving newtype Eq + +instance CEnum GenSingleValue where + type CEnumZ GenSingleValue = FC.CUInt + + declaredValues _ = CEnum.declaredValuesFromList [(1, "OK" :| ["SUCCESS"])] + showsUndeclared = CEnum.showsWrappedUndeclared "GenSingleValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "GenSingleValue" + +instance Show GenSingleValue where + showsPrec = CEnum.shows + +instance Read GenSingleValue where + readPrec = CEnum.readPrec + +deriving via AsCEnum GenSingleValue instance Bounded GenSingleValue + +deriving via AsCEnum GenSingleValue instance Enum GenSingleValue + +deriving via AsCEnum GenSingleValue instance Arbitrary GenSingleValue + +testGenSingleValue :: TestTree +testGenSingleValue = testGroup "GenSingleValue" [ + testGroup "isDeclared" [ + testCase "True" $ True @=? CEnum.isDeclared v1 + , testCase "False" $ False @=? CEnum.isDeclared v2 + ] + , testGroup "mkDeclared" [ + testCase "declared" $ Just v1 @=? CEnum.mkDeclared 1 + , testCase "!declared" $ Nothing @=? CEnum.mkDeclared @GenSingleValue 2 + ] + , testGroup "Show" [ + testCase "declared" $ "OK" @=? show v1 + , testCase "!declared" $ "GenSingleValue 2" @=? show v2 + ] + , testGroup "Read" [ + testCase "declared/ok" $ (Just v1) @=? readMaybe "OK" + , testCase "declared/sc" $ (Just v1) @=? readMaybe "SUCCESS" + , testCase "declared/parentheses" $ (Just v1) @=? readMaybe "(OK)" + , testCase "declared/parentheses/spaces" $ (Just v1) @=? readMaybe "( OK )" + , testCase "declared/spaces" $ (Just v1) @=? readMaybe " OK " + , testCase "!declared" $ (Just v2) @=? readMaybe "GenSingleValue 2" + , testCase "noParse" $ Nothing @=? readMaybe @GenSingleValue "noParse" + , testProperty "read . show" (read_show_prop @GenSingleValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @GenSingleValue) + ] + , testGroup "getNames" [ + testCase "declared" $ ["OK", "SUCCESS"] @=? CEnum.getNames v1 + , testCase "!declared" $ [] @=? CEnum.getNames v2 + ] + , testGroup "Bounded" [ + testCase "minBound" $ v1 @=? minBound + , testCase "maxBound" $ v1 @=? maxBound + ] + , testGroup "Enum" [ + testGroup "succ" [ + testCase "!successor" $ CEnumNoSuccessor 1 @=?! succ v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! succ v2 + ] + , testGroup "pred" [ + testCase "!predecessor" $ CEnumNoPredecessor 1 @=?! pred v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! pred v2 + ] + , testGroup "toEnum" [ + testCase "declared" $ v1 @=? toEnum 1 + , testCase "!declared" $ + CEnumNotDeclared 2 @=?! toEnum @GenSingleValue 2 + ] + , testGroup "fromEnum" [ + testCase "declared" $ 1 @=? fromEnum v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! fromEnum v2 + ] + , testGroup "enumFrom" [ + testCase "declared" $ [v1] @=? enumFrom v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! enumFrom v2 + ] + , testGroup "enumFromThen" [ + testCase "from==then" $ + CEnumFromEqThen 1 @=?! enumFromThen v1 v1 + , testCase "!declared from" $ + CEnumNotDeclared 2 @=?! enumFromThen v2 v1 + , testCase "!declared then" $ + CEnumNotDeclared 2 @=?! enumFromThen v1 v2 + ] + , testGroup "enumFromTo" [ + testCase "declared" $ [v1] @=? enumFromTo v1 v1 + , testCase "!declared from" $ + CEnumNotDeclared 2 @=?! enumFromTo v2 v1 + , testCase "!declared to" $ + CEnumNotDeclared 2 @=?! enumFromTo v1 v2 + ] + , testGroup "enumFromThenTo" [ + testCase "from==then" $ + CEnumFromEqThen 1 @=?! enumFromThenTo v1 v1 v2 + , testCase "!declared from" $ + CEnumNotDeclared 2 @=?! enumFromThenTo v2 v1 v1 + , testCase "!declared then" $ + CEnumNotDeclared 2 @=?! enumFromThenTo v1 v2 v2 + ] + ] + ] + where + v1, v2 :: GenSingleValue + v1 = GenSingleValue 1 + v2 = GenSingleValue 2 + +{------------------------------------------------------------------------------- + CEnum: positive values +-------------------------------------------------------------------------------} + +newtype GenPosValue = GenPosValue { + _unwrapGenPosValue :: FC.CUInt + } + deriving newtype Eq + +instance CEnum GenPosValue where + type CEnumZ GenPosValue = FC.CUInt + + declaredValues _ = CEnum.declaredValuesFromList [ + (100, NonEmpty.singleton "CONTINUE") + , (101, NonEmpty.singleton "SWITCHING_PROTOCOLS") + , (200, NonEmpty.singleton "OK") + , (201, NonEmpty.singleton "CREATED") + , (202, NonEmpty.singleton "ACCEPTED") + , (301, NonEmpty.singleton "MOVED_PERMANENTLY") + , (400, NonEmpty.singleton "BAD_REQUEST") + , (401, NonEmpty.singleton "UNAUTHORIZED") + , (403, NonEmpty.singleton "FORBIDDEN") + , (404, NonEmpty.singleton "NOT_FOUND") + ] + showsUndeclared = CEnum.showsWrappedUndeclared "GenPosValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "GenPosValue" + +instance Show GenPosValue where + showsPrec = CEnum.shows + +instance Read GenPosValue where + readPrec = CEnum.readPrec + +deriving via AsCEnum GenPosValue instance Bounded GenPosValue + +deriving via AsCEnum GenPosValue instance Enum GenPosValue + +deriving via AsCEnum GenPosValue instance Arbitrary GenPosValue + +testGenPosValue :: TestTree +testGenPosValue = testGroup "GenPosValue" [ + testGroup "isDeclared" [ + testCase "declared" $ True @=? CEnum.isDeclared v301 + , testCase "!declared" $ False @=? CEnum.isDeclared v300 + ] + , testGroup "mkDeclared" [ + testCase "declared" $ Just v301 @=? CEnum.mkDeclared 301 + , testCase "!declared" $ Nothing @=? CEnum.mkDeclared @GenPosValue 300 + ] + , testGroup "Show" [ + testCase "declared" $ "OK" @=? show v200 + , testCase "!declared" $ "GenPosValue 300" @=? show v300 + ] + , testGroup "Read" [ + testCase "declared" $ (Just v200) @=? readMaybe "OK" + , testCase "declared/parentheses" $ (Just v200) @=? readMaybe "(OK)" + , testCase "declared/parentheses/spaces" $ (Just v200) @=? readMaybe "( OK )" + , testCase "declared/spaces" $ (Just $ v200) @=? readMaybe " OK " + , testCase "!declared" $ (Just v300) @=? readMaybe "GenPosValue 300" + , testCase "noparse" $ Nothing @=? readMaybe @GenPosValue "noparse" + , testProperty "read . show" (read_show_prop @GenPosValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @GenPosValue) + ] + , testGroup "getNames" [ + testCase "declared" $ ["OK"] @=? CEnum.getNames v200 + , testCase "!declared" $ [] @=? CEnum.getNames v300 + ] + , testGroup "Bounded" [ + testCase "minBound" $ v100 @=? minBound + , testCase "maxBound" $ v404 @=? maxBound + ] + , testGroup "Enum" [ + testGroup "succ" [ + testCase "valid" $ v301 @=? succ v202 + , testCase "!successor" $ CEnumNoSuccessor 404 @=?! succ v404 + , testCase "!declared" $ CEnumNotDeclared 300 @=?! succ v300 + ] + , testGroup "pred" [ + testCase "valid" $ v202 @=? pred v301 + , testCase "!predecessor" $ CEnumNoPredecessor 100 @=?! pred v100 + , testCase "!declared" $ CEnumNotDeclared 300 @=?! pred v300 + ] + , testGroup "toEnum" [ + testCase "declared" $ v301 @=? toEnum 301 + , testCase "!declared" $ + CEnumNotDeclared 300 @=?! toEnum @GenPosValue 300 + ] + , testGroup "fromEnum" [ + testCase "declared" $ 301 @=? fromEnum v301 + , testCase "!declared" $ CEnumNotDeclared 300 @=?! fromEnum v300 + ] + , testGroup "enumFrom" [ + testCase "valid" $ + [v301, v400, v401, v403, v404] @=? enumFrom v301 + , testCase "max" $ [v404] @=? enumFrom v404 + , testCase "!declared" $ CEnumNotDeclared 300 @=?! enumFrom v300 + ] + , testGroup "enumFromThen" [ + testCase "increasing 1" $ + [v301, v400, v401, v403, v404] @=? enumFromThen v301 v400 + , testCase "increasing 2" $ + [v200, v202, v400, v403] @=? enumFromThen v200 v202 + , testCase "increasing 3" $ + [v101, v202, v401] @=? enumFromThen v101 v202 + , testCase "decreasing 1" $ + [v202, v201, v200, v101, v100] @=? enumFromThen v202 v201 + , testCase "decreasing 2" $ + [v404, v401, v301, v201, v101] @=? enumFromThen v404 v401 + , testCase "decreasing 3" $ + [v403, v301, v200] @=? enumFromThen v403 v301 + , testCase "from==then" $ + CEnumFromEqThen 200 @=?! enumFromThen v200 v200 + , testCase "!declared from" $ + CEnumNotDeclared 300 @=?! enumFromThen v300 v404 + , testCase "!declared then" $ + CEnumNotDeclared 300 @=?! enumFromThen v200 v300 + ] + , testGroup "enumFromTo" [ + testCase "valid" $ + [v202, v301, v400, v401] @=? enumFromTo v202 v401 + , testCase "!declared from" $ + CEnumNotDeclared 300 @=?! enumFromTo v300 v401 + , testCase "!declared to" $ + CEnumNotDeclared 300 @=?! enumFromTo v200 v300 + ] + , testGroup "enumFromThenTo" [ + testCase "increasing 1" $ + [v301, v400, v401] @=? enumFromThenTo v301 v400 v401 + , testCase "increasing 2" $ + [v200, v202, v400] @=? enumFromThenTo v200 v202 v401 + , testCase "increasing 3" $ + [v100, v201, v400] @=? enumFromThenTo v100 v201 v403 + , testCase "decreasing 1" $ + [v202, v201, v200] @=? enumFromThenTo v202 v201 v200 + , testCase "decreasing 2" $ + [v404, v401, v301, v201] @=? enumFromThenTo v404 v401 v200 + , testCase "decreasing 3" $ + [v404, v400, v201] @=? enumFromThenTo v404 v400 v200 + , testCase "from==then" $ + CEnumFromEqThen 200 @=?! enumFromThenTo v200 v200 v400 + , testCase "!declared from" $ + CEnumNotDeclared 300 @=?! enumFromThenTo v300 v400 v403 + , testCase "!declared then" $ + CEnumNotDeclared 300 @=?! enumFromThenTo v200 v300 v400 + , testCase "!declared to" $ + CEnumNotDeclared 300 @=?! enumFromThenTo v100 v200 v300 + ] + ] + ] + where + v100, v101, v200, v201, v202, v301, v400, v401, v403, v404 :: GenPosValue + v100 = GenPosValue 100 + v101 = GenPosValue 101 + v200 = GenPosValue 200 + v201 = GenPosValue 201 + v202 = GenPosValue 202 + v301 = GenPosValue 301 + v400 = GenPosValue 400 + v401 = GenPosValue 401 + v403 = GenPosValue 403 + v404 = GenPosValue 404 + + v300 :: GenPosValue + v300 = GenPosValue 300 + +{------------------------------------------------------------------------------- + CEnum: negative values +-------------------------------------------------------------------------------} + +newtype GenNegValue = GenNegValue { + _unwrapGenNegValue :: FC.CInt + } + deriving newtype Eq + +instance CEnum GenNegValue where + type CEnumZ GenNegValue = FC.CInt + + declaredValues _ = CEnum.declaredValuesFromList [ + (-201, NonEmpty.singleton "REALLY_TERRIBLE") + , (-200, NonEmpty.singleton "TERRIBLE") + , (-101, NonEmpty.singleton "REALLY_BAD") + , (-100, NonEmpty.singleton "BAD") + , (0, "NEUTRAL" :| ["UNREMARKABLE"]) + , (100, NonEmpty.singleton "GOOD") + , (101, NonEmpty.singleton "REALLY_GOOD") + , (200, NonEmpty.singleton "GREAT") + , (201, NonEmpty.singleton "REALLY_GREAT") + ] + showsUndeclared = CEnum.showsWrappedUndeclared "GenNegValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "GenNegValue" + +instance Show GenNegValue where + showsPrec = CEnum.shows + +instance Read GenNegValue where + readPrec = CEnum.readPrec + +deriving via AsCEnum GenNegValue instance Bounded GenNegValue + +deriving via AsCEnum GenNegValue instance Enum GenNegValue + +deriving via AsCEnum GenNegValue instance Arbitrary GenNegValue + +testGenNegValue :: TestTree +testGenNegValue = testGroup "GenNegValue" [ + testGroup "isDeclared" [ + testCase "declared" $ True @=? CEnum.isDeclared n100 + , testCase "!declared" $ False @=? CEnum.isDeclared n202 + ] + , testGroup "mkDeclared" [ + testCase "declared" $ Just n100 @=? CEnum.mkDeclared (-100) + , testCase "!declared" $ Nothing @=? CEnum.mkDeclared @GenNegValue 300 + ] + , testGroup "Show" [ + testCase "declared" $ "NEUTRAL" @=? show z + , testCase "!declared" $ "GenNegValue (-202)" @=? show n202 + ] + , testGroup "Read" [ + testCase "declared" $ (Just $ GenNegValue 0) @=? readMaybe "NEUTRAL" + , testCase "declared/parentheses" $ (Just p200) @=? readMaybe "(GREAT)" + , testCase "declared/parentheses/spaces" $ (Just p200) @=? readMaybe "( GREAT )" + , testCase "declared/spaces" $ (Just n100) @=? readMaybe " BAD " + , testCase "!declared" $ (Just n100) @=? readMaybe "GenNegValue (-100)" + , testCase "noparse" $ Nothing @=? readMaybe @GenNegValue "noparse" + , testProperty "read . show" (read_show_prop @GenNegValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @GenNegValue) + ] + , testGroup "getNames" [ + testCase "declared" $ ["NEUTRAL", "UNREMARKABLE"] @=? CEnum.getNames z + , testCase "!declared" $ [] @=? CEnum.getNames n202 + ] + , testGroup "Bounded" [ + testCase "minBound" $ n201 @=? minBound + , testCase "maxBound" $ p201 @=? maxBound + ] + , testGroup "Enum" [ + testGroup "succ" [ + testCase "valid" $ n101 @=? succ n200 + , testCase "!successor" $ CEnumNoSuccessor 201 @=?! succ p201 + , testCase "!declared" $ CEnumNotDeclared (-202) @=?! succ n202 + ] + , testGroup "pred" [ + testCase "valid" $ n100 @=? pred z + , testCase "!predecessor" $ CEnumNoPredecessor (-201) @=?! pred n201 + , testCase "!declared" $ CEnumNotDeclared 202 @=?! pred p202 + ] + , testGroup "toEnum" [ + testCase "declared" $ n101 @=? toEnum (-101) + , testCase "!declared" $ + CEnumNotDeclared (-102) @=?! toEnum @GenNegValue (-102) + ] + , testGroup "fromEnum" [ + testCase "declared" $ 101 @=? fromEnum p101 + , testCase "!declared" $ CEnumNotDeclared (-202) @=?! fromEnum n202 + ] + , testGroup "enumFrom" [ + testCase "valid" $ + [n100, z, p100, p101, p200, p201] @=? enumFrom n100 + , testCase "max" $ [p201] @=? enumFrom p201 + , testCase "!declared" $ CEnumNotDeclared (-202) @=?! enumFrom n202 + ] + , testGroup "enumFromThen" [ + testCase "increasing 1" $ + [n101, n100, z, p100, p101, p200, p201] + @=? enumFromThen n101 n100 + , testCase "increasing 2" $ + [n101, z, p101, p201] @=? enumFromThen n101 z + , testCase "increasing 3" $ + [n101, p100, p201] @=? enumFromThen n101 p100 + , testCase "decreasing 1" $ + [p100, z, n100, n101, n200, n201] @=? enumFromThen p100 z + , testCase "decreasing 2" $ + [p100, n100, n200] @=? enumFromThen p100 n100 + , testCase "decreasing 3" $ + [p201, p100, n101] @=? enumFromThen p201 p100 + , testCase "from==then" $ + CEnumFromEqThen (-100) @=?! enumFromThen n100 n100 + , testCase "!declared from" $ + CEnumNotDeclared (-202) @=?! enumFromThen n202 n200 + , testCase "!declared then" $ + CEnumNotDeclared 202 @=?! enumFromThen p200 p202 + ] + , testGroup "enumFromTo" [ + testCase "valid" $ + [n101, n100, z, p100, p101] @=? enumFromTo n101 p101 + , testCase "!declared from" $ + CEnumNotDeclared (-202) @=?! enumFromTo n202 p101 + , testCase "!declared to" $ + CEnumNotDeclared 202 @=?! enumFromTo n101 p202 + ] + , testGroup "enumFromThenTo" [ + testCase "increasing 1" $ + [n101, n100, z, p100, p101] @=? enumFromThenTo n101 n100 p101 + , testCase "increasing 2" $ + [n101, z, p101] @=? enumFromThenTo n101 z p200 + , testCase "increasing 3" $ + [n201, n100] @=? enumFromThenTo n201 n100 p100 + , testCase "decreasing 1" $ + [p101, p100, z, n100, n101] @=? enumFromThenTo p101 p100 n101 + , testCase "decreasing 2" $ + [p101, z, n101] @=? enumFromThenTo p101 z n200 + , testCase "decreasing 3" $ + [p201, p100] @=? enumFromThenTo p201 p100 n100 + , testCase "from==then" $ + CEnumFromEqThen (-101) @=?! enumFromThenTo n101 n101 p100 + , testCase "!declared from" $ + CEnumNotDeclared (-202) @=?! enumFromThenTo n202 n200 p200 + , testCase "!declared then" $ + CEnumNotDeclared 202 @=?! enumFromThenTo z p202 p202 + , testCase "!declared to" $ + CEnumNotDeclared 202 @=?! enumFromThenTo z p100 p202 + ] + ] + ] + where + n201, n200, n101, n100, z, p100, p101, p200, p201 :: GenNegValue + n201 = GenNegValue (-201) + n200 = GenNegValue (-200) + n101 = GenNegValue (-101) + n100 = GenNegValue (-100) + z = GenNegValue 0 + p100 = GenNegValue 100 + p101 = GenNegValue 101 + p200 = GenNegValue 200 + p201 = GenNegValue 201 + + n202 :: GenNegValue + n202 = GenNegValue (-202) + p202 = GenNegValue 202 + +{------------------------------------------------------------------------------- + SequentialCEnum: single value +-------------------------------------------------------------------------------} + +newtype SeqSingleValue = SeqSingleValue { + _unwrapSeqSingleValue :: FC.CUInt + } + deriving newtype Eq + +instance CEnum SeqSingleValue where + type CEnumZ SeqSingleValue = FC.CUInt + + declaredValues _ = CEnum.declaredValuesFromList [(1, "OK" :| ["SUCCESS"])] + showsUndeclared = CEnum.showsWrappedUndeclared "SeqSingleValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "SeqSingleValue" + +instance Show SeqSingleValue where + showsPrec = CEnum.shows + +instance Read SeqSingleValue where + readPrec = CEnum.readPrec + +instance SequentialCEnum SeqSingleValue where + minDeclaredValue = SeqSingleValue 1 + maxDeclaredValue = SeqSingleValue 1 + +deriving via AsCEnum SeqSingleValue instance Bounded SeqSingleValue + +deriving via AsCEnum SeqSingleValue instance Enum SeqSingleValue + +deriving via AsCEnum SeqSingleValue instance Arbitrary SeqSingleValue + +testSeqSingleValue :: TestTree +testSeqSingleValue = testGroup "SeqSingleValue" [ + testGroup "isDeclared" [ + testCase "True" $ True @=? CEnum.isDeclared v1 + , testCase "False" $ False @=? CEnum.isDeclared v2 + ] + , testGroup "mkDeclared" [ + testCase "declared" $ Just v1 @=? CEnum.mkDeclared 1 + , testCase "!declared" $ Nothing @=? CEnum.mkDeclared @SeqSingleValue 2 + ] + , testGroup "Show" [ + testCase "declared" $ "OK" @=? show v1 + , testCase "!declared" $ "SeqSingleValue 2" @=? show v2 + ] + , testGroup "Read" [ + testCase "declared" $ (Just v1) @=? readMaybe "OK" + , testCase "!declared" $ (Just v2) @=? readMaybe "SeqSingleValue 2" + , testCase "noparse" $ Nothing @=? readMaybe @SeqSingleValue "noparse" + , testProperty "read . show" (read_show_prop @SeqSingleValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @GenSingleValue) + ] + , testGroup "getNames" [ + testCase "declared" $ ["OK", "SUCCESS"] @=? CEnum.getNames v1 + , testCase "!declared" $ [] @=? CEnum.getNames v2 + ] + , testGroup "Bounded" [ + testCase "minBound" $ v1 @=? minBound + , testCase "maxBound" $ v1 @=? maxBound + ] + , testGroup "Enum" [ + testGroup "succ" [ + testCase "!successor" $ CEnumNoSuccessor 1 @=?! succ v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! succ v2 + ] + , testGroup "pred" [ + testCase "!predecessor" $ CEnumNoPredecessor 1 @=?! pred v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! pred v2 + ] + , testGroup "toEnum" [ + testCase "declared" $ v1 @=? toEnum 1 + , testCase "!declared" $ + CEnumNotDeclared 2 @=?! toEnum @SeqSingleValue 2 + ] + , testGroup "fromEnum" [ + testCase "declared" $ 1 @=? fromEnum v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! fromEnum v2 + ] + , testGroup "enumFrom" [ + testCase "declared" $ [v1] @=? enumFrom v1 + , testCase "!declared" $ CEnumNotDeclared 2 @=?! enumFrom v2 + ] + , testGroup "enumFromThen" [ + testCase "from==then" $ + CEnumFromEqThen 1 @=?! enumFromThen v1 v1 + , testCase "!declared from" $ + CEnumNotDeclared 2 @=?! enumFromThen v2 v1 + , testCase "!declared then" $ + CEnumNotDeclared 2 @=?! enumFromThen v1 v2 + ] + , testGroup "enumFromTo" [ + testCase "declared" $ [v1] @=? enumFromTo v1 v1 + , testCase "!declared from" $ + CEnumNotDeclared 2 @=?! enumFromTo v2 v1 + , testCase "!declared to" $ + CEnumNotDeclared 2 @=?! enumFromTo v1 v2 + ] + , testGroup "enumFromThenTo" [ + testCase "from==then" $ + CEnumFromEqThen 1 @=?! enumFromThenTo v1 v1 v2 + , testCase "!declared from" $ + CEnumNotDeclared 2 @=?! enumFromThenTo v2 v1 v1 + , testCase "!declared then" $ + CEnumNotDeclared 2 @=?! enumFromThenTo v1 v2 v2 + ] + ] + ] + where + v1, v2 :: SeqSingleValue + v1 = SeqSingleValue 1 + v2 = SeqSingleValue 2 + +{------------------------------------------------------------------------------- + SequentialCEnum: positive values +-------------------------------------------------------------------------------} + +newtype SeqPosValue = SeqPosValue { + _unwrapSeqPosValue :: FC.CUInt + } + deriving newtype Eq + +instance CEnum SeqPosValue where + type CEnumZ SeqPosValue = FC.CUInt + + declaredValues _ = CEnum.declaredValuesFromList [ + (1, "A" :| ["ALPHA"]) + , (2, "B" :| ["BETA"]) + , (3, NonEmpty.singleton "C") + , (4, NonEmpty.singleton "D") + , (5, NonEmpty.singleton "E") + , (6, NonEmpty.singleton "F") + , (7, NonEmpty.singleton "G") + , (8, NonEmpty.singleton "H") + , (9, NonEmpty.singleton "I") + , (10, NonEmpty.singleton "J") + ] + showsUndeclared = CEnum.showsWrappedUndeclared "SeqPosValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "SeqPosValue" + +instance Show SeqPosValue where + showsPrec = CEnum.shows + +instance Read SeqPosValue where + readPrec = CEnum.readPrec + +instance SequentialCEnum SeqPosValue where + minDeclaredValue = SeqPosValue 1 + maxDeclaredValue = SeqPosValue 10 + +deriving via AsSequentialCEnum SeqPosValue instance Bounded SeqPosValue + +deriving via AsSequentialCEnum SeqPosValue instance Enum SeqPosValue + +deriving via AsSequentialCEnum SeqPosValue instance Arbitrary SeqPosValue + +testSeqPosValue :: TestTree +testSeqPosValue = testGroup "SeqPosValue" [ + testGroup "isDeclared" [ + testCase "declared" . forM_ [1..10] $ \i -> + True @=? CEnum.isDeclared (SeqPosValue i) + , testCase "low" $ False @=? CEnum.isDeclared v0 + , testCase "high" $ False @=? CEnum.isDeclared v11 + ] + , testGroup "mkDeclared" [ + testCase "declared" . forM_ [1..10] $ \i -> + Just (SeqPosValue i) @=? CEnum.mkDeclared i + , testCase "low" $ Nothing @=? CEnum.mkDeclared @SeqPosValue 0 + , testCase "high" $ Nothing @=? CEnum.mkDeclared @SeqPosValue 11 + ] + , testGroup "Show" [ + testCase "declared" $ "A" @=? show v1 + , testCase "!declared" $ "SeqPosValue 0" @=? show v0 + ] + , testGroup "Read" [ + testCase "declared" $ (Just v3) @=? readMaybe "C" + , testCase "!declared" $ (Just v11) @=? readMaybe "SeqPosValue 11" + , testCase "noparse" $ Nothing @=? readMaybe @SeqPosValue "noparse" + , testProperty "read . show" (read_show_prop @SeqPosValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @SeqPosValue) + ] + , testGroup "getNames" [ + testCase "declared" $ ["A", "ALPHA"] @=? CEnum.getNames v1 + , testCase "!declared" $ [] @=? CEnum.getNames v0 + ] + , testGroup "Bounded" [ + testCase "minBound" $ v1 @=? minBound + , testCase "maxBound" $ v10 @=? maxBound + ] + , testGroup "Enum" [ + testGroup "succ" [ + testCase "valid" . forM_ [1..9] $ \i -> + SeqPosValue (i + 1) @=? succ (SeqPosValue i) + , testCase "max" $ CEnumNoSuccessor 10 @=?! succ v10 + , testCase "low" $ CEnumNotDeclared 0 @=?! succ v0 + , testCase "high" $ CEnumNotDeclared 11 @=?! succ v11 + ] + , testGroup "pred" [ + testCase "valid" . forM_ [2..10] $ \i -> + SeqPosValue (i - 1) @=? pred (SeqPosValue i) + , testCase "min" $ CEnumNoPredecessor 1 @=?! pred v1 + , testCase "low" $ CEnumNotDeclared 0 @=?! pred v0 + , testCase "high" $ CEnumNotDeclared 11 @=?! pred v11 + ] + , testGroup "toEnum" [ + testCase "declared" . forM_ [1..10] $ \i -> + SeqPosValue (fromIntegral i) @=? toEnum i + , testCase "low" $ CEnumNotDeclared 0 @=?! toEnum @SeqPosValue 0 + , testCase "high" $ CEnumNotDeclared 11 @=?! toEnum @SeqPosValue 11 + ] + , testGroup "fromEnum" [ + testCase "declared" . forM_ [1..10] $ \i -> + fromIntegral i @=? fromEnum (SeqPosValue i) + , testCase "low" $ CEnumNotDeclared 0 @=?! fromEnum v0 + , testCase "high" $ CEnumNotDeclared 11 @=?! fromEnum v11 + ] + , testGroup "enumFrom" [ + testCase "valid" $ [SeqPosValue i | i <- [5..10]] @=? enumFrom v5 + , testCase "max" $ [SeqPosValue 10] @=? enumFrom v10 + , testCase "low" $ CEnumNotDeclared 0 @=?! enumFrom v0 + , testCase "high" $ CEnumNotDeclared 11 @=?! enumFrom v11 + ] + , testGroup "enumFromThen" [ + testCase "increasing" $ + [SeqPosValue i | i <- [2, 4 .. 10]] @=? enumFromThen v2 v4 + , testCase "decreasing" $ + [SeqPosValue i | i <- [10, 6 .. 1]] @=? enumFromThen v10 v6 + , testCase "from==then" $ CEnumFromEqThen 2 @=?! enumFromThen v2 v2 + , testCase "!declared from" $ + CEnumNotDeclared 0 @=?! enumFromThen v0 v1 + , testCase "!declared then" $ + CEnumNotDeclared 11 @=?! enumFromThen v5 v11 + ] + , testGroup "enumFromTo" [ + testCase "valid" $ + [SeqPosValue i | i <- [4..6]] @=? enumFromTo v4 v6 + , testCase "!declared from" $ + CEnumNotDeclared 0 @=?! enumFromTo v0 v5 + , testCase "!declared to" $ + CEnumNotDeclared 11 @=?! enumFromTo v5 v11 + ] + , testGroup "enumFromThenTo" [ + testCase "increasing" $ + [SeqPosValue i | i <- [2, 4 .. 9]] @=? enumFromThenTo v2 v4 v9 + , testCase "decreasing" $ + [SeqPosValue i | i <- [10, 8 .. 4]] @=? enumFromThenTo v10 v8 v4 + , testCase "from==then" $ + CEnumFromEqThen 2 @=?! enumFromThenTo v2 v2 v9 + , testCase "!declared from" $ + CEnumNotDeclared 0 @=?! enumFromThenTo v0 v2 v9 + , testCase "!declared then" $ + CEnumNotDeclared 11 @=?! enumFromThenTo v9 v11 v11 + , testCase "!declared to" $ + CEnumNotDeclared 11 @=?! enumFromThenTo v5 v9 v11 + ] + ] + ] + where + v0, v1, v2, v4, v5, v6, v8, v9, v10, v11 :: SeqPosValue + v0 = SeqPosValue 0 + v1 = SeqPosValue 1 + v2 = SeqPosValue 2 + v3 = SeqPosValue 3 + v4 = SeqPosValue 4 + v5 = SeqPosValue 5 + v6 = SeqPosValue 6 + v8 = SeqPosValue 8 + v9 = SeqPosValue 9 + v10 = SeqPosValue 10 + v11 = SeqPosValue 11 + +{------------------------------------------------------------------------------- + SequentialCEnum: negative values +-------------------------------------------------------------------------------} + +newtype SeqNegValue = SeqNegValue { + _unwrapSeqNegValue :: FC.CInt + } + deriving newtype Eq + +instance CEnum SeqNegValue where + type CEnumZ SeqNegValue = FC.CInt + + declaredValues _ = CEnum.declaredValuesFromList [ + (-5, NonEmpty.singleton "GARBAGE") + , (-4, NonEmpty.singleton "TERRIBLE") + , (-3, NonEmpty.singleton "BAD") + , (-2, NonEmpty.singleton "DISAPPOINTING") + , (-1, NonEmpty.singleton "UGH") + , (0, "NEUTRAL" :| ["UNREMARKABLE"]) + , (1, NonEmpty.singleton "MEH") + , (2, NonEmpty.singleton "OK") + , (3, NonEmpty.singleton "GOOD") + , (4, NonEmpty.singleton "GREAT") + , (5, NonEmpty.singleton "SPECTACULAR") + ] + showsUndeclared = CEnum.showsWrappedUndeclared "SeqNegValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "SeqNegValue" + +instance Show SeqNegValue where + showsPrec = CEnum.shows + +instance Read SeqNegValue where + readPrec = CEnum.readPrec + +instance SequentialCEnum SeqNegValue where + minDeclaredValue = SeqNegValue (-5) + maxDeclaredValue = SeqNegValue 5 + +deriving via AsSequentialCEnum SeqNegValue instance Bounded SeqNegValue + +deriving via AsSequentialCEnum SeqNegValue instance Enum SeqNegValue + +deriving via AsSequentialCEnum SeqNegValue instance Arbitrary SeqNegValue + +testSeqNegValue :: TestTree +testSeqNegValue = testGroup "SeqNegValue" [ + testGroup "isDeclared" [ + testCase "declared" . forM_ [-5..5] $ \i -> + True @=? CEnum.isDeclared (SeqNegValue i) + , testCase "low" $ False @=? CEnum.isDeclared n6 + , testCase "high" $ False @=? CEnum.isDeclared p6 + ] + , testGroup "mkDeclared" [ + testCase "declared" . forM_ [-5..5] $ \i -> + Just (SeqNegValue i) @=? CEnum.mkDeclared i + , testCase "low" $ Nothing @=? CEnum.mkDeclared @SeqNegValue (-6) + , testCase "high" $ Nothing @=? CEnum.mkDeclared @SeqNegValue 6 + ] + , testGroup "Show" [ + testCase "declared" $ "NEUTRAL" @=? show z + , testCase "!declared" $ "SeqNegValue (-6)" @=? show n6 + ] + , testGroup "Read" [ + testCase "declared" $ (Just n3) @=? readMaybe "BAD" + , testCase "!declared" $ (Just $ SeqNegValue (-100)) @=? readMaybe "SeqNegValue (-100)" + , testCase "noparse" $ Nothing @=? readMaybe @SeqNegValue "noparse" + , testProperty "read . show" (read_show_prop @SeqNegValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @SeqNegValue) + ] + , testGroup "getNames" [ + testCase "declared" $ + ["NEUTRAL", "UNREMARKABLE"] @=? CEnum.getNames z + , testCase "!declared" $ [] @=? CEnum.getNames n6 + ] + , testGroup "Bounded" [ + testCase "minBound" $ n5 @=? minBound + , testCase "maxBound" $ p5 @=? maxBound + ] + , testGroup "Enum" [ + testGroup "succ" [ + testCase "valid" . forM_ [-5..4] $ \i -> + SeqNegValue (i + 1) @=? succ (SeqNegValue i) + , testCase "max" $ CEnumNoSuccessor 5 @=?! succ p5 + , testCase "low" $ CEnumNotDeclared (-6) @=?! succ n6 + , testCase "high" $ CEnumNotDeclared 6 @=?! succ p6 + ] + , testGroup "pred" [ + testCase "valid" . forM_ [-4..5] $ \i -> + SeqNegValue (i - 1) @=? pred (SeqNegValue i) + , testCase "min" $ CEnumNoPredecessor (-5) @=?! pred n5 + , testCase "low" $ CEnumNotDeclared (-6) @=?! pred n6 + , testCase "high" $ CEnumNotDeclared 6 @=?! pred p6 + ] + , testGroup "toEnum" [ + testCase "declared" . forM_ [-5..5] $ \i -> + SeqNegValue (fromIntegral i) @=? toEnum i + , testCase "low" $ + CEnumNotDeclared (-6) @=?! toEnum @SeqNegValue (-6) + , testCase "high" $ CEnumNotDeclared 6 @=?! toEnum @SeqNegValue 6 + ] + , testGroup "fromEnum" [ + testCase "declared" . forM_ [-5..5] $ \i -> + fromIntegral i @=? fromEnum (SeqNegValue i) + , testCase "low" $ CEnumNotDeclared (-6) @=?! fromEnum n6 + , testCase "high" $ CEnumNotDeclared 6 @=?! fromEnum p6 + ] + , testGroup "enumFrom" [ + testCase "valid" $ [SeqNegValue i | i <- [-1..5]] @=? enumFrom n1 + , testCase "max" $ [SeqNegValue 5] @=? enumFrom p5 + , testCase "low" $ CEnumNotDeclared (-6) @=?! enumFrom n6 + , testCase "high" $ CEnumNotDeclared 6 @=?! enumFrom p6 + ] + , testGroup "enumFromThen" [ + testCase "increasing" $ + [SeqNegValue i | i <- [-3, -1 .. 5]] @=? enumFromThen n3 n1 + , testCase "decreasing" $ + [SeqNegValue i | i <- [4, 1 .. -5]] @=? enumFromThen p4 p1 + , testCase "from==then" $ + CEnumFromEqThen (-3) @=?! enumFromThen n3 n3 + , testCase "!declared from" $ + CEnumNotDeclared (-6) @=?! enumFromThen n6 n3 + , testCase "!declared then" $ + CEnumNotDeclared 6 @=?! enumFromThen n1 p6 + ] + , testGroup "enumFromTo" [ + testCase "valid" $ + [SeqNegValue i | i <- [-3..3]] @=? enumFromTo n3 p3 + , testCase "!declared from" $ + CEnumNotDeclared (-6) @=?! enumFromTo n6 p1 + , testCase "!declared to" $ + CEnumNotDeclared 6 @=?! enumFromTo n1 p6 + ] + , testGroup "enumFromThenTo" [ + testCase "increasing" $ + [SeqNegValue i | i <- [-3, -1 .. 4]] @=? enumFromThenTo n3 n1 p4 + , testCase "decreasing" $ + [SeqNegValue i | i <- [5, 3 .. -3]] @=? enumFromThenTo p5 p3 n3 + , testCase "from==then" $ + CEnumFromEqThen (-3) @=?! enumFromThenTo n3 n3 p3 + , testCase "!declared from" $ + CEnumNotDeclared (-6) @=?! enumFromThenTo n6 n3 p4 + , testCase "!declared then" $ + CEnumNotDeclared 6 @=?! enumFromThenTo n1 p6 p6 + , testCase "!declared to" $ + CEnumNotDeclared 6 @=?! enumFromThenTo n3 n1 p6 + ] + ] + ] + where + n6, n5, n3, n1, z, p1, p3, p4, p5, p6 :: SeqNegValue + n6 = SeqNegValue (-6) + n5 = SeqNegValue (-5) + n3 = SeqNegValue (-3) + n1 = SeqNegValue (-1) + z = SeqNegValue 0 + p1 = SeqNegValue 1 + p3 = SeqNegValue 3 + p4 = SeqNegValue 4 + p5 = SeqNegValue 5 + p6 = SeqNegValue 6 + +{------------------------------------------------------------------------------- + NastiEnum +-------------------------------------------------------------------------------} + +newtype NastyValue = NastyValue { + _unwrapNastyValue :: FC.CInt + } + deriving newtype Eq + +instance CEnum NastyValue where + type CEnumZ NastyValue = FC.CInt + + declaredValues _ = CEnum.declaredValuesFromList [ + (-2, NonEmpty.singleton "Nas") + , (-1, NonEmpty.singleton "NastyValueNeg") + , (0, "Nasty" :| ["NastyValue"]) + , (1, NonEmpty.singleton "NastyVal") + , (2, NonEmpty.singleton "NastyValuePos") + ] + showsUndeclared = CEnum.showsWrappedUndeclared "NastyValue" + readPrecUndeclared = CEnum.readPrecWrappedUndeclared "NastyValue" + +instance Show NastyValue where + showsPrec = CEnum.shows + +instance Read NastyValue where + readPrec = CEnum.readPrec + +instance SequentialCEnum NastyValue where + minDeclaredValue = NastyValue (-2) + maxDeclaredValue = NastyValue 2 + +deriving via AsSequentialCEnum NastyValue instance Bounded NastyValue + +deriving via AsSequentialCEnum NastyValue instance Enum NastyValue + +deriving via AsSequentialCEnum NastyValue instance Arbitrary NastyValue + +testNastyValue :: TestTree +testNastyValue = testGroup "NastyValue" [ + testGroup "Show" [ + testCase "declared" $ "Nasty" @=? show z + , testCase "!declared" $ "NastyValue (-6)" @=? show n6 + ] + , testGroup "Read" [ + testCase "declared" $ (Just n2) @=? readMaybe "Nas" + , testCase "declared" $ (Just n1) @=? readMaybe "NastyValueNeg" + , testCase "declared" $ (Just z) @=? readMaybe "Nasty" + , testCase "declared" $ (Just z) @=? readMaybe "NastyValue" + , testCase "declared" $ (Just p1) @=? readMaybe "NastyVal" + , testCase "declared" $ (Just p2) @=? readMaybe "NastyValuePos" + , testCase "!declared" $ (Just $ NastyValue (-100)) @=? readMaybe "NastyValue (-100)" + , testCase "!declared" $ (Just $ NastyValue (100)) @=? readMaybe "NastyValue (100)" + , testCase "noparse" $ Nothing @=? readMaybe @NastyValue "noparse" + , testProperty "read . show" (read_show_prop @NastyValue) + , testProperty "readsPrec . showsPrec" (readsPrec_showsPrec_prop @NastyValue) + ] + ] + where + n6, n1, z, p1, p2 :: NastyValue + n6 = NastyValue (-6) + n2 = NastyValue (-2) + n1 = NastyValue (-1) + z = NastyValue 0 + p1 = NastyValue 1 + p2 = NastyValue 2 diff --git a/test/Test/HsBindgen/Runtime/CEnumArbitrary.hs b/test/Test/HsBindgen/Runtime/CEnumArbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/CEnumArbitrary.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.HsBindgen.Runtime.CEnumArbitrary () where + +import Test.QuickCheck (Arbitrary (arbitrary), Gen, Small (Small)) + +import HsBindgen.Runtime.CEnum (AsCEnum (WrapCEnum), + AsSequentialCEnum (WrapSequentialCEnum), + CEnum (CEnumZ, toCEnum)) + +instance CEnum a => Arbitrary (AsCEnum a) where + arbitrary = do + (Small n) <- arbitrary :: Gen (Small (CEnumZ a)) + pure $ WrapCEnum $ toCEnum n + +instance CEnum a => Arbitrary (AsSequentialCEnum a) where + arbitrary = do + (Small n) <- arbitrary :: Gen (Small (CEnumZ a)) + pure $ WrapSequentialCEnum $ toCEnum n diff --git a/test/Test/HsBindgen/Runtime/ConstantArray.hs b/test/Test/HsBindgen/Runtime/ConstantArray.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/ConstantArray.hs @@ -0,0 +1,11 @@ +module Test.HsBindgen.Runtime.ConstantArray (tests) where + +import Test.Tasty + +tests :: TestTree +tests = testGroup "HsBindgen.Runtime.ConstantArray" [ + ] + +-- TODO +-- +-- Add tests! diff --git a/test/Test/HsBindgen/Runtime/IncompleteArray.hs b/test/Test/HsBindgen/Runtime/IncompleteArray.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/IncompleteArray.hs @@ -0,0 +1,11 @@ +module Test.HsBindgen.Runtime.IncompleteArray (tests) where + +import Test.Tasty + +tests :: TestTree +tests = testGroup "HsBindgen.Runtime.IncompleteArray" [ + ] + +-- TODO +-- +-- Add tests! diff --git a/test/Test/HsBindgen/Runtime/Macro.hs b/test/Test/HsBindgen/Runtime/Macro.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/Macro.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.HsBindgen.Runtime.Macro (tests) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase, (@=?)) + +import HsBindgen.Runtime.Macro qualified as Macro + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "HsBindgen.Runtime.Macro" [ + testGroup "render" [ + testCase "object-like" $ + rendersAs "#define FOO 1 + 2" $ + Macro.objectLike "FOO" ["1", "+", "2"] + , testCase "object-like, empty body" $ + rendersAs "#define FOO" $ + Macro.objectLike "FOO" [] + , testCase "function-like" $ + rendersAs "#define ADD(x, y) x + y" $ + Macro.functionLike "ADD" ["x", "y"] ["x", "+", "y"] + , testCase "function-like, no parameters" $ + rendersAs "#define NOW() 0" $ + Macro.functionLike "NOW" [] ["0"] + , testCase "function-like, empty body" $ + rendersAs "#define IGNORE(x)" $ + Macro.functionLike "IGNORE" ["x"] [] + , testCase "variadic" $ + rendersAs "#define LOG(fmt, ...) printf ( fmt , __VA_ARGS__ )" $ + Macro.variadic "LOG" ["fmt"] + ["printf", "(", "fmt", ",", "__VA_ARGS__", ")"] + , testCase "variadic, no named parameters" $ + rendersAs "#define WARN(...) __VA_ARGS__" $ + Macro.variadic "WARN" [] ["__VA_ARGS__"] + -- The GNU form keeps its own spelling: rendering it as + -- @#define LOG(fmt, ...)@ would pass only @fmt@ on to @printf@. + , testCase "GNU named variadic" $ + rendersAs "#define LOG(fmt, args...) printf ( fmt , args )" $ + Macro.variadicNamed "LOG" ["fmt"] "args" + ["printf", "(", "fmt", ",", "args", ")"] + , testCase "GNU named variadic, no named parameters" $ + rendersAs "#define WARN(args...) args" $ + Macro.variadicNamed "WARN" [] "args" ["args"] + ] + ] + +rendersAs :: String -> Macro.Raw String -> Assertion +rendersAs expected raw = expected @=? Macro.render raw diff --git a/test/Test/HsBindgen/Runtime/SizedByteArray.hs b/test/Test/HsBindgen/Runtime/SizedByteArray.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/SizedByteArray.hs @@ -0,0 +1,230 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.HsBindgen.Runtime.SizedByteArray (tests) where + +import Data.Primitive.ByteArray qualified as BA +import Data.Proxy (Proxy (..)) +import Data.Word (Word8) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable (..)) +import GHC.TypeNats (KnownNat) +import Test.QuickCheck (Arbitrary (..), Property, ioProperty, vectorOf, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (Testable, testProperty) + +import HsBindgen.Runtime.Marshal +import HsBindgen.Runtime.Support.SizedByteArray (SizedByteArray (..)) + +import Test.Util.Orphans () + +{------------------------------------------------------------------------------- + Helper functions +-------------------------------------------------------------------------------} + +-- | Create a 'SizedByteArray' from a list of bytes +-- +-- This number of bytes must match the size of the array. +fromBytes :: forall n m. + (KnownNat n, KnownNat m) + => [Word8] + -> SizedByteArray n m +fromBytes bytes + | length bytes == size = SizedByteArray $ BA.byteArrayFromList bytes + | otherwise = error "fromBytes length mismatch" + where + size :: Int + size = staticSizeOf (Proxy :: Proxy (SizedByteArray n m)) + +-- | Extract bytes from a 'SizedByteArray' +toBytes :: SizedByteArray n m -> [Word8] +toBytes (SizedByteArray arr) = BA.foldrByteArray (:) [] arr + +{------------------------------------------------------------------------------- + Reference implementation +-------------------------------------------------------------------------------} + +-- | Read bytes using 'Storable' +-- +-- This does /not/ use the 'Storable' instance of 'SizedByteArray'. +peekSBA :: forall n m. + (KnownNat n, KnownNat m) + => Ptr (SizedByteArray n m) + -> IO (SizedByteArray n m) +peekSBA ptr = do + let ptr' = castPtr ptr + size = staticSizeOf (Proxy :: Proxy (SizedByteArray n m)) + fromBytes <$> mapM (peekElemOff ptr') [0 .. size - 1] + +-- | Write bytes using 'Storable' +-- +-- This does /not/ use the 'Storable' instance of 'SizedByteArray'. +pokeSBA :: Ptr a -> (SizedByteArray n m) -> IO () +pokeSBA ptr sba = do + let ptr' = castPtr ptr + mapM_ (uncurry (pokeElemOff ptr')) $ zip [0..] (toBytes sba) + +{------------------------------------------------------------------------------- + Arbitrary instances +-------------------------------------------------------------------------------} + +instance (KnownNat n, KnownNat m) => Arbitrary (SizedByteArray n m) where + arbitrary = + let size = staticSizeOf (Proxy :: Proxy (SizedByteArray n m)) + in fromBytes <$> vectorOf size (arbitrary @Word8) + + shrink sba = case span (== 0x00) (toBytes sba) of + (ls, (_:rs)) -> [fromBytes (ls ++ 0x00 : rs)] + (_, []) -> [] + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "HsBindgen.Runtime.SizedByteArray" [ + testGroup "StaticSize" [ + test_staticSizeOf + , test_staticAlignment + ] + , testGroup "ReadRaw+WriteRaw" [ + testGroup "readRaw reads" [ + aux8 prop_readRaw + , aux16 prop_readRaw + , aux32 prop_readRaw + ] + , testGroup "writeRaw writes" [ + aux8 prop_writeRaw + , aux16 prop_writeRaw + , aux32 prop_writeRaw + ] + , testGroup "read read (reading twice gets the same results)" [ + aux8 prop_readRead + , aux16 prop_readRead + , aux32 prop_readRead + ] + , testGroup "write read (you get back what you put in)" [ + aux8 prop_writeRead + , aux16 prop_writeRead + , aux32 prop_writeRead + ] + , testGroup "read write (putting back what you got out has no effect)" [ + aux8 prop_readWrite + , aux16 prop_readWrite + , aux32 prop_readWrite + ] + , testGroup "write write (putting twice is same as putting once)" [ + aux8 prop_writeWrite + , aux16 prop_writeWrite + , aux32 prop_writeWrite + ] + ] + ] + where + aux8 :: Testable a => (Proxy (SizedByteArray 8 2) -> a) -> TestTree + aux8 mkProp = testProperty "SizedByteArray 8 2" $ mkProp Proxy + + aux16 :: Testable a => (Proxy (SizedByteArray 16 4) -> a) -> TestTree + aux16 mkProp = testProperty "SizedByteArray 16 4" $ mkProp Proxy + + aux32 :: Testable a => (Proxy (SizedByteArray 32 8) -> a) -> TestTree + aux32 mkProp = testProperty "SizedByteArray 32 8" $ mkProp Proxy + +{------------------------------------------------------------------------------- + StaticSize +-------------------------------------------------------------------------------} + +test_staticSizeOf :: TestTree +test_staticSizeOf = testGroup "staticSizeof" [ + testCase "4" $ staticSizeOf (Proxy :: Proxy (SizedByteArray 4 2)) @?= 4 + , testCase "8" $ staticSizeOf (Proxy :: Proxy (SizedByteArray 8 2)) @?= 8 + , testCase "16" $ staticSizeOf (Proxy :: Proxy (SizedByteArray 16 2)) @?= 16 + , testCase "32" $ staticSizeOf (Proxy :: Proxy (SizedByteArray 32 2)) @?= 32 + ] + +test_staticAlignment :: TestTree +test_staticAlignment = testGroup "staticAlignment" [ + testCase "1" $ staticAlignment (Proxy :: Proxy (SizedByteArray 8 1)) @?= 1 + , testCase "2" $ staticAlignment (Proxy :: Proxy (SizedByteArray 8 2)) @?= 2 + , testCase "4" $ staticAlignment (Proxy :: Proxy (SizedByteArray 8 4)) @?= 4 + , testCase "8" $ staticAlignment (Proxy :: Proxy (SizedByteArray 8 8)) @?= 8 + ] + +{------------------------------------------------------------------------------- + ReadRaw+WriteRaw +-------------------------------------------------------------------------------} + +prop_readRaw :: forall n m. + (KnownNat n, KnownNat m) + => Proxy (SizedByteArray n m) + -> SizedByteArray n m + -> Property +prop_readRaw proxy sba = ioProperty $ + allocaBytes (staticSizeOf proxy) $ \ptr -> do + pokeSBA ptr sba + sba' <- readRaw ptr + return $ sba === sba' + +prop_writeRaw :: forall n m. + (KnownNat n, KnownNat m) + => Proxy (SizedByteArray n m) + -> SizedByteArray n m + -> Property +prop_writeRaw proxy sba = ioProperty $ + allocaBytes (staticSizeOf proxy) $ \ptr -> do + writeRaw ptr sba + sba' <- peekSBA ptr + return $ sba === sba' + +{------------------------------------------------------------------------------- + ReadRaw+WriteRaw: applicable laws from primLaws in quickcheck-classes +-------------------------------------------------------------------------------} + +prop_readRead :: forall n m. + (KnownNat n, KnownNat m) + => Proxy (SizedByteArray n m) + -> SizedByteArray n m + -> Property +prop_readRead proxy sba = ioProperty $ + allocaBytes (staticSizeOf proxy) $ \ptr -> do + pokeSBA (ptr :: Ptr (SizedByteArray 8 2)) sba + sba2 <- readRaw ptr + sba3 <- readRaw ptr + return $ sba2 === sba3 + +prop_writeRead :: forall n m. + (KnownNat n, KnownNat m) + => Proxy (SizedByteArray n m) + -> SizedByteArray n m + -> Property +prop_writeRead proxy sba = ioProperty $ + allocaBytes (staticSizeOf proxy) $ \ptr -> do + writeRaw ptr sba + sba' <- readRaw ptr + return $ sba === sba' + +prop_readWrite :: forall n m. + (KnownNat n, KnownNat m) + => Proxy (SizedByteArray n m) + -> SizedByteArray n m + -> Property +prop_readWrite proxy sba = ioProperty $ + allocaBytes (staticSizeOf proxy) $ \ptr -> do + pokeSBA ptr sba + writeRaw ptr =<< readRaw ptr + sba' <- peekSBA ptr + return $ sba === sba' + +prop_writeWrite :: forall n m. + (KnownNat n, KnownNat m) + => Proxy (SizedByteArray n m) + -> SizedByteArray n m + -> Property +prop_writeWrite proxy sba = ioProperty $ + allocaBytes (staticSizeOf proxy) $ \ptr -> do + writeRaw ptr sba + sba2 <- peekSBA ptr + writeRaw ptr sba + sba3 <- peekSBA ptr + return $ sba2 === sba3 diff --git a/test/Test/HsBindgen/Runtime/Support/ByteArray.hs b/test/Test/HsBindgen/Runtime/Support/ByteArray.hs new file mode 100644 --- /dev/null +++ b/test/Test/HsBindgen/Runtime/Support/ByteArray.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE MultiWayIf #-} + +module Test.HsBindgen.Runtime.Support.ByteArray (tests) where + +import Data.Bifunctor (Bifunctor (first)) +import Data.Either (partitionEithers) +import Data.Primitive.ByteArray (ByteArray) +import Data.Primitive.ByteArray qualified as P +import Data.Proxy (Proxy (Proxy)) +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign.Storable (Storable (sizeOf)) +import GHC.Exts (IsList (fromList, toList)) +import GHC.Stack (HasCallStack) +import Test.QuickCheck (Arbitrary (..), Arbitrary2 (liftShrink2), Gen, + Large (Large, getLarge), Property, chooseInt, + shrinkList, sized, tabulate, vectorOf, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Printf (printf) + +import HsBindgen.Runtime.Support.Bitfield (Bitfield (narrow)) +import HsBindgen.Runtime.Support.ByteArray (getUnionPayload, + getUnionPayloadBits, + setUnionPayload, + setUnionPayloadBits) + +import Test.Util.QC (Arbitrary4 (liftShrink4)) +import Test.Util.Show (showRangesOf) + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.HsBindgen.Runtime.Support.ByteArray" [ + -- prop_setGet + testProperty "prop_setGet @Word8" $ prop_setGet (Proxy @Word8) + , testProperty "prop_setGet @Word16" $ prop_setGet (Proxy @Word16) + , testProperty "prop_setGet @Word32" $ prop_setGet (Proxy @Word32) + , testProperty "prop_setGet @Word64" $ prop_setGet (Proxy @Word64) + , testProperty "prop_setGet @Int" $ prop_setGet (Proxy @Int) + + -- prop_getSet + , testProperty "prop_getSet @Word8" $ prop_getSet (Proxy @Word8) + , testProperty "prop_getSet @Word16" $ prop_getSet (Proxy @Word16) + , testProperty "prop_getSet @Word32" $ prop_getSet (Proxy @Word32) + , testProperty "prop_getSet @Word64" $ prop_getSet (Proxy @Word64) + , testProperty "prop_getSet @Int" $ prop_getSet (Proxy @Int) + + -- prop_setGetBits + , testProperty "prop_setGetBits @Word8" $ prop_setGetBits (Proxy @Word8) + , testProperty "prop_setGetBits @Word16" $ prop_setGetBits (Proxy @Word16) + , testProperty "prop_setGetBits @Word32" $ prop_setGetBits (Proxy @Word32) + , testProperty "prop_setGetBits @Word64" $ prop_setGetBits (Proxy @Word64) + , testProperty "prop_setGetBits @Int" $ prop_setGetBits (Proxy @Int) + + -- prop_getSetBits + , testProperty "prop_getSetBits @Word8" $ prop_getSetBits (Proxy @Word8) + , testProperty "prop_getSetBits @Word16" $ prop_getSetBits (Proxy @Word16) + , testProperty "prop_getSetBits @Word32" $ prop_getSetBits (Proxy @Word32) + , testProperty "prop_getSetBits @Word64" $ prop_getSetBits (Proxy @Word64) + , testProperty "prop_getSetBits @Int" $ prop_getSetBits (Proxy @Int) + ] + +{------------------------------------------------------------------------------- + Roundtrip: set and get +-------------------------------------------------------------------------------} + +-- | Roundtrip: get after set should return the set value +prop_setGet :: + forall a. (Storable a, Eq a, Show a) + => Proxy a -> SetGetParams a -> Property +prop_setGet _ params = + -- the byte array can be larger than the value we want to get/set so we + -- tabulate the number of unused bytes in the byte array + tabulate "# of unused bytes" [showRangesOf 25 (bytesSz - valueSz)] $ + params.value === getUnionPayload (setUnionPayload params.value params.bytes) + where + valueSz = sizeOf (undefined :: a) + bytesSz = P.sizeofByteArray params.bytes + +-- | Roundtrip: set after get should return the byte array to its original state +-- +-- This test is interesting because it tests that the setter /only/ modifies +-- bytes within the range of the byte array that contains the @a@ value. It used +-- to be the case that setters would zero out all bytes outside of the byte +-- range of @a@. This was a bug. See issue #2183 for more background: +-- +prop_getSet :: + forall a. Storable a + => Proxy a -> SetGetParams a -> Property +prop_getSet _ params = + -- the byte array can be larger than the value we want to get/set so we + -- tabulate the number of unused bytes in the byte array + tabulate "# of unused bytes" [showRangesOf 25 (bytesSz - valueSz)] $ + params.bytes === setUnionPayload @a (getUnionPayload params.bytes) params.bytes + where + valueSz = sizeOf (undefined :: a) + bytesSz = P.sizeofByteArray params.bytes + +-- | Parameters for 'prop_setGet' and 'prop_getSet' +-- +-- INVARIANT: see the 'CheckInvariant' instance +data SetGetParams a = SetGetParams { + value :: a + , bytes :: ByteArray + } + deriving stock (Show, Eq) + +instance (Show a, Storable a) => CheckInvariant (SetGetParams a) where + checkInvariant params = first (printf "For params (%s), " (show params) ++) go + where + go + | let vSz = sizeOf v + , let bsSz = P.sizeofByteArray bs + , vSz > bsSz + = Left $ printf "A: %d > %d" vSz bsSz + | otherwise + = Right params + + v = params.value + bs = params.bytes + +mkSetGetParams :: + forall a. (Storable a, Show a) + => a -> ByteArray -> Either String (SetGetParams a) +mkSetGetParams value bytes = checkInvariant $ SetGetParams { value = value,bytes = bytes } + +mkSetGetParams' :: + forall a. (HasCallStack, Storable a, Show a) + => a -> ByteArray -> SetGetParams a +mkSetGetParams' value bytes = checkInvariant' $ SetGetParams { value = value,bytes = bytes } + +instance (Storable a, Arbitrary a, Show a) => Arbitrary (SetGetParams a) where + arbitrary = do + bytes <- genBytes + value <- arbitrary + pure $ mkSetGetParams' value bytes + where + valueSz = sizeOf (undefined :: a) + + genBytes = sized $ \n -> do + k <- chooseInt (valueSz, max valueSz n) + let genByte = getLarge <$> arbitrary + byteArrayOf k genByte + + shrink params = snd $ partitionEithers [ + mkSetGetParams value' bytes' + | (value', bytes') <- liftShrink2 shrink shrinkBytes (params.value, params.bytes) + ] + where + valueSz = sizeOf (undefined :: a) + + shrinkBytes bytes = [ + bytes' + | let shrinkByte = fmap getLarge . shrink . Large + , bytes' <- shrinkByteArray shrinkByte bytes + , valueSz <= P.sizeofByteArray bytes' + ] + +{------------------------------------------------------------------------------- + Roundtrip: set bits and get bits +-------------------------------------------------------------------------------} + +-- | Roundtrip: get bits after set bits should return the set value +prop_setGetBits :: + forall a. Bitfield a + => Proxy a -> SetGetBitsParams a -> Property +prop_setGetBits _ params = + tabulate "# of unused leading bits" [showRangesOf 64 o] $ + tabulate "# of unused trailing bits" [showRangesOf 64 (bsSz * 8 - (o + w))] $ + narrow v w === getUnionPayloadBits o w (setUnionPayloadBits o w v bs) + where + o = params.bitOffset + w = params.bitWidth + v = params.value + bs = params.bytes + bsSz = P.sizeofByteArray bs + +-- | Roundtrip: set after get should return the byte array to its original state +-- +-- See als 'prop_getSet'. +prop_getSetBits :: + forall a. Bitfield a + => Proxy a -> SetGetBitsParams a -> Property +prop_getSetBits _ params = + tabulate "# of unused leading bits" [showRangesOf 64 o] $ + tabulate "# of unused trailing bits" [showRangesOf 64 (bsSz * 8 - (o + w))] $ + bs === setUnionPayloadBits @a o w (getUnionPayloadBits o w bs) bs + where + o = params.bitOffset + w = params.bitWidth + bs = params.bytes + bsSz = P.sizeofByteArray bs + + +-- | Parameters for 'prop_setGetBits' and 'prop_getSetBits' +-- +-- INVARIANT: see the 'CheckInvariant' instance +data SetGetBitsParams a = SetGetBitsParams { + value :: a + , bitOffset :: Int + , bitWidth :: Int + , bytes :: ByteArray + } + deriving stock (Show, Eq) + +instance (Show a, Storable a) => CheckInvariant (SetGetBitsParams a) where + checkInvariant params = first (printf "For params (%s), " (show params) ++) go + where + go + | o < 0 + = Left $ printf "A: %d < 0" o + | w < 1 || w > 64 + = Left $ printf "B: %d < 1 || %d > 64" w w + | let vSz = sizeOf v + , w > vSz * 8 + = Left $ printf "C: %d + %d > %d * 8" o w vSz + | let bsSz = P.sizeofByteArray bs + , o + w > bsSz * 8 + = Left $ printf "D: %d + %d > %d * 8" o w bsSz + | otherwise + = Right params + + o = params.bitOffset + w = params.bitWidth + v = params.value + bs = params.bytes + +mkSetGetBitsParams :: + forall a. (Storable a, Show a) + => a -> Int -> Int -> ByteArray -> Either String (SetGetBitsParams a) +mkSetGetBitsParams value bitOffset bitWidth bytes = + checkInvariant $ + SetGetBitsParams { + value = value, bitOffset = bitOffset, bitWidth = bitWidth, bytes = bytes + } + +mkSetGetBitsParams' :: + forall a. (HasCallStack, Storable a, Show a) + => a -> Int -> Int -> ByteArray -> SetGetBitsParams a +mkSetGetBitsParams' value bitOffset bitWidth bytes = + checkInvariant' + SetGetBitsParams { + value = value, bitOffset = bitOffset, bitWidth = bitWidth, bytes = bytes + } + +instance (Storable a, Show a, Arbitrary a) => Arbitrary (SetGetBitsParams a) where + arbitrary = do + bitWidth <- chooseInt (1, valueSz * 8 - 1) + let i = ceilDiv8 bitWidth + bytes <- genBytes i + bitOffset <- chooseInt (0, P.sizeofByteArray bytes * 8 - bitWidth) + value <- arbitrary + pure $ mkSetGetBitsParams' value bitOffset bitWidth bytes + where + valueSz = sizeOf (undefined :: a) + + genBytes i = sized $ \n -> do + k <- chooseInt (i, max i n) + let genByte = getLarge <$> arbitrary + byteArrayOf k genByte + + shrink params = snd $ partitionEithers [ + mkSetGetBitsParams value' bitOffset' bitWidth' bytes' + | (value', bitOffset', bitWidth', bytes') + <- liftShrink4 shrink shrink shrink shrinkBytes + (params.value, params.bitOffset, params.bitWidth, params.bytes) + ] + where + shrinkBytes bytes = [ + bytes' + | let shrinkByte = fmap getLarge . shrink . Large + , bytes' <- shrinkByteArray shrinkByte bytes + ] + +{------------------------------------------------------------------------------- + Invariants +-------------------------------------------------------------------------------} + +class CheckInvariant a where + -- | Check whether a value satisfies the type's invariant + -- + -- @Left msg@ if the invariant is not satisified, @Right _@ otherwise. + checkInvariant :: a -> Either String a + +-- | Like 'checkInvariant', but throws an error if the invariant is not +-- satisfied +checkInvariant' :: (HasCallStack, CheckInvariant a) => a -> a +checkInvariant' x = case checkInvariant x of + Left msg -> error $ msg + Right y -> y + +{------------------------------------------------------------------------------- + Arbitrary byte arrays +-------------------------------------------------------------------------------} + +byteArrayOf :: Int -> Gen Word8 -> Gen ByteArray +byteArrayOf n genByte = do + bytes <- vectorOf n genByte + pure $ fromList bytes + +shrinkByteArray :: (Word8 -> [Word8]) -> ByteArray -> [ByteArray] +shrinkByteArray shrinkByte bytes = [ + fromList bytes' + | bytes' <- shrinkList shrinkByte (toList bytes) + ] + +{------------------------------------------------------------------------------- + Numeric +-------------------------------------------------------------------------------} + +-- | Divide by 8 and round up +ceilDiv8 :: Int -> Int +ceilDiv8 x = (x + 7) `div` 8 diff --git a/test/Test/Util/Orphans.hs b/test/Test/Util/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util/Orphans.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Util.Orphans ( + ) where + +import HsBindgen.Runtime.Support.SizedByteArray + +deriving stock instance Show (SizedByteArray n m) +deriving stock instance Eq (SizedByteArray n m) diff --git a/test/Test/Util/QC.hs b/test/Test/Util/QC.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util/QC.hs @@ -0,0 +1,25 @@ +module Test.Util.QC ( + Arbitrary4 (..) + ) where + +import Data.Kind +import Test.QuickCheck + +{------------------------------------------------------------------------------- + Arbitrary4 +-------------------------------------------------------------------------------} + +class Arbitrary4 (f :: Type -> Type -> Type -> Type -> Type) where + {-# MINIMAL liftArbitrary4 #-} + liftArbitrary4 :: Gen a -> Gen b -> Gen c -> Gen d -> Gen (f a b c d) + liftShrink4 :: (a -> [a]) -> (b -> [b]) -> (c -> [c]) -> (d -> [d]) -> f a b c d -> [f a b c d] + liftShrink4 _ _ _ _ _ = [] + +instance Arbitrary4 (,,,) where + liftArbitrary4 genA genB genC genD = + (,,,) <$> genA <*> genB <*> genC <*> genD + + liftShrink4 shrA shrB shrC shrD (a, b, c, d) = do + (a', (b', (c', d'))) <- + liftShrink2 shrA (liftShrink2 shrB (liftShrink2 shrC shrD)) (a, (b, (c, d))) + pure (a', b', c', d') diff --git a/test/Test/Util/Show.hs b/test/Test/Util/Show.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util/Show.hs @@ -0,0 +1,33 @@ +module Test.Util.Show ( + showPowersOf10 + , showPowersOf + , showRangesOf + ) where + +import Data.List (find) +import Data.Maybe (fromJust) +import Text.Printf + +showPowersOf10 :: Int -> String +showPowersOf10 = showPowersOf 10 + +showPowersOf :: Int -> Int -> String +showPowersOf factor n + | factor <= 1 = error "showPowersOf: factor must be larger than 1" + | n < 0 = "n < 0" + | n == 0 = "n == 0" + | otherwise = printf "%d <= n < %d" lb ub + where + ub = fromJust (find (n <) (iterate (* factor) factor)) + lb = ub `div` factor + +showRangesOf :: Int -> Int -> String +showRangesOf range n + | range <= 0 = error "showRangesOf: range must be larger than 0" + | n == 0 = "n == 0" + | m == 0 = printf "%d < n < %d" lb ub + | otherwise = printf "%d <= n < %d" lb ub + where + m = n `div` range + lb = m * range + ub = (m + 1) * range diff --git a/test/Test/Util/Tasty.hs b/test/Test/Util/Tasty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util/Tasty.hs @@ -0,0 +1,19 @@ +module Test.Util.Tasty ( + -- * Assertions + (@=?!) + ) where + +import Control.Exception (Exception, evaluate, try) +import GHC.Stack (HasCallStack) +import Test.Tasty.HUnit (Assertion, (@=?)) + +{------------------------------------------------------------------------------- + Assertions +-------------------------------------------------------------------------------} + +(@=?!) :: + (Eq a, Eq e, Exception e, HasCallStack, Show a) + => e + -> a + -> Assertion +expected @=?! actual = (Left expected @=?) =<< try (evaluate actual) diff --git a/test/test-runtime.hs b/test/test-runtime.hs new file mode 100644 --- /dev/null +++ b/test/test-runtime.hs @@ -0,0 +1,28 @@ +module Main (main) where + +import Test.Tasty (defaultMain, testGroup) + +import Test.HsBindgen.Runtime.Bitfield qualified +import Test.HsBindgen.Runtime.CBool qualified +import Test.HsBindgen.Runtime.CEnum qualified +import Test.HsBindgen.Runtime.ConstantArray qualified +import Test.HsBindgen.Runtime.IncompleteArray qualified +import Test.HsBindgen.Runtime.Macro qualified +import Test.HsBindgen.Runtime.SizedByteArray qualified +import Test.HsBindgen.Runtime.Support.ByteArray qualified + +{------------------------------------------------------------------------------- + Main +-------------------------------------------------------------------------------} + +main :: IO () +main = defaultMain $ testGroup "test-runtime" [ + Test.HsBindgen.Runtime.Bitfield.tests + , Test.HsBindgen.Runtime.CBool.tests + , Test.HsBindgen.Runtime.CEnum.tests + , Test.HsBindgen.Runtime.ConstantArray.tests + , Test.HsBindgen.Runtime.IncompleteArray.tests + , Test.HsBindgen.Runtime.Macro.tests + , Test.HsBindgen.Runtime.SizedByteArray.tests + , Test.HsBindgen.Runtime.Support.ByteArray.tests + ]