packages feed

storable-hetero-list (empty) → 0.1.0.4

raw patch · 7 files changed

+297/−0 lines, 7 filesdep +basedep +hetero-parameter-listdep +storable-hetero-listsetup-changed

Dependencies added: base, hetero-parameter-list, storable-hetero-list, storable-peek-poke

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `try-storable-hetero-list`++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 @@+# try-storable-hetero-list
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Foreign/Storable/HeteroList.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications, RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds, PolyKinds, ConstraintKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Foreign.Storable.HeteroList (++	-- * SIZE AND ALIGNMENT++	wholeSize, sizeAlignments, infixOffsetSize,+	SizeAlignmentList, InfixOffsetSize, PrefixSize,++	-- * POKABLE++	PokableList(..),++{-+	-- * WITHPOKED++	-- ** Plain++	WithPokedHeteroToListM, withPokedHeteroToListM, withPokedWithHeteroListM,+	WithPokedHeteroToListM', withPokedHeteroToListM',++	-- ** CPS++	WithPokedHeteroToListCpsM,+	withPokedHeteroToListCpsM, withPokedWithHeteroListCpsM,+	WithPokedHeteroToListCpsM',+	withPokedHeteroToListCpsM', withPokedWithHeteroListCpsM'+	-}++	) where++import Foreign.Ptr+import Foreign.Storable.PeekPoke+import Data.Kind+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))++-- Size and Alignment++{-+class SizableList (as :: [Type]) where sizes :: [Int]; alignments :: [Int]++instance SizableList '[] where sizes = []; alignments = []++instance (Sizable a, SizableList as) => SizableList (a ': as) where+	sizes = sizeOf' @a: sizes @as+	alignments = alignment' @a : alignments @as+	-}++sizeAlignments :: forall as . SizeAlignmentList as => [(Int, Int)]+sizeAlignments = sizeAlignmentsFromSizeAlignmentList (sizeAlignmentList @as)+	-- zip (sizes @as) (alignments @as)++sizeAlignmentsFromSizeAlignmentList ::+	HeteroParList.PL SizeAlignmentOfType as -> [(Int, Int)]+sizeAlignmentsFromSizeAlignmentList HeteroParList.Nil = []+sizeAlignmentsFromSizeAlignmentList+	(SizeAlignmentOfType sz algn :** sas) =+	(sz, algn) : sizeAlignmentsFromSizeAlignmentList sas++wholeSize :: forall as . SizeAlignmentList as => Int+wholeSize = calcSize 0 $ sizeAlignments @as++calcSize :: Int -> [(Int, Int)] -> Int+calcSize n [] = n+calcSize n ((sz, al) : szals) = calcSize (((n - 1) `div` al + 1) * al + sz) szals++infixOffsetSize :: forall (part :: [Type]) (whole :: [Type]) .+	InfixOffsetSize part whole => (Offset, Size)+infixOffsetSize = infixOffsetSizeFromSizeAlignmentList @part @whole+	0 (sizeAlignmentList @whole)++data SizeAlignmentOfType (tp :: Type) = SizeAlignmentOfType Size Alignment+	deriving Show++type Size = Int; type Alignment = Int; type Offset = Int++class SizeAlignmentList ts where+	sizeAlignmentList :: HeteroParList.PL SizeAlignmentOfType ts++instance SizeAlignmentList '[] where sizeAlignmentList = HeteroParList.Nil++instance (Sizable t, SizeAlignmentList ts) => SizeAlignmentList (t ': ts) where+	sizeAlignmentList = SizeAlignmentOfType (sizeOf' @t) (alignment' @t) :**+		sizeAlignmentList @ts++class SizeAlignmentList whole => InfixOffsetSize (part :: [Type]) whole where+	infixOffsetSizeFromSizeAlignmentList :: Size ->+		HeteroParList.PL SizeAlignmentOfType whole -> (Offset, Size)++instance (+	Sizable t, SizeAlignmentList whole,+	(t ': ts) `PrefixSize` (t ': whole) ) =>+	InfixOffsetSize (t ': ts) (t ': whole) where+	infixOffsetSizeFromSizeAlignmentList sz0+		saa@(SizeAlignmentOfType _ algn :** _) = (+			align algn sz0,+			prefixSizeFromSizeAlignmentList @(t ': ts) 0 saa )++instance {-# OVERLAPPABLE #-} (Sizable t, InfixOffsetSize ts whole) =>+	InfixOffsetSize ts (t ': whole) where+	infixOffsetSizeFromSizeAlignmentList sz0+		(SizeAlignmentOfType sz algn :** sas) =+		infixOffsetSizeFromSizeAlignmentList @ts+			(align algn sz0 + sz) sas++class PrefixSize (part :: [Type]) whole where+	prefixSizeFromSizeAlignmentList :: Size ->+		HeteroParList.PL SizeAlignmentOfType whole -> Size++instance PrefixSize '[] whole where prefixSizeFromSizeAlignmentList sz _ = sz++instance PrefixSize ts whole => PrefixSize (t ': ts) (t ': whole) where+	prefixSizeFromSizeAlignmentList sz0+		(SizeAlignmentOfType sz algn :** sas) =+		prefixSizeFromSizeAlignmentList @ts (align algn sz0 + sz) sas++align :: Alignment -> Size -> Offset+align algn sz = ((sz - 1) `div` algn + 1) * algn++-- Pokable++class SizeAlignmentList as => PokableList (as :: [Type]) where+	pokeList :: Ptr x -> HeteroParList.L as -> IO ()++instance PokableList '[] where+	pokeList _ HeteroParList.Nil = pure ()++instance (Pokable a, PokableList as) => PokableList (a ': as) where+	pokeList ((`alignPtr` alignment' @a) -> p) (HeteroParList.Id x :** xs) = do+		poke' (castPtr p) x+		pokeList (p `plusPtr` sizeOf' @a) xs++{-+-- WithPoked++type WithPokedHeteroToListM = HeteroParList.ToListWithCM WithPoked++withPokedHeteroToListM :: (+	WithPokedHeteroToListM ss, Applicative m ) =>+	(forall s . WithPoked s => t s -> m a) -> HeteroParList.PL t ss -> m [a]+withPokedHeteroToListM = HeteroParList.toListWithCM @WithPoked++type WithPokedHeteroToListM' = HeteroParList.ToListWithCM' WithPoked++withPokedHeteroToListM' :: forall k t' t ss m a .+	(WithPokedHeteroToListM' t' ss, Applicative m) =>+	(forall (s :: k) . WithPoked (t' s) => t s -> m a) ->+	HeteroParList.PL t ss -> m [a]+withPokedHeteroToListM' = HeteroParList.toListWithCM' @_ @_ @WithPoked @t'++withPokedWithHeteroListM :: (WithPokedHeteroToListM ss, Applicative m) =>+		HeteroParList.PL t ss ->+		(forall s . WithPoked s => t s -> m a) -> m [a]+withPokedWithHeteroListM xs f = withPokedHeteroToListM f xs++type WithPokedHeteroToListCpsM = HeteroParList.ToListWithCCpsM WithPoked++withPokedHeteroToListCpsM :: WithPokedHeteroToListCpsM ns =>+	(forall s . WithPoked s => t s -> (a -> m b) -> m b) ->+	HeteroParList.PL t ns ->+	([a] -> m b) -> m b+withPokedHeteroToListCpsM = HeteroParList.toListWithCCpsM @WithPoked++withPokedWithHeteroListCpsM :: WithPokedHeteroToListCpsM ss =>+	HeteroParList.PL t ss ->+	(forall s . WithPoked s => t s -> (a -> m b) -> m b) ->+	([a] -> m b) -> m b+withPokedWithHeteroListCpsM f xs = withPokedHeteroToListCpsM xs f++type WithPokedHeteroToListCpsM' =+	HeteroParList.ToListWithCCpsM' WithPoked++withPokedHeteroToListCpsM' :: forall k t' t ns a m b .+	WithPokedHeteroToListCpsM' t' ns =>+	(forall (s :: k) . WithPoked (t' s) => t s -> (a -> m b) -> m b) ->+	HeteroParList.PL t ns -> ([a] -> m b) -> m b+withPokedHeteroToListCpsM' =+	HeteroParList.toListWithCCpsM' @_ @WithPoked @t'++withPokedWithHeteroListCpsM' :: forall t' t ss a m b .+	WithPokedHeteroToListCpsM' t' ss =>+	HeteroParList.PL t ss ->+	(forall s . WithPoked (t' s) => t s -> (a -> m b) -> m b) ->+	([a] -> m b) -> m b+withPokedWithHeteroListCpsM' f xs = withPokedHeteroToListCpsM' @_ @t' xs f+-}
+ storable-hetero-list.cabal view
@@ -0,0 +1,55 @@+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-hetero-list+version:        0.1.0.4+synopsis:       about Storable and Hetero list+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/storable-hetero-list#readme>+category:       Data, Foreign+homepage:       https://github.com/YoshikuniJujo/storable-hetero-list#readme+bug-reports:    https://github.com/YoshikuniJujo/storable-hetero-list/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-hetero-list++library+  exposed-modules:+      Foreign.Storable.HeteroList+  other-modules:+      Paths_storable_hetero_list+  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+    , hetero-parameter-list <2+    , storable-peek-poke <2+  default-language: Haskell2010++test-suite storable-hetero-list-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_storable_hetero_list+  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+    , hetero-parameter-list <2+    , storable-hetero-list+    , storable-peek-poke <2+  default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"