Storable.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Storable (tests) where

import qualified LLVM.Extra.Storable as Storable
import qualified LLVM.Extra.Tuple as Tuple

import qualified LLVM.ExecutionEngine as EE
import qualified LLVM.Core as LLVM

import qualified Type.Data.Num.Decimal as TypeNum

import qualified Foreign
import Foreign.Storable.Record.Tuple (Tuple(Tuple))
import Foreign.Ptr (FunPtr, Ptr)

import Data.Complex (Complex)
import Data.Word (Word16, Word32)
import Data.Int (Int8, Int16, Int32)
import Data.Tuple.HT (mapFst)

import qualified Test.QuickCheck.Monadic as QCMon
import qualified Test.QuickCheck as QC



type Importer func = FunPtr func -> func

generateFunction ::
   EE.ExecutionFunction f =>
   Importer f -> LLVM.CodeGenModule (LLVM.Function f) -> IO f
generateFunction imprt code = do
   m <- LLVM.newModule
   fn <- do
      func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> code
      EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func
   LLVM.writeBitcodeToFile "test-storable.bc" m
   return fn


foreign import ccall safe "dynamic" derefTestCasePtr ::
   Importer (Ptr inp -> Ptr out -> IO ())

modul ::
   (Storable.C a, Tuple.ValueOf a ~ al) =>
   (Storable.C b, Tuple.ValueOf b ~ bl) =>
   (al -> LLVM.CodeGenFunction () bl) ->
   LLVM.CodeGenModule (LLVM.Function (Ptr a -> Ptr b -> IO ()))
modul codegen =
   LLVM.createFunction LLVM.ExternalLinkage $ \aPtr bPtr -> do
      flip Storable.store bPtr =<< codegen =<< Storable.load aPtr
      LLVM.ret ()

run ::
   (Show a) =>
   (Storable.C a, Tuple.ValueOf a ~ al) =>
   (Storable.C b, Tuple.ValueOf b ~ bl) =>
   QC.Gen a ->
   (al -> LLVM.CodeGenFunction () bl) ->
   (a -> b -> Bool) ->
   IO QC.Property
run qcgen codegen predicate = do
   funIO <- generateFunction derefTestCasePtr $ modul codegen
   return $ QC.forAll qcgen $ \a ->
      QCMon.monadicIO $ do
         b <-
            QCMon.run $
               Foreign.with a $ \aPtr ->
               Foreign.alloca $ \bPtr -> do
                  funIO aPtr bPtr
                  Foreign.peek bPtr
         QCMon.assert $ predicate a b


roundTrip ::
   (Show a, Eq a, Storable.C a) =>
   QC.Gen a -> IO QC.Property
roundTrip qcgen = run qcgen return (==)


tests :: [(String, IO QC.Property)]
tests =
   map (mapFst ("RoundTrip." ++)) $
   ("()",
      roundTrip (QC.arbitrary :: QC.Gen ())) :
   ("Float",
      roundTrip (QC.arbitrary :: QC.Gen Float)) :
   ("(Word16,Float)",
      roundTrip (fmap Tuple (QC.arbitrary :: QC.Gen (Word16,Float)))) :
   ("(Int8,Bool,Double)",
      roundTrip (fmap Tuple (QC.arbitrary :: QC.Gen (Int8,Bool,Double)))) :
   ("Complex Float",
      roundTrip (QC.arbitrary :: QC.Gen (Complex Float))) :
   ("Vector D3 Int32",
      roundTrip (QC.arbitrary :: QC.Gen (LLVM.Vector TypeNum.D3 Int32))) :
   ("Vector D7 (Int16,Word32)",
      roundTrip (fmap (fmap Tuple)
         (QC.arbitrary :: QC.Gen (LLVM.Vector TypeNum.D7 (Int16,Word32))))) :
   []