c-expr-runtime 0.1.0.0 → 0.2.0.0

raw patch · 7 files changed

+180/−43 lines, 7 filesdep ~libclang-bindingsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: libclang-bindings

API changes (from Hackage documentation)

Files

• CHANGELOG.md +29/−2
• c-expr-runtime.cabal +3/−3
• core/C/Operator/Classes.hs +9/−0
• core/C/Operator/TH.hs +49/−29
• core/C/Type.hs +48/−5
• test/CallClang.hs +6/−3
• test/Main.hs +36/−1

@@ -1,10 +1,37 @@ # Revision history for `c-expr` +## 0.2.0.0 -- 2026-10-16++### Breaking changes++- Pointer arithmetic counts elements of the pointee, as in C, and not bytes:+  `p + i` and `i + p` advance `p` by `i` elements, `p - i` moves `p` back by+  `i` elements, and `p1 - p2` counts the elements between `p1` and `p2`. The+  `Add` and `Sub` instances for `Ptr ty` now require the new class+  `Pointee ty`: `Pointee`s are `Storable ty`, whose `sizeOf` is the size of the+  step. In particular, neither `Void` nor `()` is an instance of `Pointee`.+  Arithmetic on `Ptr ()` (`void *`) and on pointers to opaque types is a type+  error, as in C; for byte arithmetic, cast to `Ptr Word8` first. See [issue+  #2306][issue-2306].+- `SPtr` now holds an `SPointee rec ty`: `SVoidPointee` for `void *`, or+  `SObjPointee`, which carries the `Pointee ty` evidence.++### New features++- `C.Type` exports `Pointee`, `NotVoid`, `SPointee(..)`, and `unSPointee`.++### Bug fixes++- `p - i` for an unsigned `i` narrower than `Int` no longer wraps around: on+  64-bit platforms, `p - 1u` moved `p` forward by `UINT_MAX` bytes.++[issue-2306]: https://github.com/well-typed/hs-bindgen/issues/2306+ ## 0.1.0.0 -- 2026-07-14 -* Remove the `C.Char` module; UTF-8 encoding of character and string literals+- Remove the `C.Char` module; UTF-8 encoding of character and string literals   now lives in `c-expr-dsl`'s parser.  ## 0.1.0-alpha -- 2026-02-06 -* Release candidate.+- Release candidate.

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            c-expr-runtime-version:         0.1.0.0+version:         0.2.0.0 license:         BSD-3-Clause license-file:    LICENSE author:          Well-Typed LLP@@ -51,7 +51,7 @@   type:     git   location: https://github.com/well-typed/c-expr.git   subdir:   c-expr-runtime-  tag:      release-0.1.0.0+  tag:      c-expr-runtime-0.2.0.0  common common   ghc-options:@@ -123,7 +123,7 @@   -- Internal dependencies   build-depends:     , c-expr-runtime-    , libclang-bindings+    , libclang-bindings  >=0.2 && <0.3    -- Inherited dependencies   build-depends:

@@ -105,6 +105,10 @@   -- | Result type family of the C binary addition operator.   type family AddRes a b :: Type   -- | C binary addition operator.+  --+  -- With a pointer operand, @p + i@ and @i + p@ advance @p :: 'Ptr' ty@ by @i@+  -- elements of @ty@, as in C. An element is+  -- @'Foreign.Storable.sizeOf' (undefined :: ty)@ bytes; see 'C.Type.Pointee'.   (+) :: a -> b -> AddRes a b  infixl 2 -@@ -114,6 +118,11 @@   -- | Result type family of the C binary subtraction operator.   type family SubRes a b :: Type   -- | C binary subtraction operator.+  --+  -- With pointer operands, @p - i@ moves @p :: 'Ptr' ty@ back by @i@ elements+  -- of @ty@, and @p1 - p2@ is the number of elements of @ty@ from @p2@ to @p1@,+  -- as in C. An element is @'Foreign.Storable.sizeOf' (undefined :: ty)@+  -- bytes; see 'C.Type.Pointee'.   (-) :: a -> b -> SubRes a b  infixl 1 *

@@ -34,7 +34,7 @@   ( on ) import Data.Kind qualified as Hs import Data.List-  ( sortOn )+  ( nub, sortOn ) import Data.List.NonEmpty   ( groupBy ) @@ -48,7 +48,7 @@ import Data.Void   ( absurd ) import Foreign-  ( Ptr, plusPtr, minusPtr )+  ( Ptr, sizeOf, advancePtr, minusPtr ) import Foreign.C import qualified GHC.Exts as Foreign.C   ( Ptr(Ptr) )@@ -419,7 +419,7 @@               args = zip argNms ( toList argTys )                proveNm = TH.mkName proveStr-              ( provePats, mbProveGuard ) = mkSingPats ( toList argTys )+              ( provePats, mbProveGuard ) = mkSingPats pointees ( toList argTys )               proveRes = TH.TupE [ Just ( mkSingExp resTy ), Just $ TH.VarE meth ]                mkConversions :: [ Conversion ] -> TH.Exp -> TH.Exp@@ -442,43 +442,52 @@                       zipWith mkConversions ( toList convs ) ( map TH.VarE argNms )                   AddIntegralAndPtr ->                     case argNms of-                      [ i, p ] ->-                        TH.VarE 'plusPtr-                            `TH.AppE`-                          ( TH.VarE p )-                            `TH.AppE`-                          ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i )+                      [ i, p ] -> advance p ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i )                       _ -> error $ "genInstance AddIntegralAndPtr: expected 2 arguments, but got: " ++ show args                   AddPtrAndIntegral ->                     case argNms of-                      [ p, i ] ->-                        TH.VarE 'plusPtr-                            `TH.AppE`-                          ( TH.VarE p )-                            `TH.AppE`-                          ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i )+                      [ p, i ] -> advance p ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i )                       _ -> error $ "genInstance AddPtrAndIntegral: expected 2 arguments, but got: " ++ show args                   SubPtrAndPtr ->-                    case argNms of-                      [ p1, p2 ] ->+                    case ( argNms, toList argTys ) of+                      ( [ p1, p2 ], Ptr ty : _ ) ->                         ( TH.VarE 'fromIntegral `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` TH.ConT ''CPtrdiff )                             `TH.AppE`-                          ( TH.VarE 'minusPtr `TH.AppE` TH.VarE p1 `TH.AppE` TH.VarE p2 )-                      _ -> error $ "genInstance SubPtrAndPtr: expected 2 arguments, but got: " ++ show args+                          ( TH.VarE 'quot+                              `TH.AppE`+                            ( TH.VarE 'minusPtr `TH.AppE` TH.VarE p1 `TH.AppE` TH.VarE p2 )+                              `TH.AppE`+                            ( TH.VarE 'sizeOf `TH.AppE` TH.SigE ( TH.VarE 'undefined ) ( TH.VarT ty ) )+                          )+                      _ -> error $ "genInstance SubPtrAndPtr: expected 2 pointer arguments, but got: " ++ show args                   SubPtrAndIntegral ->                     case argNms of                       [ p, i ] ->-                        TH.VarE 'plusPtr-                            `TH.AppE`-                          ( TH.VarE p )-                            `TH.AppE`-                          ( TH.VarE 'fromIntegral `TH.AppE` ( TH.VarE 'Prelude.negate `TH.AppE` TH.VarE i ) )+                        -- Negate after the conversion: negating an unsigned+                        -- offset would wrap around.+                        advance p ( TH.VarE 'Prelude.negate `TH.AppE` ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i ) )                       _ -> error $ "genInstance SubPtrAndIntegral: expected 2 arguments, but got: " ++ show args+              advance :: TH.Name -> TH.Exp -> TH.Exp+              advance p n = TH.VarE 'advancePtr `TH.AppE` TH.VarE p `TH.AppE` n         ]       overlap :: Maybe TH.Overlap       overlap = Nothing+      pointees :: Pointees+      pointees =+        case methImpl of+          ConvertThenOp {}  -> AnyPointees+          AddIntegralAndPtr -> ObjectPointees+          AddPtrAndIntegral -> ObjectPointees+          SubPtrAndPtr      -> ObjectPointees+          SubPtrAndIntegral -> ObjectPointees       ctxt :: [ TH.Type ]-      ctxt = [ ]+      ctxt =+        case pointees of+          AnyPointees    -> []+          ObjectPointees ->+            [ TH.ConT ''Pointee `TH.AppT` TH.VarT ty+            | ty <- nub [ ty | Ptr ty <- toList argTys ]+            ]   return $     ( TH.InstanceD overlap ctxt clsTy ( famDecs ++ methDecs )     , proveDecs@@ -504,16 +513,27 @@ mkSingTy :: TH.Type -> TH.Type mkSingTy ty = ( TH.ConT ''SType ) `TH.AppT` TH.VarT ( TH.mkName "rec" ) `TH.AppT` ty -mkSingPats :: [ Type TH.Name ] -> ( [ TH.Pat ], Maybe TH.Guard )-mkSingPats tys = ( map ( mkSingPat . mkOne ) tickedTys, if null guards then Nothing else Just $ TH.PatG guards )+-- | Which pointees the pointer arguments of an instance accept.+data Pointees+  = -- | Any pointee, including @void@.+    AnyPointees+  | -- | Only object types: the instance needs t'Pointee'.+    ObjectPointees++mkSingPats :: Pointees -> [ Type TH.Name ] -> ( [ TH.Pat ], Maybe TH.Guard )+mkSingPats pointees tys = ( map mkOne tickedTys, if null guards then Nothing else Just $ TH.PatG guards )   where     tickedTys = mkTicked 0 tys     mkTicked :: Int -> [ Type TH.Name ] -> [ Either ( TH.Name, Int ) ( Type TH.Name ) ]     mkTicked _ [] = []     mkTicked i ( Ptr nm : rest ) = Left ( nm, i ) : mkTicked ( i + 1 )rest     mkTicked i ( ty : rest ) = Right ty : mkTicked i rest-    mkOne ( Left ( nm, i ) ) = Ptr $ mkTickedName nm i-    mkOne ( Right ty ) = ty+    mkOne ( Left ( nm, i ) ) =+      case pointees of+        AnyPointees    -> mkSingPat $ Ptr $ mkTickedName nm i+        ObjectPointees ->+          TH.ConP 'SPtr [] [ TH.AsP ( mkTickedName nm i ) ( TH.ConP 'SObjPointee [] [ TH.WildP ] ) ]+    mkOne ( Right ty ) = mkSingPat ty     guards = concat $ mapMaybe mkGroup $ groupBy ( (==) `on` fst ) $ mapMaybe oneGuard tickedTys     mkGroup :: NE.NonEmpty ( TH.Name, Int ) -> Maybe [ TH.Stmt ]     mkGroup ( _ NE.:| [] ) = Nothing

@@ -4,6 +4,8 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}  module C.Type   ( -- * C types@@ -26,8 +28,14 @@   , Platform(..), WordWidth(..), OS(..)   , hostPlatform +  -- * Pointees+  , Pointee+  , NotVoid+   -- * Singletons for C types   , SType(..)+  , SPointee(..)+  , unSPointee   , SArithmeticType(..)   , SIntegralType(..)   , SCharLikeType(..)@@ -66,8 +74,9 @@ import Data.Type.Equality import Foreign.C.Types import Foreign.Ptr qualified as Foreign (Ptr)-import Foreign.Storable (sizeOf)+import Foreign.Storable (Storable, sizeOf) import GHC.Generics (Generic)+import GHC.TypeLits (ErrorMessage (..), TypeError) import System.Info qualified (os)  --------------------------------------------------------------------------------@@ -293,15 +302,45 @@       Unsigned -> ( "unsigned " ++ )  --------------------------------------------------------------------------------+-- Pointees++-- | The pointee must not be @void@ because it has no size.+type NotVoid :: Hs.Type -> Hs.Constraint+type family NotVoid ty where+  NotVoid () = TypeError ( 'Text "Pointer arithmetic on 'void *' is not allowed in C; cast the pointer first." )+  NotVoid _  = ()++-- | A valid pointee: an object type with non-zero 'sizeOf'.+--+-- Pointer arithmetic can step over a pointee.+class    ( Storable ty, NotVoid ty ) => Pointee ty+instance ( Storable ty, NotVoid ty ) => Pointee ty++-------------------------------------------------------------------------------- -- Singletons  type SType :: ( Hs.Type -> Hs.Type ) -> Hs.Type -> Hs.Type data SType rec a where   SVoid :: SType rec ()   SArithmetic :: !( SArithmeticType ty ) -> SType rec ty-  SPtr :: rec ty -> SType rec ( Foreign.Ptr ty )+  SPtr :: !( SPointee rec ty ) -> SType rec ( Foreign.Ptr ty ) deriving stock instance ( forall x. Show ( rec x ) ) => Show ( SType rec a ) +-- | Singleton for the pointee of 'SPtr'.+type SPointee :: ( Hs.Type -> Hs.Type ) -> Hs.Type -> Hs.Type+data SPointee rec ty where+  -- | @void@: pointer arithmetic is not allowed.+  SVoidPointee :: rec () -> SPointee rec ()+  -- | An object type: pointer arithmetic is allowed.+  SObjPointee :: Pointee ty => rec ty -> SPointee rec ty+deriving stock instance ( forall x. Show ( rec x ) ) => Show ( SPointee rec ty )++-- | The singleton of the pointee type, whether @void@ or not.+unSPointee :: SPointee rec ty -> rec ty+unSPointee = \case+  SVoidPointee a -> a+  SObjPointee  a -> a+ data SArithmeticType ty where   SIntegral  :: !( SIntegralType ty ) -> SArithmeticType ty   SFloatLike :: !( SFloatingType ty ) -> SArithmeticType ty@@ -345,6 +384,10 @@       Just Refl -> Just Refl       Nothing   -> Nothing   geq _ _ = Nothing+instance GEq rec => GEq ( SPointee rec ) where+  geq (SVoidPointee _) (SVoidPointee _) = Just Refl+  geq (SObjPointee a) (SObjPointee b) = geq a b+  geq _ _ = Nothing instance GEq SArithmeticType where   geq (SIntegral a) (SIntegral b) = geq a b   geq (SFloatLike a) (SFloatLike b) = geq a b@@ -378,7 +421,7 @@   geq SPtrDiff   SPtrDiff   = Just Refl   geq _ _ = Nothing -promoteType :: ( a -> ( forall ty. rec ty -> r ) -> r ) -> Type a -> ( forall ty. ( Ord ty, Show ty ) => SType rec ty -> r ) -> r+promoteType :: ( a -> ( forall ty. SPointee rec ty -> r ) -> r ) -> Type a -> ( forall ty. ( Ord ty, Show ty ) => SType rec ty -> r ) -> r promoteType recur ty f = case ty of   Void -> f SVoid   Arithmetic i -> promoteArithmeticType i ( f . SArithmetic )@@ -430,7 +473,7 @@ demoteType recur = \case   SVoid -> Void   SArithmetic a -> Arithmetic $ demoteArithmeticType a-  SPtr a -> Ptr $ recur a+  SPtr a -> Ptr $ recur $ unSPointee a  demoteArithmeticType :: SArithmeticType ty -> ArithmeticType demoteArithmeticType = \case@@ -478,7 +521,7 @@   case ty of     SVoid  -> f     SArithmetic i -> witnessArithmeticType @c i f-    SPtr p -> recur p f+    SPtr p -> recur ( unSPointee p ) f  witnessArithmeticType   :: forall c ty r

@@ -31,9 +31,9 @@ import Clang.Enum.Bitfield qualified as Clang (BitfieldEnum, bitfieldEnum) import Clang.Enum.Simple qualified as Clang (fromSimpleEnum) import Clang.HighLevel qualified as Clang hiding (clang_getCursorLocation)+import Clang.HighLevel.Types (SourcePath (..)) import Clang.HighLevel.Types qualified as Clang import Clang.LowLevel.Core qualified as Clang hiding (clang_visitChildren)-import Clang.Paths qualified as Paths  -------------------------------------------------------------------------------- @@ -64,6 +64,7 @@         -- '__size_t', and '__signed_size_t' as 'CXType_Unexposed' (see         -- upstream https://github.com/llvm/llvm-project/issues/192268).         -- Fall back to the canonical type to recover the underlying kind.+        -- LLVM/Clang 23 and later report 'CXType_PredefinedSugar' instead.         Clang.CXType_Unexposed           -> do { canTy <- Clang.clang_getCanonicalType cxTy                                                ; case Clang.fromSimpleEnum $ Clang.cxtKind canTy of                                                    Right Clang.CXType_Unexposed -> return Nothing@@ -138,6 +139,8 @@         Clang.CXType_Attributed          -> return Nothing         Clang.CXType_ExtVector           -> return Nothing         Clang.CXType_Atomic              -> return Nothing+        Clang.CXType_PredefinedSugar     -> do { canTy <- Clang.clang_getCanonicalType cxTy+                                               ; parseClangType canTy }  -- | Query @clang@ for canonical names for types. getExpansionTypeMapping :: Clang.ClangArgs -> [ CType ] -> IO ( Map CType CType )@@ -297,8 +300,8 @@     headerName :: FilePath     headerName = "src.c" -    src :: Paths.SourcePath-    src = Paths.SourcePath $ Text.pack headerName+    src :: SourcePath+    src = SourcePath $ Text.pack headerName      args :: Clang.ClangArgs     args = Clang.ClangArgs $

@@ -17,9 +17,12 @@ import Data.Traversable (for) import Data.Type.Nat import Data.Vec.Lazy (Vec (..))+import Foreign (Ptr, nullPtr, plusPtr)+import Foreign.C.Types (CDouble, CInt, CPtrdiff, CUInt) import System.Exit import System.Info qualified as Info +import C.Expr.HostPlatform qualified as C import C.Type import C.Type.Internal.Universe @@ -91,10 +94,42 @@             "   FAILED:"           : map ( showFailure . first show ) bad         pure $ Just bad-  if null badUnary && null badBinary+  putStrLn "Pointer arithmetic"+  ptrArith <- pointerArithmeticTests+  let badPtrArith = [ name | ( name, False ) <- ptrArith ]+  if null badPtrArith+  then putStrLn $ "   PASSED (" ++ show ( length ptrArith ) ++ " tests)"+  else putStrLn $ unlines $ "   FAILED:" : map ( "   " ++ ) badPtrArith+  if null badUnary && null badBinary && null badPtrArith   then exitSuccess   else exitFailure +-- | Pointer arithmetic counts elements of the pointee, not bytes.+pointerArithmeticTests :: IO [ ( String, Bool ) ]+pointerArithmeticTests =+  pure+    [ ( "int* + int"       , ( ints C.+ ( 4 :: CInt ) ) == ints4 )+    , ( "int + int*"       , ( ( 4 :: CInt ) C.+ ints ) == ints4 )+    , ( "int* - int"       , ( ints4 C.- ( 4 :: CInt ) ) == ints )+    , ( "int* - unsigned"  , ( ints4 C.- ( 4 :: CUInt ) ) == ints )+    , ( "int* - int*"      , ( ints4 C.- ints ) == ( 4 :: CPtrdiff ) )+    , ( "int* - int* < 0"  , ( ints C.- ints4 ) == ( -4 :: CPtrdiff ) )+    , ( "double* + int"    , ( doubles C.+ ( 4 :: CInt ) ) == doubles `plusPtr` 32 )+    , ( "singAdd int* int" , snd ( C.singAdd sIntPtr sInt ) ints 4 == ints4 )+    , ( "singSub int* int*", snd ( C.singSub sIntPtr sIntPtr ) ints4 ints == 4 )+    ]+  where+    ints, ints4 :: Ptr CInt+    ints  = nullPtr+    ints4 = nullPtr `plusPtr` 16+    doubles :: Ptr CDouble+    doubles = nullPtr+    sIntArith :: SArithmeticType CInt+    sIntArith = SIntegral $ SIntLike SInt+    sInt :: SType SArithmeticType CInt+    sInt = SArithmetic sIntArith+    sIntPtr :: SType SArithmeticType ( Ptr CInt )+    sIntPtr = SPtr $ SObjPointee sIntArith  clangResourceDirArgs :: IO [ String ] clangResourceDirArgs = do