Skip to content

Instantly share code, notes, and snippets.

@qnikst
Last active Aug 29, 2015
Embed
What would you like to do?
Strange compilation behaviour:
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Main where
import Control.Applicative
import Data.Singletons
import Data.Singletons.TH
import Foreign
import Foreign.Storable
import Foreign.C
import System.IO.Unsafe (unsafePerformIO)
import Unsafe.Coerce
#include "test.h"
-- foreign library
#c
typedef struct s s_t;
#endc
typeS :: Ptr SPtr -> IO M
typeS p = do
t <- {# get s_t->t1 #} (castPtr p)
return $ if t == 0 then A else B
-- Bindings
{# pointer *s_t as SPtr newtype #}
instance Storable SPtr where
sizeOf _ = {#sizeof s_t #}
alignment _ = 8
peek = undefined
poke = undefined
data M = A | B deriving (Eq, Show)
genSingletons [''M]
-- | foreign data
newtype S a = S { unS :: Ptr (V a) }
uns :: S a -> Ptr SPtr
uns = castPtr . unS
s :: Ptr SPtr -> S a
s = S . castPtr
-- | unknown type in runtime
data SomeS = forall a . SomeS (S a)
typeOf :: S a -> M
typeOf = unsafePerformIO . typeS . castPtr . unS
cast :: M -> SomeS -> S a
cast ty (SomeS z)
| ty == typeOf z = s . uns $ z
| otherwise = error "cast: Type failure."
scast :: SM a -> SomeS -> S a
scast ty z = cast (fromSing ty) z
class MkVal a b | a -> b where
mkVal :: a -> IO (S b)
instance MkVal Int A where
mkVal i = do
p <- malloc :: IO (Ptr SPtr)
{# set s_t->t1 #} p 0
{# set s_t->t2 #} p (fromIntegral i)
{# set s_t->t3 #} p 0
return $ S (castPtr p)
instance MkVal Double B where
mkVal i = do
p <- malloc :: IO (Ptr SPtr)
{# set s_t->t1 #} p 0
{# set s_t->t2 #} p 0
{# set s_t->t3 #} p (fromRational . toRational $ i)
return $ S (castPtr p)
data V :: M -> * where
V1 :: Int -> V A
V2 :: Double -> V B
instance Storable (V a) where
sizeOf _ = sizeOf (undefined :: Ptr ())
alignment _ = sizeOf (undefined :: Ptr ())
poke = error "not interesting"
peek s = case typeOf (S s) of
A -> do unsafeCoerce $ V1 . fromIntegral <$> ({# get s_t->t2 #} (castPtr s))
B -> do unsafeCoerce $ V2 . fromRational . toRational <$> ({# get s_t->t3 #} (castPtr s))
foo :: S a -> V a
foo = unsafePerformIO . peek . unS
-- doesn't work
test = do
inner =<< fmap SomeS (mkVal (1::Int))
where
inner :: SomeS -> IO ()
inner z = do
let y = cast A z
case foo y of
V1 i -> print i
-- works
test2 = do
inner =<< fmap SomeS (mkVal (1::Int))
where
inner :: SomeS -> IO ()
inner z = do
let y = scast (sing :: SM A) z
case foo y of
V1 i -> print i
-- works
test3 = do
inner =<< fmap SomeS (mkVal (1::Int))
where
inner :: SomeS -> IO ()
inner z = do
let y = cast A z :: S A
case foo y of
V1 i -> print i
main = test >> test2
#ifndef TEST_H
#define TEST_H
struct s {
int t1;
int t2;
double t3;
};
#endif
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment