j (empty) → 0.1.0.0
raw patch · 6 files changed
+457/−0 lines, 6 filesdep +basedep +bytestringdep +j
Dependencies added: base, bytestring, j, repa, semigroups, tasty, tasty-hunit, unix
Files
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- README.md +8/−0
- j.cabal +76/−0
- src/Language/J.hs +275/−0
- test/Spec.hs +82/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# j++## 0.1.0.0++Initial release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright Vanessa McHale (c) 2020++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,8 @@+# j-hs++[](http://hackage.haskell.org/package/j)+[](https://hackage.haskell.org/package/j)++Call [J](https://www.jsoftware.com) from Haskell.++Features a [repa](https://hackage.haskell.org/package/repa) interface.
+ j.cabal view
@@ -0,0 +1,76 @@+cabal-version: 1.18+name: j+version: 0.1.0.0+license: BSD3+license-file: LICENSE+copyright: Copyright: (c) 2020 Vanessa McHale+maintainer: vamchale@gmail.com+author: Vanessa McHale+synopsis: J in Haskell+description: Haskell library for calling J+category: Interpreters, FFI, Array, J+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/vmchale/j-hs++library+ exposed-modules: Language.J+ hs-source-dirs: src+ default-language: Haskell2010+ other-extensions: FlexibleContexts OverloadedStrings CPP+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5,+ unix -any,+ bytestring -any,+ repa -any++ if !impl(ghc >=8.0)+ build-depends: semigroups -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++test-suite j-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: "-with-rtsopts -K1K" -Wall+ build-depends:+ base -any,+ j -any,+ tasty -any,+ tasty-hunit -any,+ repa -any,+ bytestring -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages
+ src/Language/J.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Marshal a limited subset of J arrays into Repa arrays.+--+-- = Tutorial+--+-- Suppose we wish to perform linear regression. In J we could do:+--+-- @+-- xs := 1 2 3+-- ys := 2 4 6+--+-- reg_result =: ys %. xs ^/ i.2+-- @+--+-- To do this with Haskell data:+--+-- @+-- do+-- jenv <- 'jinit' 'libLinux'+--+-- let hsArr0 = R.fromListUnboxed (R.ix1 3) [1.0,2.0,3.0]+-- hsArr1 = R.fromListUnboxed (R.ix1 3) [2.0,4.0,6.0]+-- jArr0 = 'JDoubleArr' $ R.copyS $ R.map (realToFrac :: Double -> CDouble) hsArr0+-- jArr1 = 'JDoubleArr' $ R.copyS $ R.map (realToFrac :: Double -> CDouble) hsArr1+--+-- 'setJData' jenv "xs" jArr0+-- 'setJData' jenv "ys" jArr1+--+-- 'bsDispatch' jenv "reg_result =: ys %. xs ^/ i.2"+--+-- 'JDoubleArr' res <- 'getJData' jenv "reg_result"+-- R.toList res+-- @+--+-- There are three steps to do the calculation, plus one to get a J environment.+--+-- (1) Use 'jinit' with the appropriate file path for your platform+--+-- 2. Marshal Haskell values and send them to the J environment. To do so, we+-- use 'setJData', which takes a 'JData' containing a repa array or+-- a string.+--+-- 3. Perform calculations within the J environment. Here, we use+-- 'bsDispatch' to compute some results and assign them within J+--+-- 4. Marshal J values back to Haskell. We use 'getJData' again.+--+--+-- Since marshaling data between J and Haskell is expensive, it's best to do as+-- much computation as possible in J.+--+-- = FFI+--+-- If you want to marshal data yourself, say to use a @Vector@, look at 'JEnv'.+module Language.J ( -- * Environment+ JEnv (..)+ , jinit+ , libLinux+ , libMac+ , bsDispatch+ , bsOut+ , JVersion+ -- * Repa+ , JData (..)+ , getJData+ , setJData+ -- * FFI+ , 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, plusPtr)+import Foreign.Storable (Storable, peek, pokeByteOff, sizeOf)+import System.Posix.ByteString (RTLDFlags (RTLD_LAZY), RawFilePath, dlopen, dlsym)++-- Upstream reference+-- https://github.com/jsoftware/stats_jserver4r/blob/4c94fc6df351fab34791aa9d78d158eaefd33b17/source/lib/j2r.c+-- https://github.com/jsoftware/stats_jserver4r/blob/4c94fc6df351fab34791aa9d78d158eaefd33b17/source/lib/r2j.c++-- | Abstract context+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++-- | Expected 'RawFilePath' to the library on a Linux machine.+libLinux :: RawFilePath+libLinux = "/usr/lib/x86_64-linux-gnu/libj.so"++type JVersion = [Int]++-- | Expected 'RawFilePath' to the library on Mac.+libMac :: JVersion -> RawFilePath+libMac v = "/Applications/j64-" <> ASCII.pack (concatMap show v) <> "/bin/libj.dylib"++-- process address++-- | Get a J environment+--+-- Passing the resultant 'JEnv' between threads can cause unexpected bugs.+jinit :: RawFilePath -- ^ Path to J library+ -> 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++-- | Send some J code to the environment.+bsDispatch :: JEnv -> BS.ByteString -> IO ()+bsDispatch (JEnv ctx jdo _ _ _) bs =+ void $ BS.useAsCString bs $ jdo ctx++-- | Read last output+--+-- For debugging+bsOut :: JEnv -> IO BS.ByteString+bsOut (JEnv ctx _ _ jout _) = BS.packCString =<< jout ctx++-- | \( O(n) \) in the array size+getJData :: R.Shape sh+ => JEnv -> BS.ByteString -- ^ Name of the value in question+ -> IO (JData sh)+getJData jenv bs = jData <$> getAtomInternal jenv bs++getAtomInternal :: JEnv -> BS.ByteString -- ^ Name of the value in question+ -> 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)++-- | J data backed by repa array+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++-- | \( O(n) \) in the array size+setJData :: (R.Shape sh) => JEnv -> BS.ByteString -- ^ Name+ -> 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++-- | Return a @'Ptr' ()@ suitable to be passed to @JSetA@+--+-- To be used on integer and double arrays+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) -- I think this is because it's non-boxed+ 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)++-- | J types+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."
+ test/Spec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++module Main ( main ) where++import Control.Applicative ((<$>))+import qualified Data.Array.Repa as R+import qualified Data.ByteString as BS+import Foreign.C.Types (CDouble, CInt)+import Language.J+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = do+ jenv <- jinit libLinux+ defaultMain $+ testGroup "J dl"+ [ testCase "Performs calculation and has sensible output" (jComp jenv)+ , testCase "Reads back type in the environment" (jType jenv)+ , testCase "Reads a string" (jStr jenv)+ , testCase "Sends an array to J" (jSetA jenv)+ , testCase "Uses J to perform a complex calculation" (regress jenv)+ , testCase "Writes strigns to J values" (stringRoundtrip jenv)+ ]++regress :: JEnv -> Assertion+regress jenv = do+ let hsArr0 = R.fromListUnboxed (R.ix1 3) [1.0,2.0,3.0]+ hsArr1 = R.fromListUnboxed (R.ix1 3) [2.0,4.0,6.0]+ setJData jenv "xs" (JDoubleArr $ R.copyS $ R.map (realToFrac :: Double -> CDouble) hsArr0)+ setJData jenv "ys" (JDoubleArr $ R.copyS $ R.map (realToFrac :: Double -> CDouble) hsArr1)+ bsDispatch jenv "reg_result =: ys %. xs ^/ i.2"+ res <- getJData jenv "reg_result"+ doubleVect res @?= [5.995204332975845e-15,1.9999999999999971]++stringRoundtrip :: JEnv -> Assertion+stringRoundtrip jenv = do+ setJData jenv "stringy_string" (JString "hello" :: JData R.Z)+ res <- unwrapStr <$> getJData jenv "stringy_string"+ res @?= "hello"++jSetA :: JEnv -> Assertion+jSetA jenv = do+ let hsArr = R.fromListUnboxed (R.ix1 3) [1,3,6]+ setJData jenv "b" (JIntArr $ R.copyS $ R.map (fromIntegral :: Int -> CInt) hsArr)+ res <- getJData jenv "b"+ intList res @?= [1,3,6]++jStr :: JEnv -> Assertion+jStr jenv = do+ bsDispatch jenv "str =: 'hello'"+ res <- getJData jenv "str"+ unwrapStr res @?= "hello"++jComp :: JEnv -> Assertion+jComp jenv = do+ bsDispatch jenv "harmonic =: (+/ % #) &.: %"+ bsDispatch jenv "c =: harmonic 1 3 6"+ res <- getJData jenv "c"+ doubleScalar res @?= [2.0]++unwrapStr :: JData R.Z -> BS.ByteString+unwrapStr (JString bs) = bs+unwrapStr _ = error "Test suite error."++doubleVect :: JData R.DIM1 -> [CDouble]+doubleVect (JDoubleArr arr) = R.toList arr+doubleVect _ = error "Test suite failure!"++doubleScalar :: JData R.Z -> [CDouble]+doubleScalar (JDoubleArr arr) = R.toList arr+doubleScalar _ = error "Test suite failure!"++intList :: JData R.DIM1 -> [CInt]+intList (JIntArr arr) = R.toList arr+intList _ = error "Test suite failure!"++jType :: JEnv -> Assertion+jType jenv = do+ bsDispatch jenv "a =: 6?6"+ res <- getJData jenv "a"+ length (intList res) @?= 6