packages feed

hs-bindgen-runtime (empty) → 1.0.0.0

raw patch · 49 files changed

+7856/−0 lines, 49 filesdep +QuickCheckdep +basedep +bytestring

Dependencies added: QuickCheck, base, bytestring, containers, hs-bindgen-runtime, primitive, record-hasfield, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, template-haskell, transformers, vector

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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`]: <https://github.com/well-typed/hs-bindgen>
+ hs-bindgen-runtime.cabal view
@@ -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
+ src/HsBindgen/Runtime/BitfieldPtr.hs view
@@ -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
+ src/HsBindgen/Runtime/Block.hs view
@@ -0,0 +1,40 @@+-- | Bare-bones support for blocks+--+-- TODO <https://github.com/well-typed/hs-bindgen/issues/2132>+--+-- 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 <https://clang.llvm.org/docs/BlockLanguageSpec.html>+--+-- 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)
+ src/HsBindgen/Runtime/CBool.hs view
@@ -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) #-}
+ src/HsBindgen/Runtime/CEnum.hs view
@@ -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)
+ src/HsBindgen/Runtime/ConstantArray.hs view
@@ -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)
+ src/HsBindgen/Runtime/FLAM.hs view
@@ -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
+ src/HsBindgen/Runtime/HasCBitfield.hs view
@@ -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
+ src/HsBindgen/Runtime/HasCField.hs view
@@ -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)
+ src/HsBindgen/Runtime/HasFFIType.hs view
@@ -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:+-- <https://www.haskell.org/onlinereport/haskell2010/haskellch8.html#x15-1560008.4.2>+--+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
+ src/HsBindgen/Runtime/IncompleteArray.hs view
@@ -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
+ src/HsBindgen/Runtime/IsArray.hs view
@@ -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
+ src/HsBindgen/Runtime/LibC.hs view
@@ -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.
+ src/HsBindgen/Runtime/Macro.hs view
@@ -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).+--+-- <https://clang.llvm.org/docs/LanguageExtensions.html#language-extensions-back-ported-to-previous-standards>+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.+    --+    -- <https://gcc.gnu.org/onlinedocs/cpp/Variadic-Macros.html>+  | 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
+ src/HsBindgen/Runtime/Marshal.hs view
@@ -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
+ src/HsBindgen/Runtime/Overloading.hs view
@@ -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
+ src/HsBindgen/Runtime/Prelude.hs view
@@ -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)
+ src/HsBindgen/Runtime/PtrConst.hs view
@@ -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.+-}+
+ src/HsBindgen/Runtime/Struct.hs view
@@ -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)
+ src/HsBindgen/Runtime/Support.hs view
@@ -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))
+ src/HsBindgen/Runtime/Support/Bitfield.hs view
@@ -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: <https://en.wikipedia.org/wiki/Endianness>+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
+ src/HsBindgen/Runtime/Support/ByteArray.hs view
@@ -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
+ src/HsBindgen/Runtime/Support/CAPI.hs view
@@ -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
+ src/HsBindgen/Runtime/Support/CompatHasField.hs view
@@ -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
+ src/HsBindgen/Runtime/Support/FunPtr.hs view
@@ -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 ()
+ src/HsBindgen/Runtime/Support/FunPtr/Class.hs view
@@ -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)
+ src/HsBindgen/Runtime/Support/LibC/Auxiliary.hsc view
@@ -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 <inttypes.h>+#include <locale.h>+#include <stdlib.h>+#include <time.h>++{-------------------------------------------------------------------------------+  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 <https://github.com/well-typed/hs-bindgen/issues/2133>+--+-- TODO CFloatT @float_t@ (arch, uses long double, math.h)++-- TODO <https://github.com/well-typed/hs-bindgen/issues/2133>+--+-- 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 <https://github.com/well-typed/hs-bindgen/issues/2133>+--+-- 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 <https://github.com/well-typed/hs-bindgen/issues/2133>+--+-- 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
+ src/HsBindgen/Runtime/Support/Ptr.hs view
@@ -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
+ src/HsBindgen/Runtime/Support/SizedByteArray.hs view
@@ -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)
+ src/HsBindgen/Runtime/Support/TH/Instances.hs view
@@ -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)
+ src/HsBindgen/Runtime/Support/TH/Types.hs view
@@ -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 = "_"+
+ src/HsBindgen/Runtime/Union.hs view
@@ -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
+ test/Test/HsBindgen/Runtime/Bitfield.hs view
@@ -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
+ test/Test/HsBindgen/Runtime/CBool.hs view
@@ -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)
+ test/Test/HsBindgen/Runtime/CEnum.hs view
@@ -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
+ test/Test/HsBindgen/Runtime/CEnumArbitrary.hs view
@@ -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
+ test/Test/HsBindgen/Runtime/ConstantArray.hs view
@@ -0,0 +1,11 @@+module Test.HsBindgen.Runtime.ConstantArray (tests) where++import Test.Tasty++tests :: TestTree+tests = testGroup "HsBindgen.Runtime.ConstantArray" [+    ]++-- TODO <https://github.com/well-typed/hs-bindgen/issues/1222>+--+-- Add tests!
+ test/Test/HsBindgen/Runtime/IncompleteArray.hs view
@@ -0,0 +1,11 @@+module Test.HsBindgen.Runtime.IncompleteArray (tests) where++import Test.Tasty++tests :: TestTree+tests = testGroup "HsBindgen.Runtime.IncompleteArray" [+    ]++-- TODO <https://github.com/well-typed/hs-bindgen/issues/1222>+--+-- Add tests!
+ test/Test/HsBindgen/Runtime/Macro.hs view
@@ -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
+ test/Test/HsBindgen/Runtime/SizedByteArray.hs view
@@ -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
+ test/Test/HsBindgen/Runtime/Support/ByteArray.hs view
@@ -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:+-- <https://github.com/well-typed/hs-bindgen/issues/2183>+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
+ test/Test/Util/Orphans.hs view
@@ -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)
+ test/Test/Util/QC.hs view
@@ -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')
+ test/Test/Util/Show.hs view
@@ -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
+ test/Test/Util/Tasty.hs view
@@ -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)
+ test/test-runtime.hs view
@@ -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+    ]