ats-storable 0.2.1.0 → 0.3.0.0

raw patch · 5 files changed

+181/−52 lines, 5 filesdep +ats-storabledep +hspecdep +microlensdep ~basedep ~composition-preludebuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: ats-storable, hspec, microlens, microlens-th

Dependency ranges changed: base, composition-prelude

API changes (from Hackage documentation)

Files

• README.md +0/−8
• Setup.hs +5/−2
• ats-storable.cabal +32/−4
• src/Foreign/Storable/ATS.hs +112/−38
• test/Spec.hs +32/−0

@@ -1,8 +0,0 @@-# ats-storable--Resuscitation of-[generic-storable](hackage.haskell.org/package/generic-storable) altered to-work with ATS' algebraic data types.--For documentation of how to use the ATS side of things, consult the-[documentation](http://ats-lang.sourceforge.net/DOCUMENT/INT2PROGINATS/HTML/x2179.html).

@@ -1,2 +1,5 @@-import Distribution.Simple-main = defaultMain+import           Distribution.ATS+import           Distribution.Simple++main = defaultMainWithHooks $+    atsUserHooks [ atsPrelude [0,3,9] ]

@@ -1,5 +1,5 @@ name:                ats-storable-version:             0.2.1.0+version:             0.3.0.0 synopsis:            Marshal ATS types into Haskell description:         Facilities for sharing types between ATS and Haskell homepage:            https://github.com//ats-generic#readme@@ -9,8 +9,7 @@ maintainer:          vamchale@gmail.com copyright:           Copyright: (c) 2018 Vanessa McHale category:            ATS, Generics-build-type:          Simple-extra-doc-files:     README.md+build-type:          Custom cabal-version:       1.18  Flag development {@@ -19,19 +18,48 @@   default: False } +Flag with-atsdeps {+  Description: Download ATS dependencies (for running the test suite)+  default: False+}++custom-setup+  setup-depends:   base+                 , ats-setup >= 0.4.0.0+                 , Cabal+ library   hs-source-dirs:      src   exposed-modules:     Foreign.Storable.ATS-  build-depends:       base >= 4.9 && < 5+  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++test-suite ats-storable-test+  -- c-sources:           cbits/types.c+  -- include-dirs:        ats-deps/prelude/ATS2-Postiats-include-0.3.9+  --                    , ats-deps/prelude/ATS2-Postiats-include-0.3.9/ccomp/runtime+  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

@@ -13,10 +13,17 @@ {-# LANGUAGE TypeOperators           #-} {-# LANGUAGE UndecidableInstances    #-} +-- | You'll probably want to use this module to simply derive an 'ATSStorable' instance. To do so:+--+-- > {-# LANGUAGE DeriveGeneric      #-}+-- > {-# LANGUAGE DeriveDataTypeable #-}+-- > {-# LANGUAGE DeriveAnyClass     #-}+-- >+-- > data MyType a = MyType a+-- >     deriving (Generic, Data, ATSStorable) module Foreign.Storable.ATS     ( ATSStorable (..)     , AsCString (..)-    , Indexed (..)     ) where  import           Control.Composition@@ -54,21 +61,27 @@ instance AsCString BSL.ByteString where     toCString = flip BS.useAsCString pure . BSL.toStrict +data ATSTypeConfig = ATSTypeConfig { _i         :: Word8 -- ^ Index of the particular constructor+                                   , n          :: Word8 -- ^ Number of constructors for the type+                                   , _recursive :: Bool -- ^ Whether or not the type is self-recursive+                                   , _special   :: Bool -- ^ Flag to be set when the type has exactly one self-recursive type.+                                   }+ class Storable' f where      sizeOf' :: f a -> Int      alignment' :: f a -> Int -    peek' :: Word8 -> Ptr (f a) -> IO (f a)+    peek' :: ATSTypeConfig -> Ptr (f a) -> IO (f a) -    poke' :: Word8 -> Ptr (f a) -> f a -> IO ()+    poke' :: ATSTypeConfig -> Ptr (f a) -> f a -> IO () -    pokeByteOff' :: Ptr (f a) -> Int -> f a -> IO ()-    pokeByteOff' = poke' 0 .* plusPtr+    pokeByteOff' :: ATSTypeConfig -> Ptr (f a) -> Int -> f a -> IO ()+    pokeByteOff' cfg = poke' cfg .* plusPtr -    peekByteOff' :: Ptr (f a) -> Int -> IO (f a)-    peekByteOff' = peek' 0 .* plusPtr+    peekByteOff' :: ATSTypeConfig -> Ptr (f a) -> Int -> IO (f a)+    peekByteOff' cfg = peek' cfg .* plusPtr  instance Storable' U1 where     sizeOf' = pure 0@@ -85,23 +98,27 @@ instance (Storable' a, Storable' b) => Storable' (a :*: b) where     sizeOf' _ = sizeOf' (undefined :: a x) + sizeOf' (undefined :: b x)     alignment' _ = gcd (alignment' (undefined :: a x)) (alignment' (undefined :: b x))-    peek' n ptr = do-        a <- peek' n (castPtr ptr)-        (a :*:) <$> peekByteOff' (castPtr ptr) (sizeOf' a)-    poke' n ptr (a :*: b) = mconcat-        [ poke' n (castPtr ptr) a-        , pokeByteOff' (castPtr ptr) (sizeOf' a) b ]+    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 ] -asIndex :: (Data a) => a -> Int-asIndex x = subtract 1 . length $ takeWhile (/= ix) cs+numConstructors :: (Data a) => a -> Int+numConstructors x = subtract 1 . length $ takeWhile (/= ix) cs     where ix = toConstr x           cs = dataTypeConstrs (dataTypeOf x) -sumHelper :: Storable' f => Word8 -> Ptr a -> f b -> IO ()-sumHelper n ptr val = do-    bptr <- mallocBytes (sizeOf' val)-    poke' n bptr val-    C.poke (castPtr ptr) bptr+sumHelper :: Storable' f => ATSTypeConfig+                         -> Ptr a -- ^ Pointer we want to write our value at+                         -> f b -- ^ Value to be written+                         -> IO ()+sumHelper cfg@(ATSTypeConfig _ _ _ True) ptr val = do+    bytesPtr <- mallocBytes (sizeOf' val)+    poke' cfg bytesPtr val+    C.poke (castPtr ptr) bytesPtr+sumHelper _ _ _ = undefined  ptrSize :: Int ptrSize = C.sizeOf (undefined :: (Ptr Word8))@@ -109,14 +126,24 @@ instance (Storable' a, Storable' b) => Storable' (a :+: b) where     sizeOf' _ = 1 + ptrSize     alignment' _ = 1++    peek' cfg@(ATSTypeConfig _ _ _ True) ptr = do+        i' <- C.peek (castPtr ptr) :: IO Word8+        bool+            (R1 <$> (peek' cfg (castPtr ptr) :: IO (b x)))+            (L1 <$> (peek' cfg (castPtr ptr) :: IO (a x)))+            (i' /= 0)     peek' _ _ = undefined-    poke' n ptr (L1 val) = mconcat-        [ C.poke (castPtr ptr) n-        , sumHelper n ptr val ]-    poke' n ptr (R1 val) = mconcat-        [ C.poke (castPtr ptr) n-        , sumHelper n ptr val ] +    poke' cfg@(ATSTypeConfig _ _ _ True) ptr (L1 val) = mconcat+        [ C.poke (castPtr ptr) (n cfg)+        , sumHelper cfg ptr val ]+    poke' cfg@(ATSTypeConfig _ _ _ True) ptr (R1 val) = mconcat+        [ 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)@@ -126,29 +153,76 @@ instance (Storable' a) => Storable' (M1 i c a) where     sizeOf' _ = sizeOf' (undefined :: a x)     alignment' _ = alignment' (undefined :: a x)-    peek' n ptr = pure M1 <*> peek' n (castPtr ptr)-    poke' n ptr (M1 val) = poke' n (castPtr ptr) val+    peek' cfg ptr = pure M1 <*> peek' cfg (castPtr ptr)+    poke' cfg ptr (M1 val) = poke' cfg (castPtr ptr) val -instance C.Storable a => Indexed a where-    index :: a -> Word8-    index = pure 1+index' :: Data a => a -> Word8+index' = fromIntegral . constrIndex . toConstr -class Indexed a where-    index :: a -> Word8-    default index :: Data a => a -> Word8-    index = fromIntegral . asIndex+count' :: Data a => a -> Word8+count' = fromIntegral . numConstructors -instance (Generic a, Storable' (Rep a), Data a) => C.Storable a where+atsCfg' :: (Recurse a, Data a) => a -> ATSTypeConfig+atsCfg' a = ATSTypeConfig (index' a) (count' a) (selfRecursive a) (isSpecial a)++instance (Generic a, Storable' (Rep a), Data a, Recurse a) => C.Storable a where     sizeOf _ = (sizeOf' . from) (undefined :: a)     alignment = C.sizeOf-    poke ptr x = poke' (index x) (castPtr ptr) (from x)-    peek = fmap to . peek' undefined . castPtr+    poke ptr x = poke' (atsCfg' x) (castPtr ptr) (from x)+    peek = fmap to . peek' (atsCfg' (undefined :: a)) . castPtr +class Recurse' f where++    selfRecursive' :: f a -> Bool+    isSpecial' :: f a -> Bool++instance Recurse' V1 where+    selfRecursive' = undefined+    isSpecial' = undefined++instance Recurse' U1 where+    selfRecursive' = pure False+    isSpecial' = pure False++instance (Recurse' a, Recurse' b) => Recurse' (a :+: b) where++    selfRecursive' _ = selfRecursive' (undefined :: a x) || selfRecursive' (undefined :: b x)+    isSpecial' _ = selfRecursive' (undefined :: a x) /= selfRecursive' (undefined :: b x)++instance (Recurse' a, Recurse' b) => Recurse' (a :*: b) where++    selfRecursive' _ = selfRecursive' (undefined :: a x) || selfRecursive' (undefined :: b x)+    isSpecial' _ = selfRecursive' (undefined :: a x) || selfRecursive' (undefined :: b x)++instance Recurse' a => Recurse' (M1 i c a) where++    selfRecursive' (M1 val) = selfRecursive' val+    isSpecial' (M1 val) = isSpecial' val++instance Recurse' (K1 i a) where++    selfRecursive' = pure True+    isSpecial' = pure True++class Recurse a where++    selfRecursive :: a -> Bool++    isSpecial :: a -> Bool++instance (Generic a, Recurse' (Rep a)) => Recurse a where++    selfRecursive = selfRecursive' . from++    isSpecial = isSpecial' . from+ class ATSStorable a where +    -- | Read a value at a pointer.     readPtr :: C.Storable a => Ptr a -> IO a     readPtr = C.peek +    -- Write a value to a pointer.     writePtr :: C.Storable a => a -> IO (Ptr a)     writePtr val = do         ptr <- mallocBytes (C.sizeOf val)

@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveAnyClass           #-}+{-# LANGUAGE DeriveDataTypeable       #-}+{-# LANGUAGE DeriveFunctor            #-}+{-# LANGUAGE DeriveGeneric            #-}+{-# LANGUAGE ForeignFunctionInterface #-}++import           Data.Data            (Data)+import           Foreign.C.Types+import           Foreign.Ptr+import           Foreign.Storable.ATS+import           GHC.Generics         (Generic)+import           Test.Hspec++foreign import ccall unsafe something :: Ptr (Option Product)++data Option a = Some a+              | None+              deriving (Show, Eq, Generic, Functor, Data, ATSStorable)++data Pair a b = Pair { _first :: a, _second :: b }+    deriving (Show, Eq, Generic, Data, ATSStorable)++type Product = Pair CInt CInt++somethingVal :: IO (Option Product)+somethingVal = readPtr something++main :: IO ()+main = hspec $+    describe "readPtr" $+        parallel $ it "should work on a combined sum/product type" $+            somethingVal >>= (`shouldBe` (Some (Pair 1 6)))