packages feed

storable-generic (empty) → 0.1.0.5

raw patch · 9 files changed

+332/−0 lines, 9 filesdep +basedep +storable-genericdep +storable-peek-pokesetup-changed

Dependencies added: base, storable-generic, storable-peek-poke, template-haskell

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `try-storable-generic`++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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# storable-generic
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Foreign/Storable/Generic.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-orphans #-}++module Foreign.Storable.Generic (++	-- * STORABLE CLASS FOR GENERIC++	G(..),++	-- * WRAPPER++	W(..)++	) where++import Foreign.Storable.Generic.TH+import Foreign.Storable.Generic.Internal++instanceTuples `mapM` [2 .. 15]
+ src/Foreign/Storable/Generic/Internal.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.Storable.Generic.Internal (G(..), W(..)) where++import GHC.Generics+import Foreign.Ptr+import Foreign.Storable+import Foreign.Storable.PeekPoke+import Data.Kind++class G a where+	gSizeOf :: a -> Int+	gAlignment :: a -> Int+	gPeek :: Ptr a -> IO a+	gPoke :: Ptr a -> a -> IO ()++	default gSizeOf :: MapTypeVal2 Sizable (Flatten (Rep a)) => a -> Int+	gSizeOf _ = fst (wholeSizeAlignmentNew @a)++	default gAlignment :: MapTypeVal2 Sizable (Flatten (Rep a)) => a -> Int+	gAlignment _ = snd (wholeSizeAlignmentNew @a)++	default gPeek :: (Generic a, Gg (Rep a)) => Ptr a -> IO a+	gPeek = (to <$>) . ggPeek . castPtr++	default gPoke :: (Generic a, Gg (Rep a)) => Ptr a -> a -> IO ()+	gPoke p = ggPoke (castPtr p) . from++class Gg f where+	ggSizeOf :: f a -> Int -> Int+	ggAlignment :: f a -> Int+	ggHeadAlignment :: f a -> Int+	ggPeek :: Ptr (f a) -> IO (f a)+	ggPoke :: Ptr (f a) -> f a -> IO ()++instance Gg U1 where+	ggSizeOf _ sz = sz+	ggAlignment _ = 1+	ggHeadAlignment _ = 1+	ggPeek _ = pure U1+	ggPoke _ _ = pure ()++instance (Storable a, Gg b) => Gg (K1 _i a :*: b) where+	ggSizeOf _ sz = ggSizeOf @b undefined (((sz + sizeOf @a undefined - 1) `div` a + 1) * a)+		where a = ggHeadAlignment @b undefined+	ggAlignment _ = alignment @a undefined `lcm` ggAlignment @b undefined+	ggHeadAlignment _ = alignment @a undefined+	ggPeek p = (:*:) <$> (K1 <$> peek (castPtr p)) <*> ggPeek (castPtr p')+		where+		ip = ptrToIntPtr p+		p' = intPtrToPtr $ ((ip + (IntPtr $ sizeOf @a undefined) - 1) `div` a + 1) * a+		a = IntPtr $ ggHeadAlignment @b undefined+	ggPoke p (K1 x :*: y) = poke (castPtr p) x >> ggPoke (castPtr p') y+		where+		ip = ptrToIntPtr p+		p' = intPtrToPtr $ ((ip + (IntPtr $ sizeOf @a undefined) - 1) `div` a + 1) * a+		a = IntPtr $ ggHeadAlignment @b undefined++instance Gg (a :*: b) => Gg (M1 _i _c a :*: b) where+	ggSizeOf _ = ggSizeOf @(a :*: b) undefined+	ggAlignment _ = ggAlignment @(a :*: b) undefined+	ggHeadAlignment _ = ggHeadAlignment @(a :*: b) undefined+	ggPeek p = (\(x :*: y) -> (M1 x :*: y)) <$> ggPeek (castPtr p)+	ggPoke p (M1 x :*: y) = ggPoke (castPtr p) (x :*: y)++instance Gg (a :*: (b :*: c)) => Gg ((a :*: b) :*: c) where+	ggSizeOf _ = ggSizeOf @(a :*: (b :*: c)) undefined+	ggAlignment _ = ggAlignment @(a :*: (b :*: c)) undefined+	ggHeadAlignment _ = ggHeadAlignment @(a :*: (b :*: c)) undefined+	ggPeek p = (\(x :*: (y :*: z)) -> (x :*: y) :*: z) <$> ggPeek (castPtr p)+	ggPoke p ((x :*: y) :*: z) = ggPoke (castPtr p) (x :*: (y :*: z))++{-+instance (Gg a, Gg b) => Gg (a :*: b) where+	ggSizeOf _ = ((ggSizeOf @a undefined - 1) `div` a + 1) * a + ggSizeOf @b undefined+		where a = ggAlignment @b undefined+	ggAlignment _ = ggAlignment @a undefined `lcm` ggAlignment @b undefined+	ggPeek p = (:*:) <$> ggPeek (castPtr p) <*> ggPeek (castPtr p')+		where+		p' = p `plusPtr` (((ggSizeOf @a undefined - 1) `div` a + 1) * a)+		a = ggAlignment @b undefined+	ggPoke p (x :*: y) = ggPoke (castPtr p) x >> ggPoke (castPtr p') y+		where+		p' = p `plusPtr` (((ggSizeOf @a undefined - 1) `div` a + 1) * a)+		a = ggAlignment @b undefined+		-}++{-+instance (Gg a, Gg b) => Gg (a :+: b) where+	ggSizeOf _ = ggSizeOf @a undefined `max` ggSizeOf @b undefined+	ggAlignment _ = ggAlignment @a undefined `lcm` ggAlignment @b undefined+	-}++instance Gg a => Gg (M1 i c a) where+	ggSizeOf (M1 x) = ggSizeOf x+	ggAlignment (M1 x) = ggAlignment x+	ggHeadAlignment (M1 x) = ggHeadAlignment x+	ggPeek = (M1 <$>) . ggPeek . castPtr+	ggPoke p (M1 x) = ggPoke (castPtr p) x++instance Storable a => Gg (K1 i a) where+	ggSizeOf (K1 x) sz = align (alignment x) sz + sizeOf x+	ggAlignment (K1 x) = alignment x+	ggHeadAlignment (K1 x) = alignment x+	ggPeek = (K1 <$>) . peek . castPtr+	ggPoke p (K1 x) = poke (castPtr p) x++newtype W a = W { unW :: a }+	deriving (Show, Eq, Ord, Enum)+	deriving newtype Generic++instance G a => Storable (W a) where+	sizeOf = gSizeOf . unW+	alignment = gAlignment . unW+	peek = (W <$>) . gPeek . castPtr+	poke p = gPoke (castPtr p) . unW++{-+instance {-# OVERLAPPABLE #-} G a => Storable a where+	sizeOf = gSizeOf+	alignment = gAlignment+	peek = gPeek+	poke = gPoke+	-}++wholeSizeAlignmentNew ::+	forall a . MapTypeVal2 Sizable (Flatten (Rep a)) => SizeAlignment+wholeSizeAlignmentNew = let sas = sizeAlignmentListNew @a in+	(calcWholeSize sas, calcWholeAlignment sas)++calcWholeAlignment :: [SizeAlignment] -> Alignment+calcWholeAlignment = foldl lcm 1 . (snd <$>)++calcWholeSize :: [SizeAlignment] -> Size+calcWholeSize = foldl next 0 . rotateAlignmentL++next :: Offset -> SizeAlignment -> Offset+next os (sz, algn) = ((os + sz - 1) `div` algn + 1) * algn++type Offset = Int++rotateAlignmentL :: [SizeAlignment] -> [SizeAlignment]+rotateAlignmentL [] = error "empty size and alignment list"+rotateAlignmentL sas = zip ss (as ++ [a]) where (ss, a : as) = unzip sas++sizeAlignmentListNew ::+	forall a . MapTypeVal2 Sizable (Flatten (Rep a)) => [SizeAlignment]+sizeAlignmentListNew = sizeAlignmentTypeList @(Flatten (Rep a))++sizeAlignmentTypeList ::+	forall (as :: [Type]) . MapTypeVal2 Sizable as => [SizeAlignment]+sizeAlignmentTypeList = mapTypeVal2 @Sizable @as (\(_ :: a) -> (sizeOf' @a, alignment' @a))++type Size = Int+type Alignment = Int+type SizeAlignment = (Size, Alignment)++class MapTypeVal2 c (as :: [Type]) where+	mapTypeVal2 :: (forall a . c a => a -> b) -> [b]++instance MapTypeVal2 c '[] where mapTypeVal2 _ = []++instance (c a, MapTypeVal2 c as) => MapTypeVal2 c (a ': as) where+	mapTypeVal2 x = x (undefined :: a) : mapTypeVal2 @c @as x++type family GetType (x :: Type -> Type) :: Type where+	GetType (K1 i a) = a+	GetType (M1 m i a) = GetType a++type family Flatten (x :: Type -> Type) :: [Type] where+	Flatten U1 = '[]+	Flatten (K1 i a) = '[a]+	Flatten (M1 m i a) = Flatten a+	Flatten (M1 m i a :*: t2) = GetType a ': Flatten t2+	Flatten ((t1 :*: t2) :*: t3) = Flatten (t1 :*: t2 :*: t3)++align :: Integral n => n -> n -> n+align algn ofst = ((ofst - 1) `div` algn + 1) * algn
+ src/Foreign/Storable/Generic/TH.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.Storable.Generic.TH (instanceTuples) where++import Language.Haskell.TH+import Foreign.Storable+import Foreign.Storable.Generic.Internal++instanceTuples :: Int -> DecQ+instanceTuples n = bar =<< newName `mapM` take n vars++bar :: [Name] -> DecQ+bar vs = instanceD+	(cxt $ (conT ''Storable `appT`) . varT <$> vs)++	(conT ''G `appT` (foldl ((. varT) . appT) (tupleT $ length vs) vs))+	[]++vars :: [String]+vars = ((: "")+	<$> ['a' .. 'z']) ++ [ cs ++ [c] | cs <- vars, c <- ['a' .. 'z'] ]
+ storable-generic.cabal view
@@ -0,0 +1,57 @@+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-generic+version:        0.1.0.5+synopsis:       Derive Storable instances with GHC.Generics+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/storable-generic#readme>+category:       Foreign+homepage:       https://github.com/YoshikuniJujo/storable-generic#readme+bug-reports:    https://github.com/YoshikuniJujo/storable-generic/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-generic++library+  exposed-modules:+      Foreign.Storable.Generic+  other-modules:+      Foreign.Storable.Generic.Internal+      Foreign.Storable.Generic.TH+      Paths_storable_generic+  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+    , storable-peek-poke <1+    , template-haskell <3+  default-language: Haskell2010++test-suite storable-generic-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_storable_generic+  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-generic+    , storable-peek-poke <1+    , template-haskell <3+  default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"