<commit_before>{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, 
             FlexibleInstances, TypeSynonymInstances, 
             EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables, 
             GADTs #-}

-----------------------------------------------------------------------------
-- |
-- Module      : FFICXX.Runtime.Cast
-- Copyright   : (c) 2011-2013 <NAME>
--
-- License     : BSD3
-- Maintainer  : <NAME> <<EMAIL>>
-- Stability   : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------

module FFICXX.Runtime.Cast where

import Data.Word
import Foreign.C            
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Array

import System.IO.Unsafe

class Castable a b where
  cast :: a -> b 
  uncast :: b -> a 

class FPtr a where
  type Raw a :: *
  get_fptr :: a -> ForeignPtr (Raw a) 
  cast_fptr_to_obj :: ForeignPtr (Raw a) -> a

class Existable a where
  data Exist a :: *  

data BottomType

class GADTTypeable a where
  data GADTType a :: * -> *
  data EGADTType a :: *




{-
-- eliminate this for the time being to have a solution with Repl
instance Castable a a where
  cast = id
  uncast = id
-}

instance Castable () () where
  cast = id 
  uncast = id 

instance Castable Int CInt where
  cast = fromIntegral 
  uncast = fromIntegral

instance Castable Word CUInt where
  cast = fromIntegral
  uncast = fromIntegral

instance Castable Word8 CChar where
  cast = fromIntegral 
  uncast = fromIntegral
  
instance Castable Double CDouble where
  cast = realToFrac
  uncast = realToFrac 

instance Castable [Double] (Ptr CDouble) where
  cast xs = unsafePerformIO (newArray (map realToFrac xs))
  uncast _c_xs = undefined 

instance Castable [Int] (Ptr CInt) where
  cast xs = unsafePerformIO (newArray (map fromIntegral xs))
  uncast _c_xs = undefined 

instance Castable String CString where
  cast x = unsafePerformIO (newCString x)
  uncast x = unsafePerformIO (peekCString x) 

instance Castable [String] (Ptr CString) where
  cast xs = unsafePerformIO (mapM  newCString xs >>= newArray)
  uncast _c_xs = undefined

instance Castable (Ptr a) (Ptr a) where 
  cast = id 
  uncast = id 


instance (Castable a a', Castable b b') => Castable (a->b) (a'->b') where
  cast f = cast . f . uncast
  uncast f = uncast . f . cast <commit_msg>add several Castable instances for (Ptr a) (Ptr a) (we cannot do generically due to incoherent instances)<commit_after>{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, 
             FlexibleInstances, TypeSynonymInstances, 
             EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables, 
             GADTs #-}


-----------------------------------------------------------------------------
-- |
-- Module      : FFICXX.Runtime.Cast
-- Copyright   : (c) 2011-2013 <NAME>
--
-- License     : BSD3
-- Maintainer  : <NAME> <<EMAIL>>
-- Stability   : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------

module FFICXX.Runtime.Cast where

import Data.Word
import Foreign.C            
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Array

import System.IO.Unsafe

class IsRawType a 

class Castable a b where
  cast :: a -> b 
  uncast :: b -> a 

class FPtr a where
  type Raw a :: *
  get_fptr :: a -> ForeignPtr (Raw a) 
  cast_fptr_to_obj :: ForeignPtr (Raw a) -> a

class Existable a where
  data Exist a :: *  

data BottomType

class GADTTypeable a where
  data GADTType a :: * -> *
  data EGADTType a :: *

class IsCType a where 


instance IsCType CChar
instance IsCType CInt
instance IsCType CUInt 
instance IsCType CString 
instance IsCType CULong 
instance IsCType CLong

-- cause incoherent instances but cannot avoid it now
{-
instance Castable a a where
  cast = id
  uncast = id
-}

instance Castable () () where
  cast = id 
  uncast = id 


instance Castable (Ptr CInt) (Ptr CInt) where 
  cast = id 
  uncast = id 

instance Castable (Ptr CChar) (Ptr CChar) where 
  cast = id 
  uncast = id 

instance Castable (Ptr CUInt) (Ptr CUInt) where 
  cast = id 
  uncast = id 

instance Castable (Ptr CULong) (Ptr CULong) where 
  cast = id 
  uncast = id 

instance Castable (Ptr CLong) (Ptr CLong) where 
  cast = id 
  uncast = id 



instance Castable CUInt CUInt where
  cast = id 
  uncast = id 

instance Castable CInt CInt where 
  cast = id 
  uncast = id 

instance Castable CULong CULong where 
  cast = id 
  uncast = id 


instance Castable Int CInt where
  cast = fromIntegral 
  uncast = fromIntegral

instance Castable Word CUInt where
  cast = fromIntegral
  uncast = fromIntegral

instance Castable Word8 CChar where
  cast = fromIntegral 
  uncast = fromIntegral
  
instance Castable Double CDouble where
  cast = realToFrac
  uncast = realToFrac 

instance Castable [Double] (Ptr CDouble) where
  cast xs = unsafePerformIO (newArray (map realToFrac xs))
  uncast _c_xs = undefined 

instance Castable [Int] (Ptr CInt) where
  cast xs = unsafePerformIO (newArray (map fromIntegral xs))
  uncast _c_xs = undefined 

instance Castable String CString where
  cast x = unsafePerformIO (newCString x)
  uncast x = unsafePerformIO (peekCString x) 

instance Castable [String] (Ptr CString) where
  cast xs = unsafePerformIO (mapM  newCString xs >>= newArray)
  uncast _c_xs = undefined


instance (Castable a a', Castable b b') => Castable (a->b) (a'->b') where
  cast f = cast . f . uncast
  uncast f = uncast . f . cast 
{'fraction_non_alphanumeric': 0.12977649603460706, 'fraction_numerical': 0.003604902667627974, 'mean_word_length': 2.505369551484523, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 31, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6508815', 'n_tokens_mistral': 1821, 'n_tokens_neox': 1707, 'n_words': 604}