Hs2lib-0.5.7: FFI.hs

{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances   #-}

import Control.Applicative
import Control.Monad
import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Array

class Context t where
    type Collapse t :: *    
    type Cxt t :: * -> *    
    collapse :: t -> Collapse t
    
newtype PureCxt a = PureCxt { unwrapPure :: a }
    
instance Functor PureCxt where 
   fmap f = PureCxt . f . unwrapPure
instance Applicative PureCxt where 
    pure  = PureCxt
    (<*>) = \(PureCxt f) (PureCxt x) -> PureCxt (f x)
instance Monad PureCxt where
    return  = pure
    m >>= k = k $ unwrapPure m

-- strip out pure contexts, only needs to look at one layer
instance Context (PureCxt a) where
    type Collapse (PureCxt a) = a
    type Cxt (PureCxt a) = PureCxt
    collapse = unwrapPure
    
-- merge IO contexts using join
instance Context (IO (IO a)) where
    type Collapse (IO (IO a)) = IO a
    type Cxt (IO (IO a)) = IO
    collapse = join
    
-- remove contexts underneath IO... this might need to be recursive. haven't
-- thought through all the ways contexts can stack up yet.
instance Context (IO (PureCxt a)) where
    type Collapse (IO (PureCxt a)) = IO a
    type Cxt (IO (PureCxt a)) = IO
    collapse = fmap unwrapPure

-- defer IO on a function to only the result. definitely recursive here.
instance (Context (IO b)) => Context (IO (a -> b)) where
    type Collapse (IO (a -> b)) = a -> Collapse (IO b)
    type Cxt (IO (a -> b)) = IO
    collapse x y = collapse $ fmap ($ y) x
    
-- should probably rethink to what extent I want to separate these...
type family ForeignCxt int :: * -> *

type instance ForeignCxt () = PureCxt

class Convert ext int | ext -> int, int -> ext where
    type Foreign int :: *
    type Native ext :: *
    toForeign :: Native ext  -> ForeignCxt (Native  ext) (Foreign int)
    toNative  :: Foreign int -> ForeignCxt (Foreign int) (Native ext)

instance Convert () () where
    type Foreign () = ()
    type Native  () = ()
    toForeign = pure
    toNative  = pure
    
type instance ForeignCxt Int = PureCxt
type instance ForeignCxt CInt = PureCxt
instance Convert CInt Int where
    type Foreign Int = CInt
    type Native CInt = Int
    toForeign = pure . fromIntegral
    toNative = pure . fromIntegral

type instance ForeignCxt Double = PureCxt
type instance ForeignCxt CDouble = PureCxt
instance Convert CDouble Double where
    type Foreign Double = CDouble
    type Native CDouble = Double
    toForeign = pure . realToFrac
    toNative = pure . realToFrac

type instance ForeignCxt Float = PureCxt
type instance ForeignCxt CFloat = PureCxt
instance Convert CFloat Float where
    type Foreign Float = CFloat
    type Native CFloat = Float
    toForeign = pure . realToFrac
    toNative = pure . realToFrac


type instance ForeignCxt String = IO
type instance ForeignCxt CWString = IO
instance Convert CWString String where
    type Foreign String  = CWString
    type Native CWString = String
    toForeign = newCWString
    toNative  = peekCWString

-- a quick and dirty way to represent arrays; the Int is because we need a size
-- to convert from an array, and the newtype is because otherwise instances
-- for [a] would overlap with String (which is actually [Char])
-- it would probably be nice to handle the (Int,_) as a context, actually,
-- but I'm not sure what the most effective way to do that would be.
type SizedArray a = (Int, Ptr a)
newtype AsArray a = AsArray { getSizedArray :: [a] }
-- instance Newtype (AsArray a) [a] where
    -- pack = AsArray
    -- unpack = getSizedArray

type instance ForeignCxt (AsArray a) = IO
type instance ForeignCxt (SizedArray a) = IO
instance (Storable a) => Convert (SizedArray a) (AsArray a) where
    type Foreign (AsArray a) = (SizedArray a)
    type Native (SizedArray a) = (AsArray a) 
    toForeign xs = let xs' = getSizedArray xs in (,) (length xs') <$> newArray xs'
    toNative = fmap AsArray . uncurry peekArray

class FFImport ext where
    type Import ext :: *
    ffImport :: ext -> Import ext

class FFExport int where
    type Export int :: *
    ffExport :: int -> Export int
    
class A a where
  type Res a :: *
  foo :: a -> Res a
  
instance A Int where
  type Res Int = Int
  foo x = x + 4

-- instance ( Context (IO (ForeignCxt a (Native a)))
         -- , Convert a (Native a)
         -- ) => FFImport (IO a) where
    -- type Import (IO a) = Collapse (IO (ForeignCxt a (Native a)))
    -- ffImport x = collapse $ toNative <$> x

-- instance ( FFImport b, Convert a (Native a)
         -- , Context (ForeignCxt (Native a) (Import b))
         -- , Functor (ForeignCxt (Native a))
         -- ) => FFImport (a -> b) where
    -- type Import (a -> b) = Native a -> Collapse (ForeignCxt (Native a) (Import b))
    -- ffImport f x = collapse $ ffImport . f <$> toForeign x

-- instance ( Context (IO (ForeignCxt a (Foreign a)))
         -- , Convert (Foreign a) a
         -- ) => FFExport (IO a) where
    -- type Export (IO a) = Collapse (IO (ForeignCxt a (Foreign a)))
    -- ffExport x = collapse $ toForeign <$> x

-- instance ( FFExport b, Convert (Foreign a) a
         -- , Context (ForeignCxt (Foreign a) (Export b))
         -- , Functor (ForeignCxt (Foreign a))
         -- ) => FFExport (a -> b) where
    -- type Export (a -> b) = Foreign a -> Collapse (ForeignCxt (Foreign a) (Export b))
    -- ffExport f x = collapse $ ffExport . f <$> toNative x
    
-- instance ( FFImport (a -> b)
         -- , FFExport (c -> d)
         -- , Context (Native a -> Collapse (ForeignCxt (Native a) (Import b)))
         -- ) => Convert (a -> b) (c -> d) where
    -- type Native  (a -> b) = Import (a -> b)
    -- type Foreign (c -> d) = Export (c -> d)
    -- toNative = collapse . ffImport