ats-storable 0.3.0.1 → 0.3.0.3
raw patch · 6 files changed
+160/−73 lines, 6 filesdep −microlensdep −microlens-thsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: microlens, microlens-th
API changes (from Hackage documentation)
Files
- Setup.hs +2/−5
- ats-src/types.dats +31/−0
- ats-storable.cabal +67/−48
- atspkg.dhall +14/−0
- src/Foreign/Storable/ATS.hs +28/−12
- test/Spec.hs +18/−8
Setup.hs view
@@ -1,5 +1,2 @@-import Distribution.ATS-import Distribution.Simple--main = defaultMainWithHooks $- atsUserHooks [ atsPrelude [0,3,9] ]+import Distribution.Simple+main = defaultMain
+ ats-src/types.dats view
@@ -0,0 +1,31 @@+#define ATS_MAINATSFLAG 1++datavtype option(a: t@ype+) =+ | Some of a+ | None++datavtype tri(a: t@ype+) =+ | First of a+ | Second+ | Third++typedef pair(a: t@ype, b: t@ype) = @{ first = a, second = b }+typedef product = pair(int, int)++extern+fun something() : option(product) =+ "mac#"++extern+fun something_else() : tri(int) =+ "mac#"++implement something () =+ let+ var x: product = @{ first = 1, second = 6 }+ in+ Some(x)+ end++implement something_else () =+ First(2)
ats-storable.cabal view
@@ -1,53 +1,72 @@-name: ats-storable-version: 0.3.0.1-synopsis: Marshal ATS types into Haskell-description: Facilities for sharing types between ATS and Haskell-homepage: https://github.com//ats-generic#readme-license: BSD3-license-file: LICENSE-author: Vanessa McHale-maintainer: vamchale@gmail.com-copyright: Copyright: (c) 2018 Vanessa McHale-category: ATS, Generics-build-type: Simple-cabal-version: 1.18+cabal-version: 1.18+name: ats-storable+version: 0.3.0.3+license: BSD3+license-file: LICENSE+copyright: Copyright: (c) 2018 Vanessa McHale+maintainer: vamchale@gmail.com+author: Vanessa McHale+synopsis: Marshal ATS types into Haskell+description:+ Facilities for sharing types between ATS and Haskell+category: ATS, Generics+build-type: Simple+extra-source-files:+ atspkg.dhall+ ats-src/*.dats -Flag development {- Description: Enable `-Werror`- manual: True- default: False-}+source-repository head+ type: darcs+ location: https://hub.darcs.net/vmchale/ats-storable +flag development+ description:+ Enable `-Werror`+ default: False+ manual: True+ library- hs-source-dirs: src- exposed-modules: Foreign.Storable.ATS- build-depends: base >= 4.10 && < 5- , composition-prelude- , text- , bytestring- , microlens- , microlens-th- default-language: Haskell2010- if flag(development)- ghc-options: -Werror- if impl(ghc >= 8.0)- ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat - ghc-options: -Wall+ exposed-modules:+ Foreign.Storable.ATS+ hs-source-dirs: src+ default-language: Haskell2010+ other-extensions: ConstrainedClassMethods DefaultSignatures+ DeriveDataTypeable FlexibleInstances IncoherentInstances+ InstanceSigs MonoLocalBinds ScopedTypeVariables StandaloneDeriving+ TypeOperators UndecidableInstances+ ghc-options: -Wall+ build-depends:+ base >=4.10 && <5,+ composition-prelude -any,+ text -any,+ bytestring -any+ + if flag(development)+ ghc-options: -Werror+ + if impl(ghc >=8.0)+ ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wcompat test-suite ats-storable-test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs- build-depends: base- , ats-storable- , hspec- if flag(development)- ghc-options: -Werror- if impl(ghc >= 8.0)- ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall- default-language: Haskell2010--source-repository head- type: darcs- location: https://hub.darcs.net/vmchale/ats+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ default-language: Haskell2010+ other-extensions: DeriveAnyClass DeriveDataTypeable DeriveFunctor+ DeriveGeneric+ extra-libraries:+ storable+ -- extra-lib-dirs: ./dist-newstyle/lib+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ base -any,+ ats-storable -any,+ hspec -any+ + if flag(development)+ ghc-options: -Werror+ + if impl(ghc >=8.0)+ ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wcompat
+ atspkg.dhall view
@@ -0,0 +1,14 @@+let prelude = https://raw.githubusercontent.com/vmchale/atspkg/master/ats-pkg/dhall/atspkg-prelude.dhall++in prelude.default ⫽ + { libraries =+ [+ prelude.lib ⫽ + { name = "storable"+ , src = [ "ats-src/types.dats" ]+ , libTarget = "dist-newstyle/lib/libstorable.a"+ , static = True+ }+ ]+ , compiler = [0,3,10]+ }
src/Foreign/Storable/ATS.hs view
@@ -2,12 +2,10 @@ {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-}@@ -30,6 +28,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Data+import Data.Foldable import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Word@@ -101,9 +100,9 @@ peek' cfg ptr = do a <- peek' cfg (castPtr ptr) (a :*:) <$> peekByteOff' cfg (castPtr ptr) (sizeOf' a)- poke' cfg ptr (a :*: b) = mconcat- [ poke' cfg (castPtr ptr) a- , pokeByteOff' cfg (castPtr ptr) (sizeOf' a) b ]+ poke' cfg ptr (a :*: b) =+ poke' cfg (castPtr ptr) a >>+ pokeByteOff' cfg (castPtr ptr) (sizeOf' a) b numConstructors :: (Data a) => a -> Int numConstructors x = subtract 1 . length $ takeWhile (/= ix) cs@@ -118,16 +117,35 @@ bytesPtr <- mallocBytes (sizeOf' val) poke' cfg bytesPtr val C.poke (castPtr ptr) bytesPtr-sumHelper _ _ _ = undefined+sumHelper cfg@(ATSTypeConfig _ _ True False) ptr val = do+ bytesPtr <- mallocBytes (sizeOf' val)+ poke' cfg bytesPtr val+ C.pokeByteOff (castPtr ptr) 1 bytesPtr+sumHelper cfg@(ATSTypeConfig _ _ False False) ptr val =+ pokeByteOff' cfg (castPtr ptr) 1 val ptrSize :: Int ptrSize = C.sizeOf (undefined :: (Ptr Word8)) +-- The rules for storing a type in ATS are somewhat complex, so it bears writing+-- them down here.+--+-- 1. For a type which may be recursive (including all universally quantified+-- types), the variable type must be heap-allocated.+--+-- 2. In the specific case of a (possibly recursive) sum type with two+-- constructors, one of which is empty, we may simply use a null pointer.+--+-- 3. For other types, we simply tag the constructor number and use a boxed+-- (stack-allocated) type.+--+-- Product types are a good deal simpler.+ instance (Storable' a, Storable' b) => Storable' (a :+: b) where sizeOf' _ = 1 + ptrSize alignment' _ = 1 - peek' cfg@(ATSTypeConfig _ _ _ True) ptr = do+ peek' cfg@(ATSTypeConfig _ _ True True) ptr = do i' <- C.peek (castPtr ptr) :: IO Word8 bool (R1 <$> (peek' cfg (castPtr ptr) :: IO (b x)))@@ -135,15 +153,13 @@ (i' /= 0) peek' _ _ = undefined - poke' cfg@(ATSTypeConfig _ _ _ True) ptr (L1 val) = mconcat+ poke' cfg@ATSTypeConfig{} ptr (L1 val) = fold [ C.poke (castPtr ptr) (n cfg) , sumHelper cfg ptr val ]- poke' cfg@(ATSTypeConfig _ _ _ True) ptr (R1 val) = mconcat+ poke' cfg@ATSTypeConfig{} ptr (R1 val) = fold [ C.poke (castPtr ptr) (n cfg) , sumHelper cfg ptr val ] - poke' _ _ _ = undefined- instance (C.Storable a) => Storable' (K1 i a) where sizeOf' _ = C.sizeOf (undefined :: a) alignment' _ = C.alignment (undefined :: a)@@ -222,7 +238,7 @@ readPtr :: C.Storable a => Ptr a -> IO a readPtr = C.peek - -- Write a value to a pointer.+ -- | Write a value to a pointer. writePtr :: C.Storable a => a -> IO (Ptr a) writePtr val = do ptr <- mallocBytes (C.sizeOf val)
test/Spec.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} import Data.Data (Data) import Foreign.C.Types@@ -12,11 +11,17 @@ import Test.Hspec foreign import ccall unsafe something :: Ptr (Option Product)+foreign import ccall unsafe something_else :: Ptr (Tri CInt) data Option a = Some a | None deriving (Show, Eq, Generic, Functor, Data, ATSStorable) +data Tri a = First a+ | Second+ | Third+ deriving (Show, Eq, Generic, Functor, Data, ATSStorable)+ data Pair a b = Pair { _first :: a, _second :: b } deriving (Show, Eq, Generic, Data, ATSStorable) @@ -25,8 +30,13 @@ somethingVal :: IO (Option Product) somethingVal = readPtr something +somethingElseVal :: IO (Tri CInt)+somethingElseVal = readPtr something_else+ main :: IO ()-main = hspec $- describe "readPtr" $- parallel $ it "should work on a combined sum/product type" $+main = hspec $ parallel $+ describe "readPtr" $ do+ it "should work on a combined sum/product type" $ somethingVal >>= (`shouldBe` (Some (Pair 1 6)))+ it "should work on a combined sum/product type" $+ (pure $ pendingWith "not yet") somethingElseVal -- somethingElseVal >>= (`shouldBe` (First 2))