storable-peek-poke (empty) → 0.1.0.1

raw patch · 8 files changed

+224/−0 lines, 8 filesdep +basedep +storable-peek-pokedep +typelevel-tools-yjsetup-changed

Dependencies added: base, storable-peek-poke, typelevel-tools-yj

Files

• CHANGELOG.md +11/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• src/Foreign/Storable/PeekPoke.hs +20/−0
• src/Foreign/Storable/PeekPoke/Internal.hs +104/−0
• storable-peek-poke.cabal +54/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,11 @@+# Changelog for `try-storable-peek-poke`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2023++All rights reserved.++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 Yoshikuni Jujo nor the names of other+      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+OWNER 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.

@@ -0,0 +1,1 @@+# storable-peek-poke

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,20 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.Storable.PeekPoke (++	-- * Sizable, Peek and Poke++	Sizable(..), Peek(..), peekMaybe, Poke(..),++	-- * Peekable, WithPoked and Pokable++	Peekable, peekArray',+	WithPoked(..), PtrS, ptrS, withPtrS, withPokedMaybe',+	Pokable, withPoked, withPokedMaybe,++	-- * Storable' and NullPtr++	Storable', pattern NullPtr ) where++import Foreign.Storable.PeekPoke.Internal

@@ -0,0 +1,104 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.Storable.PeekPoke.Internal (++	-- * Sizable, Peek and Poke++	Sizable(..), Peek(..), peekMaybe, Poke(..),++	-- * Peekable, WithPoked and Pokable++	Peekable, peekArray',+	WithPoked(..), PtrS(..), ptrS, withPtrS, withPokedMaybe',+	Pokable, withPoked, withPokedMaybe,++	-- * Storable' and NullPtr++	Storable', pattern NullPtr ) where++import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Storable+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe++class Sizable a where sizeOf' :: Int; alignment' :: Int+class Peek a where peek' :: Ptr a -> IO a+class Poke a where poke' :: Ptr a -> a -> IO ()++class (Sizable a, Peek a) => Peekable a+instance (Sizable a, Peek a) => Peekable a++class (Sizable a, Poke a, WithPoked a) => Pokable a+instance (Sizable a, Poke a) => Pokable a++class (Peekable a, Pokable a, Storable a) => Storable' a+instance (Peekable a, Pokable a, Storable a) => Storable' a++instance {-# OVERLAPPABLE #-} Storable a => Sizable a where+	sizeOf' = sizeOf @a undefined+	alignment' = alignment @a undefined++instance {-# OVERLAPPABLE #-} Storable a => Peek a where peek' = peek+instance {-# OVERLAPPABLE #-} Storable a => Poke a where poke' = poke++withPoked :: Pokable a => a -> (Ptr a -> IO b) -> IO b+withPoked x f = alloca' \p -> poke' p x >> f p++withPokedMaybe :: Pokable a => Maybe a -> (Ptr a -> IO b) -> IO b+withPokedMaybe = \case Nothing -> ($ NullPtr); Just x -> withPoked x++alloca' :: forall a b . Sizable a => (Ptr a -> IO b) -> IO b+alloca' = allocaBytesAligned (sizeOf' @a) (alignment' @a)++pattern NullPtr :: Ptr a+pattern NullPtr <- ((== nullPtr) -> True) where NullPtr = nullPtr++peekMaybe :: Peek a => Ptr a -> IO (Maybe a)+peekMaybe = \case NullPtr -> pure Nothing; p -> Just <$> peek' p++peekArray' :: forall a . Peekable a => Int -> Ptr a -> IO [a]+peekArray' n ((`alignPtr` (alignment' @a)) -> p)+	| n <= 0 = pure []+	| True = (:) <$> peek' p <*> peekArray' (n - 1) (p `plusPtr` sizeOf' @a)++newtype PtrS s a = PtrS_ (Ptr a) deriving Show++ptrS :: Ptr a -> PtrS s a+ptrS = PtrS_++castPtrS :: PtrS s a -> PtrS s b+castPtrS (PtrS_ p) = PtrS_ $ castPtr p++pattern NullPtrS :: PtrS s a+pattern NullPtrS <- PtrS_ NullPtr where NullPtrS = PtrS_ NullPtr++withPtrS :: PtrS s a -> (Ptr a -> IO b) -> IO ()+withPtrS (PtrS_ p) = (() <$) . ($ p)++class WithPoked a where+	withPoked' :: a -> (forall s . PtrS s a -> IO b) -> IO b++instance {-# OVERLAPPABLE #-} Pokable a => WithPoked a where+	withPoked' x f = withPoked x $ f . ptrS++withPokedMaybe' :: WithPoked a =>+	Maybe a -> (forall s . PtrS s a -> IO b) -> IO b+withPokedMaybe' = \case Nothing -> ($ NullPtrS); Just x -> withPoked' x++instance WithPoked (TPMaybe.M t 'Nothing) where+	withPoked' TPMaybe.N f = f $ ptrS nullPtr++instance WithPoked (t a) => WithPoked (TPMaybe.M t ('Just a)) where+	withPoked' (TPMaybe.J x) f = withPoked' x (f . castPtrS)++instance {-# OVERLAPPABLE #-} WithPoked a => WithPoked (TMaybe.Id a) where+	withPoked' (TMaybe.Id x) f = withPoked' x (f . castPtrS)

@@ -0,0 +1,54 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           storable-peek-poke+version:        0.1.0.1+synopsis:       class Sizable, Peek and Poke+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/storable-peek-poke#readme>+category:       Data, Foreign+homepage:       https://github.com/YoshikuniJujo/storable-peek-poke#readme+bug-reports:    https://github.com/YoshikuniJujo/storable-peek-poke/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      @2023 Yoshikuni Jujo+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/storable-peek-poke++library+  exposed-modules:+      Foreign.Storable.PeekPoke+      Foreign.Storable.PeekPoke.Internal+  other-modules:+      Paths_storable_peek_poke+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , typelevel-tools-yj+  default-language: Haskell2010++test-suite storable-peek-poke-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_storable_peek_poke+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , storable-peek-poke+    , typelevel-tools-yj+  default-language: Haskell2010

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"