diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,2 @@ -import Distribution.ATS -import Distribution.Simple - -main = defaultMainWithHooks $ - atsUserHooks [ atsPrelude [0,3,9] ] +import Distribution.Simple +main = defaultMain diff --git a/ats-src/types.dats b/ats-src/types.dats new file mode 100644 --- /dev/null +++ b/ats-src/types.dats @@ -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) diff --git a/ats-storable.cabal b/ats-storable.cabal --- a/ats-storable.cabal +++ b/ats-storable.cabal @@ -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 diff --git a/atspkg.dhall b/atspkg.dhall new file mode 100644 --- /dev/null +++ b/atspkg.dhall @@ -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] + } diff --git a/src/Foreign/Storable/ATS.hs b/src/Foreign/Storable/ATS.hs --- a/src/Foreign/Storable/ATS.hs +++ b/src/Foreign/Storable/ATS.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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))