diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# try-storable-hetero-list diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Foreign/Storable/HeteroList.hs b/src/Foreign/Storable/HeteroList.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/HeteroList.hs @@ -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 +-} diff --git a/storable-hetero-list.cabal b/storable-hetero-list.cabal new file mode 100644 --- /dev/null +++ b/storable-hetero-list.cabal @@ -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 +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"