{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.J (
JEnv (..)
, jinit
, jLoad
, Profile (..)
, linuxProfile
, macProfile
, windowsProfile
#ifndef mingw32_HOST_OS
, libLinux
, libMac
, profLinux
#else
, libWindows
#endif
, bsDispatch
, bsOut
, JVersion
, JData (..)
, getJData
, setJData
, J
, JDoType
, JGetMType
, JGetRType
, JSetAType
) where
import Control.Applicative (pure, (<$>), (<*>))
import qualified Data.Array.Repa as R
import qualified Data.Array.Repa.Repr.ForeignPtr as RF
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as ASCII
import qualified Data.ByteString.Internal as BS
import Data.Functor (void)
import Data.Semigroup ((<>))
import Foreign.C.String (CString)
import Foreign.C.Types (CChar, CDouble, CInt (..), CLLong (..))
import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import Foreign.Marshal (alloca, copyArray, mallocBytes, peekArray, pokeArray)
import Foreign.Ptr (FunPtr, Ptr, castPtrToFunPtr, plusPtr)
import Foreign.Storable (Storable, peek, pokeByteOff, sizeOf)
import System.Info (arch)
#ifndef mingw32_HOST_OS
import System.Posix.ByteString (RTLDFlags (RTLD_LAZY), RawFilePath, dlopen, dlsym)
#else
import System.Win32.DLL (getProcAddress, loadLibrary)
#endif
data J
data JEnv = JEnv { context :: Ptr J
, evaluator :: JDoType
, reader :: JGetMType
, out :: JGetRType
, setter :: JSetAType
}
type JDoType = Ptr J -> CString -> IO CInt
type JGetMType = Ptr J -> CString -> Ptr CLLong -> Ptr CLLong -> Ptr (Ptr CLLong) -> Ptr (Ptr CChar) -> IO CInt
type JGetRType = Ptr J -> IO CString
type JSetAType = Ptr J -> CLLong -> CString -> CLLong -> Ptr () -> IO CInt
foreign import ccall "dynamic" mkJDo :: FunPtr JDoType -> JDoType
foreign import ccall "dynamic" mkJInit :: FunPtr (IO (Ptr J)) -> IO (Ptr J)
foreign import ccall "dynamic" mkJGetM :: FunPtr JGetMType -> JGetMType
foreign import ccall "dynamic" mkJGetR :: FunPtr JGetRType -> JGetRType
foreign import ccall "dynamic" mkJSetA :: FunPtr JSetAType -> JSetAType
type JVersion = [Int]
squashVersion :: JVersion -> String
squashVersion = concatMap show
squashVersionBS :: JVersion -> BS.ByteString
squashVersionBS = ASCII.pack . squashVersion
#ifndef mingw32_HOST_OS
libLinux :: RawFilePath
libLinux = "/usr/lib/" <> ASCII.pack arch <> "-linux-gnu/libj.so"
libMac :: JVersion -> RawFilePath
libMac v = "/Applications/j64-" <> squashVersionBS v <> "/bin/libj.dylib"
#else
libWindows :: JVersion -> FilePath
libWindows v = "C:\\Program Files\\J" <> squashVersion v <> "\\bin\\j.dll"
#endif
profLinux :: BS.ByteString -> BS.ByteString
profLinux v = "/etc/j/" <> v <> "/profile.ijs"
binpathLinux :: BS.ByteString
binpathLinux = "/usr/bin"
dllLinux :: BS.ByteString -> BS.ByteString
dllLinux v = "libj.so." <> v
linuxProfile :: BS.ByteString
-> Profile
linuxProfile ver = Profile (profLinux ver) binpathLinux (dllLinux ver)
macProfile :: JVersion
-> Profile
macProfile v =
let binPathMac = "/Applications/j64-" <> squashVersionBS v <> "/bin"
in Profile (binPathMac <> "/profile.ijs") binPathMac (binPathMac <> "/libj.dylib")
windowsProfile :: JVersion
-> Profile
windowsProfile v =
let binPathWindows = "C:\\Program Files\\J" <> squashVersionBS v <> "\\bin"
in Profile (binPathWindows <> "\\profile.ijs") binPathWindows (binPathWindows <> "j.dll")
data Profile = Profile { profPath :: BS.ByteString
, binPath :: BS.ByteString
, dllName :: BS.ByteString
}
jLoad :: JEnv
-> Profile
-> IO ()
jLoad jenv (Profile fp bin dll) = bsDispatch jenv ("(3 : '0!:0 y')<'"<> fp <> "'[BINPATH_z_=:'" <> bin <> "'[LIBFILE_z_=:'" <> dll <> "'[ARGV_z_=:''")
#ifndef mingw32_HOST_OS
jinit :: RawFilePath
-> IO JEnv
jinit libFp = do
libj <- dlopen libFp [RTLD_LAZY]
jt <- mkJInit =<< dlsym libj "JInit"
let jeval = mkJDo <$> dlsym libj "JDo"
let jread = mkJGetM <$> dlsym libj "JGetM"
let jOut = mkJGetR <$> dlsym libj "JGetR"
let jSet = mkJSetA <$> dlsym libj "JSetA"
JEnv jt <$> jeval <*> jread <*> jOut <*> jSet
#else
jinit :: FilePath
-> IO JEnv
jinit libFp = do
libj <- loadLibrary libFp
jt <- mkJInit . castPtrToFunPtr =<< getProcAddress libj "JInit"
let jeval = mkJDo . castPtrToFunPtr <$> getProcAddress libj "JDo"
let jread = mkJGetM . castPtrToFunPtr <$> getProcAddress libj "JGetM"
let jOut = mkJGetR . castPtrToFunPtr <$> getProcAddress libj "JGetR"
let jSet = mkJSetA . castPtrToFunPtr <$> getProcAddress libj "JSetA"
JEnv jt <$> jeval <*> jread <*> jOut <*> jSet
#endif
bsDispatch :: JEnv -> BS.ByteString -> IO ()
bsDispatch (JEnv ctx jdo _ _ _) bs =
void $ BS.useAsCString bs $ jdo ctx
bsOut :: JEnv -> IO BS.ByteString
bsOut (JEnv ctx _ _ jout _) = BS.packCString =<< jout ctx
getJData :: R.Shape sh
=> JEnv -> BS.ByteString
-> IO (JData sh)
getJData jenv bs = jData <$> getAtomInternal jenv bs
getAtomInternal :: JEnv -> BS.ByteString
-> IO JAtom
getAtomInternal (JEnv ctx _ jget _ _) bs = do
BS.useAsCString bs $ \name ->
alloca $ \t ->
alloca $ \s ->
alloca $ \r ->
alloca $ \d -> do
jget ctx name t r s d
ty' <- intToJType <$> peek t
rank' <- peek r
let intRank = fromIntegral rank'
shape' <- peekArray intRank =<< peek s
let mult = case ty' of
JBool -> sizeOf (undefined :: CChar)
JChar -> sizeOf (undefined :: CChar)
JInteger -> sizeOf (undefined :: CInt)
JDouble -> sizeOf (undefined :: CDouble)
let resBytes = mult * intRank
res <- mallocForeignPtrBytes resBytes
let arrSz = mult * fromIntegral (product shape')
withForeignPtr res $ \r' -> do
d' <- peek d
copyArray r' d' arrSz
pure $ JAtom ty' shape' res
data JAtom = JAtom !JType ![CLLong] !(ForeignPtr CChar)
data JData sh = JIntArr !(R.Array RF.F sh CInt)
| JDoubleArr !(R.Array RF.F sh CDouble)
| JBoolArr !(R.Array RF.F sh CChar)
| JString !BS.ByteString
setJData :: (R.Shape sh) => JEnv -> BS.ByteString
-> JData sh -> IO CInt
setJData (JEnv ctx _ _ _ jset) name (JIntArr iarr) = BS.useAsCStringLen name $ \(n, sz) -> do
(ds, d) <- repaArr JInteger iarr
jset ctx (fromIntegral sz) n ds d
setJData (JEnv ctx _ _ _ jset) name (JDoubleArr iarr) = BS.useAsCStringLen name $ \(n, sz) -> do
(ds, d) <- repaArr JDouble iarr
jset ctx (fromIntegral sz) n ds d
setJData (JEnv ctx _ _ _ jset) name (JBoolArr iarr) = BS.useAsCStringLen name $ \(n, sz) -> do
(ds, d) <- repaArr JBool iarr
jset ctx (fromIntegral sz) n ds d
setJData (JEnv ctx _ _ _ jset) name (JString bs) = BS.useAsCStringLen name $ \(n, sz) -> do
(ds, d) <- strArr bs
jset ctx (fromIntegral sz) n ds d
repaArr :: (R.Shape sh, Storable e) => JType -> R.Array RF.F sh e -> IO (CLLong, Ptr ())
repaArr jty arr = do
let (rank', sh) = repaSize arr
sz = product sh
let wid = 32 + 8 * (rank' + sz)
ptr <- mallocBytes (fromIntegral wid)
pokeByteOff ptr 0 (227 :: CLLong)
pokeByteOff ptr (sizeOf (undefined :: CLLong)) (jTypeToInt jty)
pokeByteOff ptr (2 * sizeOf (undefined :: CLLong)) sz
pokeByteOff ptr (3 * sizeOf (undefined :: CLLong)) rank'
let dimOff = 4 * sizeOf (undefined :: CLLong)
pokeArray (ptr `plusPtr` dimOff) sh
let dataOff = dimOff + fromIntegral rank' * sizeOf (undefined :: CLLong)
withForeignPtr (RF.toForeignPtr arr) $ \src ->
copyArray (ptr `plusPtr` dataOff) src (fromIntegral sz)
pure (wid, ptr)
strArr :: BS.ByteString -> IO (CLLong, Ptr ())
strArr bs = do
let len = BS.length bs
wid = 40 + 8 * (1 + len `div` 8)
len' = fromIntegral len :: CLLong
ptr <- mallocBytes wid
pokeByteOff ptr 0 (227 :: CLLong)
pokeByteOff ptr (sizeOf (undefined :: CLLong)) (jTypeToInt JChar)
pokeByteOff ptr (2 * sizeOf (undefined :: CLLong)) len'
pokeByteOff ptr (3 * sizeOf (undefined :: CLLong)) (1 :: CLLong)
pokeByteOff ptr (4 * sizeOf (undefined :: CLLong)) len'
let dataOff = 5 * sizeOf (undefined :: CLLong)
BS.useAsCString bs $ \pSrc ->
copyArray (ptr `plusPtr` dataOff) pSrc len
pure (fromIntegral wid, ptr)
repaSize :: (R.Source r e, R.Shape sh) => R.Array r sh e -> (CLLong, [CLLong])
repaSize arr = let sh = R.extent arr in (fromIntegral $ R.rank sh, fromIntegral <$> R.listOfShape sh)
data JType = JBool
| JChar
| JInteger
| JDouble
intToJType :: CLLong -> JType
intToJType 1 = JBool
intToJType 2 = JChar
intToJType 4 = JInteger
intToJType 8 = JDouble
intToJType _ = error "Unsupported type!"
jTypeToInt :: JType -> CLLong
jTypeToInt JBool = 1
jTypeToInt JChar = 2
jTypeToInt JInteger = 4
jTypeToInt JDouble = 8
jData :: R.Shape sh => JAtom -> JData sh
jData (JAtom JInteger sh fp) = JIntArr $ RF.fromForeignPtr (R.shapeOfList $ fmap fromIntegral sh) (castForeignPtr fp)
jData (JAtom JDouble sh fp) = JDoubleArr $ RF.fromForeignPtr (R.shapeOfList $ fmap fromIntegral sh) (castForeignPtr fp)
jData (JAtom JBool sh fp) = JBoolArr $ RF.fromForeignPtr (R.shapeOfList $ fmap fromIntegral sh) (castForeignPtr fp)
jData (JAtom JChar [l] fp) = JString $ BS.fromForeignPtr (castForeignPtr fp) 0 (fromIntegral l)
jData (JAtom JChar _ _) = error "Not supported."