├── src ├── hsmatlab.m ├── hsc_sym.h ├── libhsmatlab.exports ├── hsmatlab.c ├── Makefile ├── Makefile.in ├── libhsmatlab.h ├── readme.txt └── libhsmatlab.c ├── test ├── mtest.m ├── mcellTest.m ├── makeTestStruct.m ├── useTestStruct.m ├── Spec.hs ├── SpecEngine.hs ├── makeTestStructByteStream.m ├── hsmli.hs ├── generic.hs ├── runtime.hs ├── Makefile ├── Makefile.in └── Test │ ├── UtilTemplate.hs │ ├── Util.hs │ └── Engine.hs ├── .gitignore ├── runHSMat.sh ├── hello └── SpecHello.hs ├── stack.yaml.lock ├── Foreign ├── Matlab.hs └── Matlab │ ├── Array │ ├── Auto.hs │ ├── MArray.hs │ ├── Able.hs │ └── IMX.hs │ ├── Optics.hsc │ ├── Util.hs │ ├── Engine │ └── Wrappers.hs │ ├── Runtime │ └── Generic.hs │ ├── MAT.hsc │ ├── Engine.hsc │ ├── Types.hs │ ├── Runtime.hsc │ ├── Internal.hsc │ └── Array.hsc ├── shell.nix ├── attic └── Array_interpreter.hs ├── deps.nix ├── LICENSE ├── patchMATLAB.sh ├── Setup.hs ├── stack.yaml ├── README.md └── matlab.cabal /src/hsmatlab.m: -------------------------------------------------------------------------------- 1 | function hsmatlab 2 | -------------------------------------------------------------------------------- /test/mtest.m: -------------------------------------------------------------------------------- 1 | function y = mtest(x) 2 | y = cos(x); 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | patchMatlab.lock 3 | 4 | # Editor files 5 | *~ 6 | -------------------------------------------------------------------------------- /test/mcellTest.m: -------------------------------------------------------------------------------- 1 | function y = mcellTest(x) 2 | y = {'ads', '123', 4; 7 8 9}; 3 | -------------------------------------------------------------------------------- /src/hsc_sym.h: -------------------------------------------------------------------------------- 1 | #define hsc_SYM2(X) hsc_const_str(#X) 2 | #define hsc_SYM(X) hsc_SYM2(X) 3 | -------------------------------------------------------------------------------- /test/makeTestStruct.m: -------------------------------------------------------------------------------- 1 | function sOut = makeTestStruct() 2 | sOut = struct('x', 2, 'y', 5); 3 | end 4 | -------------------------------------------------------------------------------- /test/useTestStruct.m: -------------------------------------------------------------------------------- 1 | function sumOut = useTestStruct(sIn) 2 | sumOut = sIn.x + sIn.y; 3 | end 4 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Engine (engineTests) 4 | 5 | main :: IO () 6 | main = engineTests 7 | 8 | -------------------------------------------------------------------------------- /test/SpecEngine.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Engine (engineTests) 4 | 5 | main :: IO () 6 | main = engineTests 7 | 8 | -------------------------------------------------------------------------------- /src/libhsmatlab.exports: -------------------------------------------------------------------------------- 1 | libhsmatlabInitialize 2 | libhsmatlabInitializeWithHandlers 3 | libhsmatlabTerminate 4 | libhsmatlabPrintStackTrace 5 | 6 | -------------------------------------------------------------------------------- /test/makeTestStructByteStream.m: -------------------------------------------------------------------------------- 1 | function sOutBS = makeTestStructByteStream() 2 | sOut = makeTestStruct(); 3 | sOutBS = getByteStreamFromArray(sOut); 4 | end 5 | -------------------------------------------------------------------------------- /runHSMat.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | export PATH=$HOME/.local/bin:$MATLAB_PATH/bin:$PATH 4 | 5 | LD_LIBRARY_PATH=$MATLAB_PATH/bin/glnxa64:$MATLAB_PATH/sys/os/glnxa64:$LD_LIBRARY_PATH "$@" 6 | -------------------------------------------------------------------------------- /hello/SpecHello.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | -- This is mainly here to help in differential diagnosis, 4 | -- as it is a Haskell program that does not touch MATLAB 5 | 6 | main :: IO () 7 | main = putStrLn "Hello, world!" 8 | 9 | -------------------------------------------------------------------------------- /src/hsmatlab.c: -------------------------------------------------------------------------------- 1 | /* a thin wrapper to add to the library to allow for arbitrary function calls */ 2 | LIB_libhsmatlab_C_API 3 | bool MW_CALL_CONV mlHsFeval(const char *fun, int nlhs, mxArray *plhs[], int nrhs, mxArray *prhs[]) 4 | { 5 | return mclFeval(_mcr_inst, fun, nlhs, plhs, nrhs, prhs); 6 | } 7 | -------------------------------------------------------------------------------- /test/hsmli.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Foreign.Matlab 3 | import Foreign.Matlab.Runtime.Generic 4 | 5 | loop ml = do 6 | i <- getLine 7 | when (i /= "") $ do 8 | mlGenericEval ml i 0 9 | loop ml 10 | 11 | main = do 12 | ml <- openMLGeneric ["-nojvm", "-nojit"] 13 | putStrLn "ready. enter matlab expression or blank line to exit." 14 | loop ml 15 | closeMLGeneric ml 16 | -------------------------------------------------------------------------------- /test/generic.hs: -------------------------------------------------------------------------------- 1 | import Foreign.Matlab 2 | import Foreign.Matlab.Runtime.Generic 3 | 4 | main = do 5 | ml <- openMLGeneric ["-nojvm", "-nojit"] 6 | putStrLn "ready" 7 | x <- createMXScalar (pi :: MDouble) 8 | [y] <- mlGenericFun ml "cos" [anyMXArray x] 1 9 | mxArrayClass y >>= print 10 | Just y <- castMXArray y 11 | y <- mxScalarGet y 12 | print (y :: MDouble) 13 | closeMLGeneric ml 14 | -------------------------------------------------------------------------------- /test/runtime.hs: -------------------------------------------------------------------------------- 1 | import Foreign.Matlab 2 | import Foreign.Matlab.Runtime 3 | 4 | main = do 5 | ml <- openMLibrary "./mtest" ["-nojvm", "-nojit"] 6 | putStrLn "ready" 7 | x <- createMXScalar (pi :: MDouble) 8 | [y] <- mLibraryCall ml "mtest" [anyMXArray x] 1 9 | mxArrayClass y >>= print 10 | Just y <- castMXArray y 11 | y <- mxScalarGet y 12 | print (y :: MDouble) 13 | closeMLibrary ml 14 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 524996 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml 11 | sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 12 | original: lts-14.27 13 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | MCC=mcc 2 | MCCFLAGS= 3 | 4 | TESTS=engine runtime generic 5 | default: $(TESTS) 6 | @echo "All tests should have produced:" 7 | @echo " ready" 8 | @echo " MXClassDouble" 9 | @echo " -1.0" 10 | @for t in $^ ; do echo Running $$t... ; ./$$t ; done 11 | 12 | %: %.hs 13 | ghc -I.. --make $@ 14 | 15 | lib%.so: %.m 16 | $(MCC) $(MCCFLAGS) -W lib:$(basename $@) -T link:lib $^ 17 | 18 | runtime: libmtest.so 19 | 20 | clean: 21 | rm -rf libmtest_mcr 22 | rm -f *.o *.hi $(TESTS) libmtest* mccExcludedFiles.log readme.txt 23 | -------------------------------------------------------------------------------- /test/Makefile.in: -------------------------------------------------------------------------------- 1 | MCC=@MATLAB_MCC@ 2 | MCCFLAGS=@MCCFLAGS@ 3 | 4 | TESTS=engine runtime generic 5 | default: $(TESTS) 6 | @echo "All tests should have produced:" 7 | @echo " ready" 8 | @echo " MXClassDouble" 9 | @echo " -1.0" 10 | @for t in $^ ; do echo Running $$t... ; ./$$t ; done 11 | 12 | %: %.hs 13 | ghc -I.. --make $@ 14 | 15 | lib%.so: %.m 16 | $(MCC) $(MCCFLAGS) -W lib:$(basename $@) -T link:lib $^ 17 | 18 | runtime: libmtest.so 19 | 20 | clean: 21 | rm -rf libmtest_mcr 22 | rm -f *.o *.hi $(TESTS) libmtest* mccExcludedFiles.log readme.txt 23 | -------------------------------------------------------------------------------- /Foreign/Matlab.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | {-| 4 | Bundles Matlab data structure and general-purpose routines. 5 | -} 6 | 7 | module Foreign.Matlab 8 | ( module Foreign.Matlab.Types 9 | , module Foreign.Matlab.Array 10 | , module Foreign.Matlab.Array.Auto 11 | --, module Foreign.Matlab.Array.MArray 12 | , module Foreign.Matlab.Array.IMX 13 | , module Foreign.Matlab.Array.Able 14 | , module Foreign.Matlab.MAT 15 | ) where 16 | 17 | import Foreign.Matlab.Types 18 | import Foreign.Matlab.Array 19 | import Foreign.Matlab.Array.Auto 20 | --import Foreign.Matlab.Array.MArray 21 | import Foreign.Matlab.Array.IMX 22 | import Foreign.Matlab.Array.Able 23 | import Foreign.Matlab.MAT 24 | -------------------------------------------------------------------------------- /test/Test/UtilTemplate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.UtilTemplate where 4 | 5 | import Control.Monad.Catch (MonadThrow) 6 | import Control.Monad.IO.Class 7 | import qualified Control.Exception as E 8 | import qualified Data.Text as Txt 9 | import Language.Haskell.TH (Exp, Q, runIO) 10 | import Path 11 | import System.Environment 12 | 13 | getRepoDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) 14 | getRepoDir = do 15 | testExePath <- liftIO $ getEnv "PWD" 16 | repoPath <- pure $ parseAbsDir $ Txt.unpack $ fst $ Txt.breakOn 17 | (Txt.pack "FarmDataServer/.stack-work") (Txt.pack testExePath) 18 | repoPath 19 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | # 2 | # TODO: consider using a shell-specific version of pathdef.m 3 | # TODO: instead of relying on a default in Documents/MATLAB 4 | # 5 | 6 | with import {}; 7 | let 8 | deps = (import ./deps.nix); 9 | in 10 | haskell.lib.buildStackProject { 11 | name = "impureMatlabEnv"; 12 | dontUnpack = true; 13 | buildInputs = deps.buildInputs; 14 | libPath = deps.libPath; 15 | src = null; 16 | shellHook = '' 17 | export MATLAB_PATH=${deps.matlabPath} 18 | export PATH=$PATH:$MATLAB_PATH/bin 19 | 20 | source ${./patchMATLAB.sh} 21 | 22 | ''; 23 | } 24 | 25 | # Note this will break nix commands inside the shell: 26 | # export LD_LIBRARY_PATH=$MATLAB_PATH/bin/glnxa64:$MATLAB_PATH/sys/os/glnxa64:$LD_LIBRARY_PATH 27 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | MCC=mcc 2 | MCCFLAGS= 3 | 4 | libhsmatlab.so: hsmatlab.m hsmatlab.c 5 | rm -f $@ $@.post 6 | # just create the wrapper 7 | $(MCC) $(MCCFLAGS) -W lib:$(basename $@) -c hsmatlab.m 8 | # matlab 7.6 sticks the ctf at the end of the library, but has a bug when not creating libraries that it tries anyway, so we check that here 9 | -[ -f $@ ] && mv $@ $@.post 10 | # stick our own call into the wrapper 11 | cat hsmatlab.c >> $(basename $@).c 12 | # build the library 13 | $(MCC) $(MCCFLAGS) -W lib:$(basename $@) -T link:lib $(basename $@).c 14 | # 7.6: do what mcc tried to do before 15 | -[ -f $@.post ] && cat $(basename $@).ctf >> $@ 16 | 17 | clean: 18 | rm -rf libhsmatlab_mcr 19 | rm -f libhsmatlab* mccExcludedFiles.log readme.txt 20 | -------------------------------------------------------------------------------- /src/Makefile.in: -------------------------------------------------------------------------------- 1 | MCC=@MATLAB_MCC@ 2 | MCCFLAGS=@MCCFLAGS@ 3 | 4 | libhsmatlab.so: hsmatlab.m hsmatlab.c 5 | rm -f $@ $@.post 6 | # just create the wrapper 7 | $(MCC) $(MCCFLAGS) -W lib:$(basename $@) -c hsmatlab.m 8 | # matlab 7.6 sticks the ctf at the end of the library, but has a bug when not creating libraries that it tries anyway, so we check that here 9 | -[ -f $@ ] && mv $@ $@.post 10 | # stick our own call into the wrapper 11 | cat hsmatlab.c >> $(basename $@).c 12 | # build the library 13 | $(MCC) $(MCCFLAGS) -W lib:$(basename $@) -T link:lib $(basename $@).c 14 | # 7.6: do what mcc tried to do before 15 | -[ -f $@.post ] && cat $(basename $@).ctf >> $@ 16 | 17 | clean: 18 | rm -rf libhsmatlab_mcr 19 | rm -f libhsmatlab* mccExcludedFiles.log readme.txt 20 | -------------------------------------------------------------------------------- /attic/Array_interpreter.hs: -------------------------------------------------------------------------------- 1 | data StructPath = 2 | SField String 3 | | SIx MIndex 4 | -- | SList [SField] -- Consider this for later, would require merging and likely runtime errors 5 | 6 | data StructTerm = 7 | 8 | -- | Convenience tool to automate extraction of MATLAB datastructures. 9 | mxGetPath :: (MXArrayComponent a, MXArrayComponent b) 10 | => [StructPath] -> MXArray a -> MIO (Either String (MXArray b)) 11 | mxGetPath pathCur:pathRest arr = do 12 | mxGetPath pathCur:[] arr = do 13 | 14 | -- TODO - how to dwe deal with the type of non-MXArray vs MXArray in retrievals? 15 | -- TODO: maye a new class that includes both options? 16 | 17 | mxGetPathPart :: (MXArrayComponent a) => StructPath -> MXArray a -> MIO (Either String MAnyArray) 18 | mxGetPathPart (SField field) arr = do 19 | mxGetPathPart (SIx ix) arr = do 20 | -------------------------------------------------------------------------------- /deps.nix: -------------------------------------------------------------------------------- 1 | with import {}; 2 | let 3 | matlabGcc = gcc49; 4 | matlabVersion = "R2017a"; 5 | matlabPath = "/opt/MATLAB/${matlabVersion}"; 6 | matlabLibPath = "${matlabPath}/bin/glnxa64"; 7 | in 8 | stdenv.mkDerivation { 9 | name = "impureMatlabEnvDeps"; 10 | matlabPath = matlabPath; 11 | inherit matlabGcc; 12 | inherit ghc; 13 | dontUnpack = true; 14 | buildInputs = [ 15 | matlabGcc 16 | makeWrapper 17 | zlib 18 | # for Haskell: 19 | gmp 20 | stack 21 | ]; 22 | 23 | libPath = stdenv.lib.makeLibraryPath [ 24 | gmp 25 | mesa_glu 26 | ncurses 27 | pam 28 | xorg.libxcb 29 | xorg.libXi 30 | xorg.libXext 31 | xorg.libXmu 32 | xorg.libXp 33 | xorg.libXpm 34 | xorg.libXrandr 35 | xorg.libXrender 36 | xorg.libXt 37 | xorg.libXtst 38 | xorg.libXxf86vm 39 | xorg.libX11 40 | zlib 41 | ]; 42 | src = null; 43 | } 44 | -------------------------------------------------------------------------------- /Foreign/Matlab/Array/Auto.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 'MXArray' 'ForeignPtr' wrapper. 3 | 4 | A 'MXArray' that is automatically freed. These arrays must never be put inside other arrays or used as function results. 5 | -} 6 | module Foreign.Matlab.Array.Auto ( 7 | MXAuto, 8 | mxAuto, 9 | withMXAuto, 10 | MAnyAuto 11 | ) where 12 | 13 | import Foreign 14 | import Foreign.Matlab.Util 15 | import Foreign.Matlab.Internal 16 | 17 | -- |A 'MXArray' that is automatically freed with 'Foreign.Matlab.Array.freeMXArray' 18 | newtype MXAuto a = MXAuto (ForeignPtr MXArrayType) 19 | 20 | foreign import ccall unsafe "&mxDestroyArray" mxDestroyArray_ptr :: FunPtr (MXArrayPtr -> IO ()) 21 | 22 | -- |Turn an 'MXArray' into an 'MXAuto'. The original 'MXArray' should not be used after this operation. 23 | mxAuto :: MXArray a -> MIO (MXAuto a) 24 | mxAuto (MXArray a) 25 | | a == nullPtr = MXAuto =.< newForeignPtr_ a 26 | | otherwise = MXAuto =.< newForeignPtr mxDestroyArray_ptr a 27 | 28 | -- |Use a 'MXAuto' 29 | withMXAuto :: MXAuto a -> (MXArray a -> IO b) -> IO b 30 | withMXAuto (MXAuto a) f = withForeignPtr a (f . MXArray) 31 | 32 | type MAnyAuto = MXAuto MAny 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) [2008..2015] Dylan Simon, Ben Sherman. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | * Redistributions of source code must retain the above copyright 6 | notice, this list of conditions and the following disclaimer. 7 | * Redistributions in binary form must reproduce the above copyright 8 | notice, this list of conditions and the following disclaimer in the 9 | documentation and/or other materials provided with the distribution. 10 | * Neither the names of the contributors nor of their affiliations may 11 | be used to endorse or promote products derived from this software 12 | without specific prior written permission. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY 15 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 21 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /Foreign/Matlab/Optics.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | -- | A few Optics definitions used by this project. These definitions are either 5 | -- | copied or copmatible with those from the `lens` package. 6 | module Foreign.Matlab.Optics where 7 | 8 | import Data.Coerce (Coercible, coerce) 9 | import Data.Profunctor 10 | import Data.Profunctor.Unsafe ((.#)) 11 | 12 | type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t 13 | 14 | type Lens' s a = Lens s s a a 15 | 16 | 17 | -- | Build a 'Lens' from a getter and a setter. 18 | -- 19 | -- @ 20 | -- 'lens' :: 'Functor' f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t 21 | -- @ 22 | -- 23 | -- >>> s ^. lens getter setter 24 | -- getter s 25 | -- 26 | -- >>> s & lens getter setter .~ b 27 | -- setter s b 28 | -- 29 | -- >>> s & lens getter setter %~ f 30 | -- setter s (f (getter s)) 31 | -- 32 | -- @ 33 | -- 'lens' :: (s -> a) -> (s -> a -> s) -> 'Lens'' s a 34 | -- @ 35 | lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b 36 | lens sa sbt afb s = sbt s <$> afb (sa s) 37 | {-# INLINE lens #-} 38 | 39 | type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) 40 | type Iso' s a = Iso s s a a 41 | 42 | coerce' :: forall a b. Coercible a b => b -> a 43 | coerce' = coerce (id :: a -> a) 44 | {-# INLINE coerce' #-} 45 | 46 | coerced :: forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b 47 | # if __GLASGOW_HASKELL__ >= 710 48 | coerced l = rmap (fmap coerce') l .# coerce 49 | # else 50 | coerced l = case sym Coercion :: Coercion a s of 51 | Coercion -> rmap (fmap coerce') l .# coerce 52 | # endif 53 | 54 | -------------------------------------------------------------------------------- /Foreign/Matlab/Array/MArray.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Safe MArray interface to "Foreign.Matlab.Array". 3 | 4 | An instance of 'Data.Array.MArray.MArray' for 'MXArray'. Although array access can be done through this instance, arrays themselves must be created using 'mxMArray' along with one of the "Foreign.Matlab.Array" create functions. 5 | -} 6 | module Foreign.Matlab.Array.MArray ( 7 | MMXArray, mxMArray, unMmxArray 8 | ) where 9 | 10 | import qualified Data.Ix as Ix 11 | import qualified Data.Array.Base as DA 12 | import qualified Unsafe.Coerce 13 | import Foreign.Matlab.Util 14 | import Foreign.Matlab.Types 15 | import Foreign.Matlab.Array 16 | 17 | -- |A wrapper for 'MXArray' to allow for a 'Data.Array.MArray.MArray' instance. All instances of this type will have 'MIndex' as @i@ 18 | newtype MMXArray i e = MMXArray { mmxArray :: MXArray e } 19 | 20 | -- |Get an 'Data.Array.MArray.MArray' instance for an 'MXArray'. The resulting object is just a different interface to the same underlying array. 21 | mxMArray :: MXArrayComponent a => MXArray a -> MMXArray MIndex a 22 | mxMArray = MMXArray 23 | -- |Get a 'MXArray' back from its 'Data.Array.MArray.MArray' instance 24 | unMmxArray :: MXArrayComponent a => MMXArray MIndex a -> MXArray a 25 | unMmxArray = mmxArray 26 | 27 | mix :: Ix.Ix a => MIndex -> a 28 | mix x = Unsafe.Coerce.unsafeCoerce x 29 | mir :: Ix.Ix a => (MIndex,MIndex) -> (a,a) 30 | mir (x,y) = (mix x,mix y) 31 | 32 | instance MXArrayComponent e => DA.MArray MMXArray e IO where 33 | getBounds = mir . mSizeRange .=< mxArraySize . mmxArray 34 | getNumElements = mxArrayLength . mmxArray 35 | newArray_ _ = fail "MMXArray.newArray_: use MXArrayI . createMXArray" 36 | unsafeRead = mxArrayGetOffset . mmxArray 37 | unsafeWrite = mxArraySetOffset . mmxArray 38 | 39 | -------------------------------------------------------------------------------- /patchMATLAB.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Based on https://github.com/jdreaver/NixOS-matlab/blob/master/builder.sh 4 | # 5 | 6 | PATCH_MATLAB_LOCK_FILE=patchMatlab.lock 7 | 8 | if [ ! -f "$PATCH_MATLAB_LOCK_FILE" ]; then 9 | PATCH_FILES=( 10 | $MATLAB_PATH/bin/glnxa64/MATLAB 11 | $MATLAB_PATH/bin/glnxa64/matlab_helper 12 | $MATLAB_PATH/bin/glnxa64/mbuildHelp 13 | $MATLAB_PATH/bin/glnxa64/mex 14 | $MATLAB_PATH/bin/glnxa64/need_softwareopengl 15 | $MATLAB_PATH/sys/java/jre/glnxa64/jre/bin/java 16 | ) 17 | 18 | echo "Patching java... ($MATLAB_PATH/sys/java/jre/glnxa64/jre/bin/java)" 19 | chmod u+rw "$MATLAB_PATH/sys/java/jre/glnxa64/jre/bin/java" 20 | patchelf --interpreter "$(cat $NIX_CC/nix-support/dynamic-linker)" \ 21 | --set-rpath "$libPath:$(patchelf --print-rpath $MATLAB_PATH/sys/java/jre/glnxa64/jre/bin/java)"\ 22 | --force-rpath "$MATLAB_PATH/sys/java/jre/glnxa64/jre/bin/java" 23 | 24 | echo "Patching MATLAB executables..." 25 | for f in ${PATCH_FILES[*]}; do 26 | chmod u+rw $f 27 | patchelf --interpreter "$(cat $NIX_CC/nix-support/dynamic-linker)" \ 28 | --set-rpath "$libPath:$(patchelf --print-rpath $f)"\ 29 | --force-rpath $f 30 | done 31 | 32 | SO_FILES=$(ls -1 $MATLAB_PATH/bin/glnxa64/*.so) 33 | for f in ${SO_FILES[*]}; do 34 | chmod u+rw $f 35 | patchelf --set-rpath "$libPath:$(patchelf --print-rpath $f)"\ 36 | --force-rpath $f 37 | done 38 | 39 | # Set the correct path to gcc 40 | CC_FILES=( 41 | $MATLAB_PATH/bin/mbuildopts.sh 42 | $MATLAB_PATH/bin/mexopts.sh 43 | ) 44 | 45 | for f in ${CC_FILES[*]}; do 46 | chmod u+rw $f 47 | substituteInPlace $f\ 48 | --replace "CC='gcc'" "CC='${matlabGcc}/bin/gcc'" 49 | done 50 | 51 | touch "$PATCH_MATLAB_LOCK_FILE" 52 | fi 53 | -------------------------------------------------------------------------------- /Foreign/Matlab/Util.hs: -------------------------------------------------------------------------------- 1 | module Foreign.Matlab.Util where 2 | 3 | import Control.Monad 4 | import Foreign 5 | 6 | infixl 1 >., >.=, >=. 7 | infixr 1 =.<, .=< 8 | (>.) :: Monad m => m a -> b -> m b 9 | (>.=) :: Monad m => m a -> (a -> b) -> m b 10 | (=.<) :: Monad m => (a -> b) -> m a -> m b 11 | (>=.) :: Monad m => (a -> m b) -> (b -> c) -> a -> m c 12 | (.=<) :: Monad m => (b -> c) -> (a -> m b) -> a -> m c 13 | 14 | (>.) e r = e >> return r 15 | (>.=) e r = e >>= return . r 16 | (=.<) r e = return . r =<< e 17 | (>=.) e r = e >=> return . r 18 | (.=<) r e = return . r <=< e 19 | 20 | ii :: (Integral a, Integral b) => a -> b 21 | ii = fromIntegral 22 | 23 | type With x y a = x -> (y -> a) -> a 24 | 25 | mapWith :: With x y a -> With [x] [y] a 26 | mapWith w l f = m l id where 27 | m [] s = f (s []) 28 | m (x:l) s = w x (\y -> m l (s.(y:))) 29 | 30 | mapWith' :: With x y a -> With [x] [y] a 31 | mapWith' w = m where 32 | m [] e = e [] 33 | m (x:l) e = m l (\s -> w x (\y -> e (y:s))) 34 | 35 | mapWithRev :: With x y a -> With [x] [y] a 36 | mapWithRev w l f = m l [] where 37 | m [] s = f s 38 | m (x:l) s = w x (\y -> m l (y:s)) 39 | 40 | mapWithArray :: Storable y => With x y (IO a) -> With [x] (Ptr y) (IO a) 41 | mapWithArray w l f = mapWithArrayLen w l (\(p,_) -> f p) 42 | 43 | mapWithArrayLen :: Storable y => With x y (IO a) -> With [x] (Ptr y, Int) (IO a) 44 | --mapWithArrayLen w l f = mapWith w l (\l -> withArrayLen l (curry f)) 45 | mapWithArrayLen w l f = 46 | allocaArray (length l) $ \p -> 47 | let 48 | set [] i = f (p,i) 49 | set (x:l) i = w x $ \y -> pokeElemOff p i y >> set l (succ i) 50 | in set l 0 51 | 52 | segment :: Int -> [a] -> [[a]] 53 | segment _ [] = [] 54 | segment n l = a : segment n r where (a,r) = splitAt n l 55 | 56 | replaceIndex :: [a] -> Int -> a -> [a] 57 | replaceIndex [] _ _ = error "replaceIndex: index too large" 58 | replaceIndex (_:l) 0 y = y:l 59 | replaceIndex (x:l) n y = x : replaceIndex l (pred n) y 60 | -------------------------------------------------------------------------------- /Foreign/Matlab/Array/Able.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Direct conversion between Haskell data structures and 'IMXData'. 3 | 4 | In general, scalars convert to the obvious, and lists to row vectors. 5 | -} 6 | module Foreign.Matlab.Array.Able ( 7 | Matlabable (toMatlab, fromMatlab), 8 | withMatlabArray, fromMatlabArray 9 | ) where 10 | 11 | import Foreign.Matlab.Util 12 | import Foreign.Matlab.Types 13 | import Foreign.Matlab.Array.IMX 14 | 15 | class Matlabable a where 16 | toMatlab :: a -> IMXData 17 | fromMatlab :: IMXData -> Maybe a 18 | 19 | --instance (MScalar a, IMXArrayElem a) => Matlabable a where { toMatlab = scalarIMX ; fromMatlab = imxScalar } 20 | instance Matlabable Bool where { toMatlab = scalarIMX ; fromMatlab = imxScalar } 21 | instance Matlabable Char where { toMatlab = scalarIMX ; fromMatlab = imxScalar } 22 | instance Matlabable Float where { toMatlab = scalarIMX ; fromMatlab = imxScalar } 23 | instance Matlabable Double where { toMatlab = scalarIMX ; fromMatlab = imxScalar } 24 | 25 | instance Matlabable Int where 26 | toMatlab = scalarIMX . (ii :: Int -> MInt32) 27 | fromMatlab = fmap (ii :: MInt32 -> Int) . imxScalar 28 | 29 | instance Matlabable String where 30 | toMatlab = listIMX [1,-1] 31 | fromMatlab = imxList 32 | 33 | instance Matlabable [Double] where 34 | toMatlab = listIMX [1,-1] 35 | fromMatlab = imxList 36 | 37 | instance Matlabable [Int] where 38 | toMatlab = listIMX [1,-1] . map (ii :: Int -> MInt32) 39 | fromMatlab = fmap (map (ii :: MInt32 -> Int)) . imxList 40 | 41 | instance Matlabable () where 42 | toMatlab () = IMXNull 43 | fromMatlab IMXNull = Just () 44 | fromMatlab _ = Nothing 45 | 46 | -- |Generate a temporary 'MXArray' 47 | withMatlabArray :: Matlabable a => a -> (MAnyArray -> IO a) -> IO a 48 | withMatlabArray = withIMXData . toMatlab 49 | 50 | -- |Convert directly from 'MXArray' (without freeing the original array) 51 | fromMatlabArray :: Matlabable a => MAnyArray -> IO (Maybe a) 52 | fromMatlabArray = fromMatlab .=< imxData 53 | -------------------------------------------------------------------------------- /test/Test/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Util where 4 | 5 | import Control.Monad.Catch (MonadThrow) 6 | import Control.Monad.IO.Class 7 | import qualified Control.Exception as E 8 | import Control.Monad (join) 9 | -- import Data.AEq 10 | -- import Data.CallStack 11 | import Data.Either (fromRight) 12 | import qualified Data.Text as Txt 13 | import Language.Haskell.TH 14 | import Language.Haskell.TH.Syntax 15 | import Path 16 | import System.Environment 17 | -- import Test.HUnit.Lang (FailureReason(..), HUnitFailure(..)) 18 | import Test.UtilTemplate 19 | 20 | getRepoDirStatic :: String 21 | getRepoDirStatic = $(lift . toFilePath =<< runIO getRepoDir) 22 | 23 | 24 | -- fromRightTst :: Either a b -> b 25 | -- fromRightTst = (fromRight undefined) 26 | 27 | -- assertEqualFP :: (AEq a, Show a) => [Char] -> a -> a -> IO () 28 | -- assertEqualFP preface e a = unless (a === e) $ unequalBody preface e a 29 | 30 | -- assertApproxFP :: (AEq a, Show a) => [Char] -> a -> a -> IO () 31 | -- assertApproxFP preface e a = unless (a ~== e) $ unequalBody preface e a 32 | 33 | -- unequalBody :: (Show a1, Show a2) => [Char] -> a2 -> a1 -> IO () 34 | -- unequalBody preface expected actual = do 35 | -- (prefaceMsg `deepseq` expectedMsg `deepseq` actualMsg `deepseq` E.throwIO 36 | -- (HUnitFailure location $ ExpectedButGot prefaceMsg expectedMsg actualMsg)) 37 | -- where 38 | -- prefaceMsg 39 | -- | null preface = Nothing 40 | -- | otherwise = Just preface 41 | -- expectedMsg = show expected 42 | -- actualMsg = show actual 43 | 44 | -- -- | As copied from https://hackage.haskell.org/package/HUnit-1.6.0.0/docs/src/Test.HUnit.Lang.html#location 45 | -- location :: HasCallStack => Maybe SrcLoc 46 | -- location = case reverse callStack of 47 | -- (_, loc) : _ -> Just loc 48 | -- [] -> Nothing 49 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | import Distribution.Simple.Utils 3 | import Distribution.Simple.Setup 4 | import Distribution.Simple.Program 5 | import Distribution.Simple.LocalBuildInfo 6 | import Distribution.PackageDescription 7 | import Distribution.ModuleName (components) 8 | import Control.Monad 9 | import Data.Maybe 10 | import System.Directory 11 | import System.FilePath 12 | 13 | defhooks = simpleUserHooks 14 | 15 | programs = [ simpleProgram "mcc" ] 16 | 17 | runtime desc = maybe False (elem ["Foreign","Matlab","Runtime"] 18 | . map components . exposedModules) $ library desc 19 | 20 | build desc binfo hooks flags = do 21 | when (runtime desc) $ 22 | rawSystemExit (fromFlag $ buildVerbosity flags) "make" ["-Csrc"] 23 | buildHook defhooks desc binfo hooks flags 24 | 25 | clean desc binfo hooks flags = do 26 | makeExists <- doesFileExist "src/Makefile" 27 | when makeExists $ 28 | rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["-Csrc", "clean"] 29 | cleanHook defhooks desc binfo hooks flags 30 | 31 | install desc binfo hooks flags = do 32 | instHook defhooks desc binfo hooks flags 33 | when (runtime desc) $ mapM_ (\f -> 34 | copyFileVerbose (fromFlag $ installVerbosity flags) 35 | ("src" f) 36 | (libdir (absoluteInstallDirs desc binfo NoCopyDest) f)) 37 | ["libhsmatlab.so"] 38 | 39 | reg desc binfo hooks flags = do 40 | pwd <- getCurrentDirectory 41 | let 42 | desc' = desc{ library = fmap lm (library desc) } 43 | lm l = l { libBuildInfo = (libBuildInfo l) 44 | { ldOptions = map ("-Wl,-rpath," ++) (extraLibDirs (libBuildInfo l) ) 45 | ++ ldOptions (libBuildInfo l), 46 | extraLibDirs = lib : extraLibDirs (libBuildInfo l) } } 47 | lib 48 | | fromFlag $ regInPlace flags = pwd "src" 49 | | otherwise = libdir (absoluteInstallDirs desc binfo NoCopyDest) 50 | regHook defhooks desc' binfo hooks flags 51 | 52 | hooks = defhooks { 53 | hookedPrograms = programs, 54 | buildHook = build, 55 | cleanHook = clean, 56 | instHook = install, 57 | regHook = reg 58 | } 59 | 60 | main = defaultMainWithHooks hooks 61 | -------------------------------------------------------------------------------- /src/libhsmatlab.h: -------------------------------------------------------------------------------- 1 | /* 2 | * MATLAB Compiler: 4.18.1 (R2013a) 3 | * Date: Mon Aug 4 14:07:22 2014 4 | * Arguments: "-B" "macro_default" "-W" "lib:libhsmatlab" "-T" "link:lib" 5 | * "libhsmatlab.c" 6 | */ 7 | 8 | #ifndef __libhsmatlab_h 9 | #define __libhsmatlab_h 1 10 | 11 | #if defined(__cplusplus) && !defined(mclmcrrt_h) && defined(__linux__) 12 | # pragma implementation "mclmcrrt.h" 13 | #endif 14 | #include "mclmcrrt.h" 15 | #ifdef __cplusplus 16 | extern "C" { 17 | #endif 18 | 19 | #if defined(__SUNPRO_CC) 20 | /* Solaris shared libraries use __global, rather than mapfiles 21 | * to define the API exported from a shared library. __global is 22 | * only necessary when building the library -- files including 23 | * this header file to use the library do not need the __global 24 | * declaration; hence the EXPORTING_ logic. 25 | */ 26 | 27 | #ifdef EXPORTING_libhsmatlab 28 | #define PUBLIC_libhsmatlab_C_API __global 29 | #else 30 | #define PUBLIC_libhsmatlab_C_API /* No import statement needed. */ 31 | #endif 32 | 33 | #define LIB_libhsmatlab_C_API PUBLIC_libhsmatlab_C_API 34 | 35 | #elif defined(_HPUX_SOURCE) 36 | 37 | #ifdef EXPORTING_libhsmatlab 38 | #define PUBLIC_libhsmatlab_C_API __declspec(dllexport) 39 | #else 40 | #define PUBLIC_libhsmatlab_C_API __declspec(dllimport) 41 | #endif 42 | 43 | #define LIB_libhsmatlab_C_API PUBLIC_libhsmatlab_C_API 44 | 45 | 46 | #else 47 | 48 | #define LIB_libhsmatlab_C_API 49 | 50 | #endif 51 | 52 | /* This symbol is defined in shared libraries. Define it here 53 | * (to nothing) in case this isn't a shared library. 54 | */ 55 | #ifndef LIB_libhsmatlab_C_API 56 | #define LIB_libhsmatlab_C_API /* No special import/export declaration */ 57 | #endif 58 | 59 | extern LIB_libhsmatlab_C_API 60 | bool MW_CALL_CONV libhsmatlabInitializeWithHandlers( 61 | mclOutputHandlerFcn error_handler, 62 | mclOutputHandlerFcn print_handler); 63 | 64 | extern LIB_libhsmatlab_C_API 65 | bool MW_CALL_CONV libhsmatlabInitialize(void); 66 | 67 | extern LIB_libhsmatlab_C_API 68 | void MW_CALL_CONV libhsmatlabTerminate(void); 69 | 70 | 71 | 72 | extern LIB_libhsmatlab_C_API 73 | void MW_CALL_CONV libhsmatlabPrintStackTrace(void); 74 | 75 | 76 | 77 | #ifdef __cplusplus 78 | } 79 | #endif 80 | #endif 81 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-14.27 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | 68 | nix: 69 | pure: true 70 | shell-file: shell.nix 71 | -------------------------------------------------------------------------------- /Foreign/Matlab/Engine/Wrappers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Wrappers to common (and some uncommon) MATLAB functions using the MATLAB Engine. 3 | 4 | Note that you cannot use "Foreign.Matlab.Engine" and "Foreign.Matlab.Runtime" in the same program. 5 | This seems to be a Matlab limitation. 6 | -} 7 | 8 | module Foreign.Matlab.Engine.Wrappers ( 9 | addpath 10 | , clearVar 11 | , getArrayFromByteStream 12 | , getByteStreamFromArray 13 | , MEither(..), isMLeft, isMRight 14 | , VarArgIn, mxVarArgs 15 | ) where 16 | 17 | import qualified Data.Map.Strict as DM 18 | import Foreign.Matlab 19 | import Foreign.Matlab.Engine 20 | import Path 21 | 22 | type VarArgIn = DM.Map String MAnyArray 23 | 24 | -- | We require an absolute path in this case 25 | addpath :: Engine -> Path Abs Dir -> IO () 26 | addpath eng p = engineEvalProc eng "addpath" [EvalStr $ toFilePath p] 27 | 28 | -- | TODO: add a test for this, likely not working as expected. 29 | -- | Clears a variable from the engine's workspace 30 | clearVar :: Engine -> String -> IO () 31 | clearVar eng var = engineEvalProc eng "clear" [EvalStr var] 32 | 33 | -- | Wraps an undocumented function to serialize a MATLAB object. 34 | getByteStreamFromArray :: Engine -> MAnyArray -> IO (Either String [MUint8]) 35 | getByteStreamFromArray eng mObj = do 36 | [byteStream] <- engineEvalFun eng "getByteStreamFromArray" [EvalArray mObj] 1 37 | mxArrMay <- castMXArray byteStream 38 | case mxArrMay of 39 | Just mxArr -> Right <$> mxArrayGetAll mxArr 40 | Nothing -> pure $ Left 41 | "getByteStreamFromArray: Couldn't convert MATLAB bytestream to [MUint8]" 42 | 43 | -- | Wraps an undocumented function to deserialize a MATLAB object. 44 | getArrayFromByteStream :: Engine -> [MUint8] -> IO MAnyArray 45 | getArrayFromByteStream eng bytes = do 46 | matBsArr <- createMXArray [length bytes] 47 | mxArraySetAll matBsArr bytes 48 | [mObj] <- engineEvalFun eng "getArrayFromByteStream" [EvalArray matBsArr] 1 49 | pure mObj 50 | 51 | newtype MEither = MEither {unMXEither :: MStructArray} 52 | 53 | isMLeft :: MEither -> IO Bool 54 | isMLeft me = do 55 | sFields <- mStructFields $ unMXEither me 56 | pure $ "left" `elem` sFields 57 | 58 | isMRight :: MEither -> IO Bool 59 | isMRight me = do 60 | sFields <- mStructFields $ unMXEither me 61 | pure $ "right" `elem` sFields 62 | 63 | -- | Utility function to create an eval-able list of arguments for a vararg map. 64 | mxVarArgs :: VarArgIn -> [EngineEvalArg MAny] 65 | mxVarArgs varargin = DM.toList varargin >>= kvToArg 66 | where 67 | kvToArg :: (String, MAnyArray) -> [EngineEvalArg MAny] 68 | kvToArg kv = [EvalStr $ fst kv, EvalArray $ snd kv] 69 | -------------------------------------------------------------------------------- /src/readme.txt: -------------------------------------------------------------------------------- 1 | MATLAB Compiler 2 | 3 | 1. Prerequisites for Deployment 4 | 5 | . Verify the MATLAB Compiler Runtime (MCR) is installed and ensure you 6 | have installed version 8.1 (R2013a). 7 | 8 | . If the MCR is not installed, do the following: 9 | (1) enter 10 | 11 | >>mcrinstaller 12 | 13 | at MATLAB prompt. The MCRINSTALLER command displays the 14 | location of the MCR Installer. 15 | 16 | (2) run the MCR Installer. 17 | 18 | Or download the Linux 64-bit version of the MCR for R2013a 19 | from the MathWorks Web site by navigating to 20 | 21 | http://www.mathworks.com/products/compiler/mcr/index.html 22 | 23 | 24 | For more information about the MCR and the MCR Installer, see 25 | Distribution to End Users in the MATLAB Compiler documentation 26 | in the MathWorks Documentation Center. 27 | 28 | 29 | 2. Files to Deploy and Package 30 | 31 | Files to package for Shared Libraries 32 | ===================================== 33 | -libhsmatlab.so 34 | -libhsmatlab.h 35 | -MCRInstaller.zip 36 | -if end users are unable to download the MCR using the above 37 | link, include it when building your component by clicking 38 | the "Add MCR" link in the Deployment Tool 39 | -This readme file 40 | 41 | 3. Definitions 42 | 43 | For information on deployment terminology, go to 44 | http://www.mathworks.com/help. Select MATLAB Compiler > 45 | Getting Started > About Application Deployment > 46 | Application Deployment Terms in the MathWorks Documentation 47 | Center. 48 | 49 | 50 | 4. Appendix 51 | 52 | A. Linux x86-64 systems: 53 | On the target machine, add the MCR directory to the environment variable 54 | LD_LIBRARY_PATH by issuing the following commands: 55 | 56 | NOTE: is the directory where MCR is installed 57 | on the target machine. 58 | 59 | setenv LD_LIBRARY_PATH 60 | $LD_LIBRARY_PATH: 61 | /v81/runtime/glnxa64: 62 | /v81/bin/glnxa64: 63 | /v81/sys/os/glnxa64: 64 | /v81/sys/java/jre/glnxa64/jre/lib/amd64/native_threads: 65 | /v81/sys/java/jre/glnxa64/jre/lib/amd64/server: 66 | /v81/sys/java/jre/glnxa64/jre/lib/amd64 67 | setenv XAPPLRESDIR /v81/X11/app-defaults 68 | 69 | For more detail information about setting MCR paths, see Distribution to End Users in 70 | the MATLAB Compiler documentation in the MathWorks Documentation Center. 71 | 72 | 73 | 74 | NOTE: To make these changes persistent after logout on Linux 75 | or Mac machines, modify the .cshrc file to include this 76 | setenv command. 77 | NOTE: The environment variable syntax utilizes forward 78 | slashes (/), delimited by colons (:). 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /Foreign/Matlab/Runtime/Generic.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Generic runtime library interface. 3 | This uses a Matlab library built along with HSMatlab to provide runtime access to general Matlab functionality throuh "Foreign.Matlab.Runtime". 4 | Any builtin Matlab function can be called through this interface, but other M-file functions may not -- these need to be put into a library or used through "Foreign.Matlab.Engine" instead. 5 | -} 6 | module Foreign.Matlab.Runtime.Generic ( 7 | MLGeneric, 8 | openMLGeneric, 9 | closeMLGeneric, 10 | mlGenericEval, 11 | mlGenericFun, 12 | mlGenericSetVar, 13 | mlGenericGetVar, 14 | mlGenericCapture 15 | ) where 16 | 17 | import Foreign.C.String 18 | --import System.FilePath 19 | import Foreign.Matlab.Util 20 | import Foreign.Matlab.Types 21 | import Foreign.Matlab.Array 22 | import Foreign.Matlab.Runtime 23 | --import Paths_matlab 24 | 25 | data MLGeneric = MLGeneric { 26 | mlgLibrary :: MLibrary, 27 | mlgFeval :: CString -> MFun 28 | } 29 | 30 | -- |Create a generic interface to the Matlab runtime. Only one is necessary in any given application. 31 | openMLGeneric :: [String] -> IO MLGeneric 32 | openMLGeneric opt = do 33 | -- libdir <- getLibDir 34 | ml <- openMLibrary ({- libdir -} "hsmatlab") opt 35 | feval <- mlGenericFeval ml 36 | return $ MLGeneric { mlgLibrary = ml, mlgFeval = feval } 37 | 38 | -- |Close a MLGeneric interface no longer in use. 39 | closeMLGeneric :: MLGeneric -> IO () 40 | closeMLGeneric MLGeneric{ mlgLibrary = ml } = closeMLibrary ml 41 | 42 | -- |Call the named Matlab function using the specified interface. 43 | mlGenericFun :: MLGeneric -> String -> MFun 44 | mlGenericFun mlg f a n = do 45 | withCString f (\f -> mlgFeval mlg f (map anyMXArray a) n) 46 | 47 | -- |Eval Matlab code. 48 | mlGenericEval :: MLGeneric 49 | -> String -- ^ The Matlab code string to evaluate 50 | -> Int -- ^ The number of arguments returned by the code 51 | -> IO [MAnyArray] 52 | mlGenericEval mlg e n = do 53 | e <- createRowVector e 54 | r <- mlGenericFun mlg "eval" [anyMXArray e] n 55 | freeMXArray e 56 | return r 57 | 58 | -- |Set the given variable to the value in the base scope 59 | mlGenericSetVar :: MLGeneric -> String -> MXArray a -> IO () 60 | mlGenericSetVar mlg v x = do 61 | b <- createRowVector "base" 62 | v <- createRowVector v 63 | [] <- mlGenericFun mlg "assignin" [anyMXArray b,anyMXArray v,anyMXArray x] 0 64 | freeMXArray v 65 | freeMXArray b 66 | 67 | -- |Get the value of the given variable in the base scope 68 | mlGenericGetVar :: MLGeneric -> String -> IO MAnyArray 69 | mlGenericGetVar mlg v = head =.< mlGenericEval mlg v 1 70 | 71 | -- |Evaluate Matlab code and capture the generated output (see 'mlGenericEval') 72 | mlGenericCapture :: MLGeneric -> String -> Int -> IO (String,[MAnyArray]) 73 | mlGenericCapture mlg e n = do 74 | e <- createRowVector e 75 | (cap:res) <- mlGenericFun mlg "evalc" [anyMXArray e] (succ n) 76 | freeMXArray e 77 | Just cap <- castMXArray cap 78 | cap <- mxArrayGetAll cap 79 | return $ (cap,res) 80 | -------------------------------------------------------------------------------- /src/libhsmatlab.c: -------------------------------------------------------------------------------- 1 | /* 2 | * MATLAB Compiler: 4.18.1 (R2013a) 3 | * Date: Mon Aug 4 14:07:22 2014 4 | * Arguments: "-B" "macro_default" "-W" "lib:libhsmatlab" "-T" "link:lib" 5 | * "libhsmatlab.c" 6 | */ 7 | 8 | #include 9 | #define EXPORTING_libhsmatlab 1 10 | #include "libhsmatlab.h" 11 | 12 | static HMCRINSTANCE _mcr_inst = NULL; 13 | 14 | 15 | #ifdef __cplusplus 16 | extern "C" { 17 | #endif 18 | 19 | static int mclDefaultPrintHandler(const char *s) 20 | { 21 | return mclWrite(1 /* stdout */, s, sizeof(char)*strlen(s)); 22 | } 23 | 24 | #ifdef __cplusplus 25 | } /* End extern "C" block */ 26 | #endif 27 | 28 | #ifdef __cplusplus 29 | extern "C" { 30 | #endif 31 | 32 | static int mclDefaultErrorHandler(const char *s) 33 | { 34 | int written = 0; 35 | size_t len = 0; 36 | len = strlen(s); 37 | written = mclWrite(2 /* stderr */, s, sizeof(char)*len); 38 | if (len > 0 && s[ len-1 ] != '\n') 39 | written += mclWrite(2 /* stderr */, "\n", sizeof(char)); 40 | return written; 41 | } 42 | 43 | #ifdef __cplusplus 44 | } /* End extern "C" block */ 45 | #endif 46 | 47 | /* This symbol is defined in shared libraries. Define it here 48 | * (to nothing) in case this isn't a shared library. 49 | */ 50 | #ifndef LIB_libhsmatlab_C_API 51 | #define LIB_libhsmatlab_C_API /* No special import/export declaration */ 52 | #endif 53 | 54 | LIB_libhsmatlab_C_API 55 | bool MW_CALL_CONV libhsmatlabInitializeWithHandlers( 56 | mclOutputHandlerFcn error_handler, 57 | mclOutputHandlerFcn print_handler) 58 | { 59 | int bResult = 0; 60 | if (_mcr_inst != NULL) 61 | return true; 62 | if (!mclmcrInitialize()) 63 | return false; 64 | { 65 | mclCtfStream ctfStream = 66 | mclGetEmbeddedCtfStream((void *)(libhsmatlabInitializeWithHandlers)); 67 | if (ctfStream) { 68 | bResult = mclInitializeComponentInstanceEmbedded( &_mcr_inst, 69 | error_handler, 70 | print_handler, 71 | ctfStream); 72 | mclDestroyStream(ctfStream); 73 | } else { 74 | bResult = 0; 75 | } 76 | } 77 | if (!bResult) 78 | return false; 79 | return true; 80 | } 81 | 82 | LIB_libhsmatlab_C_API 83 | bool MW_CALL_CONV libhsmatlabInitialize(void) 84 | { 85 | return libhsmatlabInitializeWithHandlers(mclDefaultErrorHandler, 86 | mclDefaultPrintHandler); 87 | } 88 | 89 | LIB_libhsmatlab_C_API 90 | void MW_CALL_CONV libhsmatlabTerminate(void) 91 | { 92 | if (_mcr_inst != NULL) 93 | mclTerminateInstance(&_mcr_inst); 94 | } 95 | 96 | LIB_libhsmatlab_C_API 97 | void MW_CALL_CONV libhsmatlabPrintStackTrace(void) 98 | { 99 | char** stackTrace; 100 | int stackDepth = mclGetStackTrace(&stackTrace); 101 | int i; 102 | for(i=0; i 26 | 27 | data MATFileType 28 | type MATFilePtr = Ptr MATFileType 29 | -- |The opaque type of MAT file handles 30 | newtype MATFile = MATFile MATFilePtr 31 | 32 | withMATFile :: With MATFile MATFilePtr (IO a) 33 | withMATFile (MATFile mat) f = f mat 34 | 35 | foreign import ccall unsafe "matOpen" matOpen_c :: CString -> CString -> IO MATFilePtr 36 | foreign import ccall unsafe "matClose" matClose_c :: MATFilePtr -> IO CInt 37 | 38 | data MATMode = MATRead | MATWrite | MATUpdate 39 | 40 | -- |Open a MAT-file using mode. 41 | matOpen :: FilePath -> MATMode -> IO MATFile 42 | matOpen f m = do 43 | throwErrnoIfNull ("matOpen: " ++ f) 44 | (withCString f (withCString (ms m) . matOpen_c)) 45 | >.= MATFile 46 | where 47 | ms MATRead = "r" 48 | ms MATWrite = "w" 49 | ms MATUpdate = "u" 50 | 51 | -- |Close a MAT-file opened with matOpen. 52 | matClose :: MATFile -> IO () 53 | matClose m = throwErrnoIfMinus1_ "matClose" $ withMATFile m matClose_c 54 | 55 | foreign import ccall unsafe matPutVariable :: MATFilePtr -> CString -> MXArrayPtr -> IO CInt 56 | foreign import ccall unsafe matPutVariableAsGlobal :: MATFilePtr -> CString -> MXArrayPtr -> IO CInt 57 | -- |Write array value with the specified name to the MAT-file, deleting any previously existing variable with that name in the MAT-file. 58 | matSet :: MATFile 59 | -> Bool -- ^ Global. If true, the variable will be written such that when the MATLAB LOAD command loads the variable, it will automatically place it in the global workspace. 60 | -> String -> MXArray a -> IO () 61 | matSet m g n v = do 62 | r <- withMATFile m (\m -> withCString n (withMXArray v . (if g then matPutVariableAsGlobal else matPutVariable) m)) 63 | when (r /= 0) $ fail "matPut" 64 | 65 | foreign import ccall unsafe matGetVariable :: MATFilePtr -> CString -> IO MXArrayPtr 66 | -- |Read the array value for the specified variable name from a MAT-file. 67 | matGet :: MATFile -> String -> IO (Maybe MAnyArray) 68 | matGet m n = do 69 | a <- withMATFile m (withCString n . matGetVariable) 70 | if a == nullPtr 71 | then return Nothing 72 | else Just =.< mkMXArray a 73 | 74 | foreign import ccall unsafe matDeleteVariable :: MATFilePtr -> CString -> IO CInt 75 | -- |Remove a variable with with the specified name from the MAT-file. 76 | matRemove :: MATFile -> String -> IO () 77 | matRemove m n = do 78 | r <- withMATFile m (withCString n . matDeleteVariable) 79 | when (r /= 0) $ fail "matRemove" 80 | 81 | foreign import ccall unsafe mxFree :: Ptr a -> IO () 82 | 83 | foreign import ccall unsafe matGetDir :: MATFilePtr -> Ptr CInt -> IO (Ptr CString) 84 | -- |Get a list of the names of the arrays in a MAT-file. 85 | matList :: MATFile -> IO [String] 86 | matList m = 87 | withMATFile m $ \m -> alloca $ \n -> do 88 | sp <- matGetDir m n 89 | n <- peek n 90 | when (n < 0) $ fail "matList" 91 | s <- mapM peekCString =<< peekArray (ii n) sp 92 | mxFree sp 93 | return s 94 | 95 | foreign import ccall unsafe matGetNextVariable :: MATFilePtr -> Ptr CString -> IO MXArrayPtr 96 | -- |Load all the variables from a MAT file 97 | matLoad :: FilePath -> IO [(String,MAnyArray)] 98 | matLoad file = do 99 | mat <- matOpen file MATRead 100 | vars <- withMATFile mat load 101 | matClose mat 102 | return vars 103 | where 104 | load m = alloca $ \n -> do 105 | a <- matGetNextVariable m n 106 | if a == nullPtr 107 | then return [] 108 | else do 109 | a <- mkMXArray a 110 | n <- peek n >>= peekCString 111 | ((n,a) :) =.< load m 112 | 113 | -- |Write all the variables to a new MAT file 114 | matSave :: FilePath -> [(String,MXArray a)] -> IO () 115 | matSave file vars = do 116 | mat <- matOpen file MATWrite 117 | mapM_ (uncurry $ matSet mat False) vars 118 | matClose mat 119 | -------------------------------------------------------------------------------- /Foreign/Matlab/Engine.hsc: -------------------------------------------------------------------------------- 1 | {-| 2 | Interface to a Matlab engine. 3 | This works by spawning a separate matlab process and interchanging data in MAT format. 4 | 5 | Note that you cannot use "Foreign.Matlab.Engine" and "Foreign.Matlab.Runtime" in the same program. 6 | This seems to be a Matlab limitation. 7 | -} 8 | module Foreign.Matlab.Engine ( 9 | Engine, 10 | newEngine, 11 | engineEval, 12 | engineGetVar, 13 | engineSetVar, 14 | EngineEvalArg(..), 15 | engineEvalFun, 16 | engineEvalProc, 17 | HasEngine(..), SetEngine(..), 18 | qt 19 | ) where 20 | 21 | import Control.Monad 22 | import Foreign 23 | import Foreign.C.String 24 | import Foreign.C.Types 25 | import Data.List 26 | import Foreign.Matlab.Array (createMXScalar) 27 | import Foreign.Matlab.Optics 28 | import Foreign.Matlab.Util 29 | import Foreign.Matlab.Internal 30 | 31 | #include 32 | 33 | data EngineType 34 | type EnginePtr = Ptr EngineType 35 | 36 | 37 | class HasEngine env where 38 | getEngine :: env -> Engine 39 | 40 | class HasEngine env => SetEngine env where 41 | setEngine :: env -> Engine -> env 42 | 43 | engine :: Lens' env Engine 44 | engine = lens getEngine setEngine 45 | 46 | -- |A Matlab engine instance 47 | newtype Engine = Engine (ForeignPtr EngineType) 48 | deriving Eq 49 | 50 | foreign import ccall unsafe engOpen :: CString -> IO EnginePtr 51 | foreign import ccall unsafe "&" engClose :: FunPtr (EnginePtr -> IO ()) -- CInt 52 | 53 | -- |Start Matlab server process. It will automatically be closed down when no longer in use. 54 | newEngine :: FilePath -> IO Engine 55 | newEngine host = do 56 | eng <- withCString host engOpen 57 | if eng == nullPtr 58 | then fail "engOpen" 59 | else Engine =.< newForeignPtr engClose eng 60 | 61 | withEngine :: Engine -> (EnginePtr -> IO a) -> IO a 62 | withEngine (Engine eng) = withForeignPtr eng 63 | 64 | foreign import ccall unsafe engEvalString :: EnginePtr -> CString -> IO CInt 65 | -- |Execute matlab statement 66 | engineEval :: Engine -> String -> IO () 67 | engineEval eng s = do 68 | r <- withEngine eng (withCString s . engEvalString) 69 | when (r /= 0) $ fail "engineEval" 70 | 71 | foreign import ccall unsafe engGetVariable :: EnginePtr -> CString -> IO MXArrayPtr 72 | -- |Get a variable with the specified name from MATLAB's workspace 73 | engineGetVar :: Engine -> String -> IO (MXArray a) 74 | engineGetVar eng v = withEngine eng (withCString v . engGetVariable) >>= mkMXArray 75 | 76 | foreign import ccall unsafe engPutVariable :: EnginePtr -> CString -> MXArrayPtr -> IO CInt 77 | -- |Put a variable into MATLAB's workspace with the specified name 78 | engineSetVar :: Engine -> String -> MXArray a -> IO () 79 | engineSetVar eng v x = do 80 | r <- withEngine eng (\eng -> withCString v (withMXArray x . engPutVariable eng)) 81 | when (r /= 0) $ fail "engineSetVar" 82 | 83 | data EngineEvalArg a = EvalArray (MXArray a) | EvalStruct MStruct | EvalVar String | EvalStr String 84 | 85 | -- |Evaluate a function with the given arguments and number of results. 86 | -- This automates 'engineSetVar' on arguments (using \"hseval_inN\"), 'engineEval', and 'engineGetVar' on results (using \"hseval_outN\"). 87 | engineEvalFun :: Engine -> String -> [EngineEvalArg a] -> Int -> IO [MAnyArray] 88 | engineEvalFun eng fun args no = do 89 | arg <- zipWithM makearg args [1 :: Int ..] 90 | let out = map makeout [1..no] 91 | let outs = if out == [] then "" else "[" ++ unwords out ++ "] = " 92 | engineEval eng (outs ++ fun ++ "(" ++ intercalate "," arg ++ ")") 93 | mapM (engineGetVar eng) out 94 | where 95 | makearg (EvalArray x) i = do 96 | let v = "hseval_in" ++ show i 97 | engineSetVar eng v x 98 | pure v 99 | makearg (EvalStruct x) i = do 100 | xa <- createMXScalar x 101 | let v = "hseval_in" ++ show i 102 | engineSetVar eng v xa 103 | pure v 104 | makearg (EvalVar v) _ = pure v 105 | makearg (EvalStr v) _ = pure $ qt v 106 | makeout i = "hseval_out" ++ show i 107 | 108 | -- |Convenience function for calling functions that do not return values (i.e. "procedures"). 109 | engineEvalProc :: Engine -> String -> [EngineEvalArg a] -> IO () 110 | engineEvalProc eng fun args = do 111 | _ <- engineEvalFun eng fun args 0 112 | pure () 113 | 114 | -- |Utility function to quote a string 115 | qt :: String -> String 116 | qt s = "'" <> s <> "'" 117 | -------------------------------------------------------------------------------- /matlab.cabal: -------------------------------------------------------------------------------- 1 | Name: matlab 2 | Version: 0.3.0.0 3 | Cabal-Version: >= 1.10 4 | Author: Dylan Simon, Ben Sherman, Brandon Barker 5 | Maintainer: Brandon Barker 6 | License: BSD3 7 | License-file: LICENSE 8 | Synopsis: Matlab bindings and interface 9 | Description: 10 | This package aims to provide a comprehensive interface to the 11 | MathWorks MATLAB(R) libraries and native data structures, including 12 | complete matrix access, MAT-format files, linking and execution of 13 | runtime libraries and engine. Requires MATLAB for full functionality 14 | or an installed Matlab Component Runtime (MCR). This has been tested 15 | with MATLAB R2014a and might work with others. 16 | . 17 | [/Installation/] 18 | You will probably need add some arguments that point Cabal to your MATLAB 19 | installation. For example, on a Linux system, it may look like this: 20 | . 21 | > cabal install --extra-lib-dirs="/usr/local/MATLAB/R2014a/bin/glnxa64/" --extra-include-dirs="/usr/local/MATLAB/R2014a/extern/include/" 22 | Category: Foreign,Math 23 | Bug-reports: https://github.com/bmsherman/haskell-matlab/issues 24 | 25 | build-type: Custom 26 | tested-with: GHC == 8.6.5 27 | extra-source-files: src/Makefile src/hsmatlab.m src/hsmatlab.c src/hsc_sym.h 28 | test/Makefile test/runtime.hs 29 | test/generic.hs test/mtest.m test/hsmli.hs 30 | test/Test/Engine.hs 31 | 32 | Flag Engine 33 | Description: Enable Matlab engine (spawned eng process) support 34 | default: True 35 | Flag Runtime 36 | Description: Enable Matlab runtime (linked library) support 37 | default: False 38 | 39 | library 40 | default-language: Haskell2010 41 | Build-depends: base >= 4.0 && < 4.16, 42 | array >= 0.5 && < 0.6, 43 | filepath >= 1.4 && < 1.5, 44 | path >= 0.6 && < 0.7, 45 | profunctors >= 5.3 && < 5.4, 46 | Cabal >= 2.1 && < 2.5 47 | Exposed-modules: Foreign.Matlab, 48 | Foreign.Matlab.Types, 49 | Foreign.Matlab.Array, 50 | Foreign.Matlab.Array.Auto, 51 | Foreign.Matlab.Array.MArray, 52 | Foreign.Matlab.Array.IMX, 53 | Foreign.Matlab.Array.Able, 54 | Foreign.Matlab.Engine.Wrappers, 55 | Foreign.Matlab.MAT 56 | Other-modules: Foreign.Matlab.Optics 57 | Foreign.Matlab.Util, 58 | Foreign.Matlab.Internal 59 | default-extensions: ForeignFunctionInterface, 60 | MultiParamTypeClasses, 61 | FunctionalDependencies, 62 | FlexibleInstances 63 | ghc-options: -Wall -fno-warn-name-shadowing 64 | include-dirs: src/ 65 | extra-libraries: mx, mat 66 | 67 | if flag(runtime) 68 | build-tools: mcc 69 | Build-depends: unix >= 2.7 && < 2.8 70 | Exposed-modules: Foreign.Matlab.Runtime, Foreign.Matlab.Runtime.Generic 71 | 72 | if flag(engine) 73 | Exposed-modules: Foreign.Matlab.Engine 74 | Build-depends: containers >= 0.6 && < 0.7 75 | extra-libraries: eng 76 | 77 | Source-repository head 78 | Type: git 79 | Location: git://github.com/bmsherman/haskell-matlab.git 80 | 81 | Source-repository this 82 | Type: git 83 | Location: git://github.com/bmsherman/haskell-matlab/releases/tag/0.3.0.0.git 84 | Tag: 0.3.0.0 85 | 86 | -- test-suite matlab-test 87 | -- type: exitcode-stdio-1.0 88 | -- main-is: Spec.hs 89 | -- other-modules: 90 | -- Test.Engine 91 | -- hs-source-dirs: 92 | -- test 93 | -- ghc-options: -threaded -rtsopts -with-rtsopts=-N 94 | -- build-depends: 95 | -- base >= 4 && <5 96 | -- , filepath 97 | -- , matlab 98 | -- , turtle >= 1.5 99 | -- default-language: Haskell2010 100 | -- extra-libraries: eng, mx, mat 101 | 102 | executable matlab-engine-test 103 | main-is: SpecEngine.hs 104 | other-modules: 105 | Test.Engine 106 | Test.Util 107 | Test.UtilTemplate 108 | hs-source-dirs: 109 | test 110 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts 111 | build-depends: 112 | base 113 | , exceptions >= 0.10 && < 0.11 114 | , filepath 115 | , matlab 116 | , path 117 | , template-haskell >= 2.14 && < 2.15 118 | , text >= 1.2 && < 1.3 119 | default-language: Haskell2010 120 | extra-libraries: eng, mx, mat 121 | 122 | executable haskell-hello 123 | main-is: SpecHello.hs 124 | other-modules: 125 | hs-source-dirs: 126 | hello 127 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 128 | build-depends: 129 | base 130 | default-language: Haskell2010 131 | extra-libraries: 132 | -------------------------------------------------------------------------------- /Foreign/Matlab/Types.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Mapping of basic Matlab types to Haskell types. 3 | -} 4 | module Foreign.Matlab.Types ( 5 | -- * Representations of Matlab types 6 | -- |Most types are simple aliases of Haskell types, given simply to identify them and provide a consistent naming scheme. 7 | 8 | MIO, 9 | 10 | MXClass(..), 11 | MChar, 12 | MLogical, 13 | MScalar, 14 | 15 | MNumeric, 16 | -- * Numeric types 17 | MDouble, 18 | MSingle, 19 | MInt8, 20 | MInt16, 21 | MInt32, 22 | MInt64, 23 | MUint8, 24 | MUint16, 25 | MUint32, 26 | MUint64, 27 | MComplex, 28 | 29 | -- * Array indexing 30 | MSize, MSubs, 31 | MIndex(..), 32 | mStart, mOffset, 33 | mSizeRange, mRangeSize, 34 | normMSize, realMSize, 35 | 36 | -- * Opaque types 37 | MXArray, 38 | MAny, MAnyArray, 39 | MCell(MCell), mCell, 40 | MStruct, mStruct, 41 | MFun 42 | ) where 43 | 44 | 45 | import Data.Complex 46 | import Data.Ix 47 | import Foreign.Matlab.Internal 48 | 49 | -- |The class of types which are simple Matlab scalars and can be array elements 50 | class MScalar a 51 | -- |The class of types which Matlab consisters \"numeric\" 52 | class (MScalar a, Num a) => MNumeric a 53 | 54 | instance MScalar MChar 55 | instance MScalar MLogical 56 | instance MScalar MDouble 57 | instance MScalar MSingle 58 | instance MScalar MInt8 59 | instance MScalar MInt16 60 | instance MScalar MInt32 61 | instance MScalar MInt64 62 | instance MScalar MUint8 63 | instance MScalar MUint16 64 | instance MScalar MUint32 65 | instance MScalar MUint64 66 | instance MNumeric a => MScalar (MComplex a) 67 | 68 | instance MNumeric MDouble 69 | instance MNumeric MSingle 70 | instance MNumeric MInt8 71 | instance MNumeric MInt16 72 | instance MNumeric MInt32 73 | instance MNumeric MInt64 74 | instance MNumeric MUint8 75 | instance MNumeric MUint16 76 | instance MNumeric MUint32 77 | instance MNumeric MUint64 78 | 79 | -- |Complex numeric types. Unfortunately, 'Complex' only applies to 'RealFloat' types, whereas Matlab allows any numeric type, so some types are (currently) unaccessable. 80 | type MComplex = Complex 81 | 82 | -- |The type of array sizes, which are the column-major lengths of each dimensions 83 | type MSize = [Int] 84 | -- |The type of array index subscripts, which are the column-major, 0-based indices in each dimension with normal Matlab semantics (flatten along last dimension) 85 | type MSubs = [Int] 86 | -- |Ways to index an array. Using Matlab semantics, a singleton MSubs [n] is equivalent to a raw 0-based offset (MOffset n). 87 | newtype MIndex = MSubs MSubs 88 | -- MOffset Int -- ^0-based offset from the beginning of the array (equivalent to singleton MSubs) 89 | 90 | -- |First index in array 91 | mStart :: MIndex 92 | mStart = MSubs [] 93 | 94 | -- |Raw, 0-based array offset index 95 | mOffset :: Int -> MIndex 96 | mOffset i = MSubs [i] 97 | 98 | instance Show MIndex where 99 | showsPrec _ (MSubs []) = id 100 | showsPrec _ (MSubs l) = showChar '(' . foldr1 (\s r -> s . showChar ',' . r) (map shows l) . showChar ')' 101 | instance Eq MIndex where 102 | MSubs a == MSubs b = eq a b where 103 | eq [] [] = True 104 | eq (x:a) (y:b) = (x == y) && eq a b 105 | eq [] b = eq [0] b 106 | eq a [] = eq a [0] 107 | instance Ord MIndex where 108 | compare (MSubs a) (MSubs b) = cmp a b where 109 | cmp [] [] = EQ 110 | cmp (x:a) (y:b) = case cmp a b of { EQ -> compare x y ; r -> r } 111 | cmp [] b = cmp [0] b 112 | cmp a [] = cmp a [0] 113 | instance Ix MIndex where 114 | range (MSubs a, MSubs b) = map MSubs $ rng a b where 115 | rng [] [] = [[]] 116 | rng (x:a) (y:b) = concatMap (\l -> map (:l) [x..y]) $ rng a b 117 | rng [] b = rng [0] b 118 | rng _ _ = error "MIndex.range: length mismatch" 119 | index (MSubs a, MSubs b) (MSubs l) = idx a b l where 120 | idx _ _ [] = 0 121 | idx (x:a) (y:b) (i:l) = i-x+((y-x+1)*idx a b l) 122 | idx [] [] (0:l) = idx [] [] l 123 | idx [] b l = idx [0] b l 124 | idx _ _ _ = error "MIndex.index: length mismatch" 125 | inRange (MSubs a, MSubs b) (MSubs l) = inr a b l where 126 | inr _ _ [] = True 127 | inr a@(x:_) b@(_:_) [i] = i >= x && i-x < rangeSize (MSubs a, MSubs b) 128 | inr (x:a) (y:b) (i:l) = i >= x && i <= y && inr a b l 129 | inr [] [] (0:l) = inr [] [] l 130 | inr [] b l = inr [0] b l 131 | inr _ _ _ = error "MIndex.inRange: length mismatch" 132 | rangeSize (MSubs a, MSubs b) = rsz a b where 133 | rsz [] b = product $ map succ b 134 | rsz (x:a) (y:b) = (y-x+1)*rsz a b 135 | rsz _ _ = error "MIndex.rangeSize: length mismatch" 136 | 137 | -- |Convert an array size to an index range, which will be of the form ((0,0,0...),(i-1,j-1,k-1,...)) 138 | mSizeRange :: MSize -> (MIndex,MIndex) 139 | mSizeRange l = (MSubs [], MSubs $ map pred $ normMSize l) 140 | 141 | -- |Convert an index range to an array size 142 | mRangeSize :: (MIndex,MIndex) -> MSize 143 | mRangeSize (MSubs [], MSubs l) = map succ l 144 | mRangeSize _ = error "mRangeSize: invalid lower bound" 145 | 146 | -- |Get the size form that Matlab likes (@length (realMSize s) >= 2@) 147 | realMSize :: MSize -> MSize 148 | realMSize [] = [1,1] 149 | realMSize [n] = [n,1] 150 | realMSize s = s 151 | 152 | -- |Get a more useful size form (no trailing singletons) 153 | normMSize :: MSize -> MSize 154 | normMSize [] = [] 155 | normMSize (1:l) = case normMSize l of { [] -> [] ; l -> (1:l) } 156 | normMSize (x:l) = x : normMSize l 157 | -------------------------------------------------------------------------------- /Foreign/Matlab/Runtime.hsc: -------------------------------------------------------------------------------- 1 | {-| 2 | Interface to Matlab runtime libraries. 3 | This uses a Matlab shared library which has been built with \"mcc -l\", and only functions in this library may be called. 4 | Multiple libraries may be loaded simultaneously. 5 | 6 | Note that you cannot use "Foreign.Matlab.Runtime" and "Foreign.Matlab.Engine" in the same program. 7 | This seems to be a Matlab limitation. 8 | -} 9 | module Foreign.Matlab.Runtime ( 10 | MLibrary, 11 | openMLibrary, 12 | closeMLibrary, 13 | mLibraryFun, 14 | mLibraryCall, 15 | 16 | mlGenericFeval 17 | ) where 18 | 19 | import Foreign hiding (unsafePerformIO) 20 | import Foreign.C.String 21 | import Foreign.C.Types 22 | import System.Posix.DynamicLinker (DL, RTLDFlags (RTLD_NOW), dlopen, dlclose, dlsym) 23 | import Data.List 24 | import qualified Data.Char 25 | import Distribution.Simple.BuildPaths (dllExtension) 26 | import Control.Concurrent.MVar 27 | import System.FilePath (splitFileName, dropExtensions, extSeparator 28 | , (<.>), ()) 29 | import Foreign.Matlab.Util 30 | import Foreign.Matlab.Internal 31 | import System.IO.Unsafe (unsafePerformIO) 32 | 33 | #include "hsc_sym.h" 34 | #include "libhsmatlab.h" 35 | 36 | initialized :: MVar Integer 37 | initialized = unsafePerformIO (newMVar 0) 38 | 39 | type InitApp = Ptr CString -> CInt -> IO CBool 40 | type TermApp = IO CBool 41 | 42 | initializeApp :: InitApp -> [String] -> IO () 43 | initializeApp init opt = modifyMVar_ initialized maybeinit where 44 | maybeinit 0 = 45 | mapWithArrayLen withCString opt $ \(optp,optn) -> do 46 | r <- init optp (ii optn) 47 | if boolC r 48 | then return 1 49 | else fail "mclInitializeApplication" 50 | maybeinit n = return $ succ n 51 | 52 | terminateApp :: TermApp -> IO () 53 | terminateApp term = modifyMVar_ initialized maybeterm where 54 | maybeterm 1 = do 55 | r <- term 56 | if boolC r 57 | then return 0 58 | else fail "mclTerminateApplication" 59 | maybeterm n = return $ pred n 60 | 61 | {- 62 | foreign import ccall unsafe mclInitializeApplication :: InitApp 63 | foreign import ccall unsafe mclTerminateApplication :: TermApp 64 | initialize = initializeApp mclInitializeApplication 65 | terminate = terminateApp mclTerminateApplication 66 | -} 67 | 68 | foreign import ccall "dynamic" mkInitApp :: FunPtr InitApp -> InitApp 69 | foreign import ccall "dynamic" mkTermApp :: FunPtr TermApp -> TermApp 70 | 71 | type InitFun = IO CBool 72 | type FiniFun = IO () 73 | type MLXFun = CInt -> Ptr MXArrayPtr -> CInt -> Ptr MXArrayPtr -> IO CBool 74 | 75 | foreign import ccall "dynamic" mkInitFun :: FunPtr InitFun -> InitFun 76 | foreign import ccall "dynamic" mkFiniFun :: FunPtr FiniFun -> FiniFun 77 | foreign import ccall "dynamic" mkMLXFun :: FunPtr MLXFun -> MLXFun 78 | 79 | -- |A Matlab library handle 80 | data MLibrary = MLibrary { mlName :: String, mlDL :: DL } 81 | 82 | -- |Open and initialize a matlab shared library. 83 | openMLibrary :: 84 | String -- ^ The name of the library, which may be a full path to the file, or simply the library name 85 | -> [String] -- ^ Arguments with which to initialize the application instance (e.g., \"-nojvm\") 86 | -> IO MLibrary 87 | openMLibrary mlname opt = do 88 | let (path, base) = splitFileName mlname 89 | name = (if isPrefixOf "lib" base then drop 3 else id) (dropExtensions base) 90 | file = (if isPrefixOf "lib" base then id else ("lib" ++)) ((if isSuffixOf dllExtension base || isInfixOf (dllExtension++[extSeparator]) base then id else (<.> dllExtension)) base) 91 | dl <- dlopen (path file) [RTLD_NOW] 92 | let ml = MLibrary name dl 93 | inia <- mkInitApp =.< dlsym dl #SYM mclInitializeApplication 94 | initializeApp inia opt 95 | --initialize opt 96 | inif <- mkInitFun =.< dlsym dl ("lib" ++ name ++ "Initialize") 97 | r <- inif 98 | if boolC r 99 | then return ml 100 | else fail ("lib" ++ name ++ "Initialize") 101 | 102 | -- |Terminate and close a matlab library. 103 | closeMLibrary :: MLibrary -> IO () 104 | closeMLibrary (MLibrary name dl) = do 105 | fini <- mkFiniFun =.< dlsym dl ("lib" ++ name ++ "Terminate") 106 | fini 107 | fina <- mkTermApp =.< dlsym dl #SYM mclTerminateApplication 108 | terminateApp fina 109 | --terminate 110 | dlclose dl 111 | 112 | makeMFun :: MLXFun -> MFun 113 | makeMFun fun arg no = 114 | mapWithArrayLen withMXArray arg $ \(argp,argn) -> 115 | allocaArray no $ \outp -> do 116 | r <- fun (ii no) outp (ii argn) argp 117 | if boolC r 118 | then peekArray no outp >>= mapM mkMXArray 119 | else fail "MFun" 120 | 121 | -- |Return a Haskell function representing the Matlab function with the given name in the given library 122 | mLibraryFun :: MLibrary -> String -> IO MFun 123 | mLibraryFun (MLibrary _ dl) fun = 124 | (makeMFun . mkMLXFun) =.< dlsym dl ("mlx" ++ Data.Char.toUpper (head fun) : tail fun) 125 | 126 | -- |Call the Matlab function with the given name in the given library directly 127 | mLibraryCall :: MLibrary -> String -> MFun 128 | mLibraryCall ml f arg no = do 129 | fun <- mLibraryFun ml f 130 | fun arg no 131 | 132 | foreign import ccall "dynamic" mkFeval :: FunPtr (CString -> MLXFun) -> CString -> MLXFun 133 | 134 | -- |Internal use only. See "Foreign.Matlab.Runtime.Generic" 135 | mlGenericFeval :: MLibrary -> IO (CString -> MFun) 136 | mlGenericFeval MLibrary{ mlName = "hsmatlab", mlDL = dl } = do 137 | fe <- mkFeval =.< dlsym dl "mlHsFeval" 138 | return $ makeMFun . fe 139 | mlGenericFeval _ = fail "mlGenericEval: use Matlab.Runtime.Generic" 140 | -------------------------------------------------------------------------------- /test/Test/Engine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Test.Engine where 6 | 7 | import Control.Exception (SomeException, assert, try) 8 | import Data.Either (isLeft, isRight, lefts) 9 | import Foreign.Matlab 10 | import Foreign.Matlab.Engine 11 | import Foreign.Matlab.Engine.Wrappers 12 | import Language.Haskell.TH (Q, runIO) 13 | import Language.Haskell.TH.Syntax (lift) 14 | import Path 15 | import Test.Util 16 | 17 | engineTests = runEngineTests "" 18 | 19 | runEngineTests :: String -> IO () 20 | runEngineTests host = do 21 | putStrLn "-- Starting engine --" 22 | eng <- newEngine host 23 | putStrLn "-- Engine created --" 24 | let testPath = repoDir testRel 25 | addpath eng testPath 26 | runLocalMatFun eng 27 | cosOfPi eng 28 | testIsMNull eng 29 | testGetFirstLast eng 30 | testAbstractValueUse eng 31 | testTypedAbstractValueUse eng 32 | testGetByteStreamFromArray eng 33 | testGetArrayFromByteStream eng 34 | testCellGet eng 35 | testClearVar eng 36 | 37 | cosOfPi :: Engine -> IO () 38 | cosOfPi eng = do 39 | putStrLn "\n-- cos pi --" 40 | x <- createMXScalar (pi :: MDouble) 41 | cosBody eng "cos" x 42 | 43 | runLocalMatFun :: Engine -> IO () 44 | runLocalMatFun eng = do 45 | putStrLn "\n-- mtest: cos pi --" 46 | x <- createMXScalar (pi :: MDouble) 47 | cosBody eng "mtest" x 48 | 49 | cosBody :: Engine -> String -> MXArray MDouble -> IO () 50 | cosBody eng cosFun x = do 51 | [y] <- engineEvalFun eng cosFun [EvalArray x] 1 52 | mxArrayClass y >>= print 53 | Just y <- castMXArray y 54 | y <- mxScalarGet y 55 | print (y :: MDouble) 56 | 57 | testIsMNull :: Engine -> IO () 58 | testIsMNull eng = do 59 | putStrLn $ "\n-- testIsMNull --" 60 | xa <- createMXScalar (1.0 :: MDouble) 61 | let xaRes = assert (isMNull xa == False) xa 62 | xaResEi <- mxArrayGetFirst xaRes 63 | putStrLn $ " xaResEi is Right: " <> (show xaResEi) 64 | xae :: MXArray MChar <- createMXArray [] 65 | freeMXArray xae 66 | mxLen <- mxArrayLength xae 67 | mxDims <- mxArraySize xae 68 | putStrLn $ "length is " <> (show mxLen) <> " dims are " <> (show $ mxDims) 69 | let xaeRes = assert (isMNull xae == False) xae 70 | xaeResEi <- mxArrayGetFirst xaeRes 71 | putStrLn $ " xaeResEi is Left: " <> (show xaeResEi) 72 | 73 | testGetFirstLast :: Engine -> IO () 74 | testGetFirstLast eng = do 75 | putStrLn $ "\n-- testGetFirstLast --" 76 | let testVal :: MDouble = 1.0 77 | xa <- createMXScalar testVal 78 | xfEi <- mxArrayGetFirst xa 79 | xlEi <- mxArrayGetLast xa 80 | let xRes = assert (xlEi == Right 1.0 && xfEi == xlEi) xfEi 81 | putStrLn $ " xRes is : " <> (show xRes) 82 | threeArray :: MXArray MDouble <- fromListIO [5.0, 6.0, 7.0] 83 | txfEi <- mxArrayGetFirst threeArray 84 | txlEi <- mxArrayGetLast threeArray 85 | let txfRes = assert (txfEi == Right 5.0) txfEi 86 | putStrLn $ " txfRes is : " <> (show txfRes) 87 | let txlRes = assert (txlEi == Right 7.0) txlEi 88 | putStrLn $ " txlRes is : " <> (show txlRes) 89 | 90 | testAbstractValueUse :: Engine -> IO () 91 | testAbstractValueUse eng = do 92 | putStrLn $ "\n-- testAbstractValueUse --" 93 | sOut <- makeTestStruct eng 94 | sSum <- useTestStruct eng sOut 95 | let sSumRes = assert (sSum == 7.0) sSum 96 | putStrLn $ " struct sum is: " <> (show sSumRes) 97 | 98 | makeTestStruct :: Engine -> IO MAnyArray 99 | makeTestStruct eng = do 100 | [res] <- engineEvalFun eng "makeTestStruct" [] 1 101 | pure res 102 | 103 | useTestStruct :: Engine -> MAnyArray -> IO MDouble 104 | useTestStruct eng sIn = do 105 | [res] <- engineEvalFun eng "useTestStruct" [EvalArray sIn] 1 106 | mxArrMay <- castMXArray res 107 | case mxArrMay of 108 | Just mxArr -> mxScalarGet mxArr 109 | Nothing -> pure 0.0 110 | 111 | 112 | newtype MyAbsType = MyAbsType { unMyAbsType :: MAnyArray } 113 | 114 | -- |Similar to testAbstractValueUse, but instead of using 115 | -- |MAnyArray, we use newtypes for better type safety 116 | testTypedAbstractValueUse :: Engine -> IO () 117 | testTypedAbstractValueUse eng = do 118 | putStrLn $ "\n-- testTypedAbstractValueUse --" 119 | sOut <- makeTestStructTyped eng 120 | sSum <- useTestStructTyped eng sOut 121 | let sSumRes = assert (sSum == 7.0) sSum 122 | putStrLn $ " struct sum is: " <> (show sSumRes) 123 | 124 | makeTestStructTyped :: Engine -> IO MyAbsType 125 | makeTestStructTyped eng = MyAbsType <$> (makeTestStruct eng) 126 | 127 | useTestStructTyped :: Engine -> MyAbsType -> IO MDouble 128 | useTestStructTyped eng (MyAbsType sIn) = useTestStruct eng sIn 129 | 130 | testGetByteStreamFromArray :: Engine -> IO () 131 | testGetByteStreamFromArray eng = do 132 | putStrLn $ "\n-- testGetByteStreamFromArray --" 133 | sOutBSMatlab <- makeTestStructByteStream eng 134 | sOut <- makeTestStruct eng 135 | Right sOutBSHaskell <- getByteStreamFromArray eng sOut 136 | let bsSum = sum $ fromIntegral <$> (assert (sOutBSMatlab == sOutBSHaskell) sOutBSHaskell) 137 | putStrLn $ " bytestream sum is: " <> (show bsSum) 138 | 139 | testGetArrayFromByteStream :: Engine -> IO () 140 | testGetArrayFromByteStream eng = do 141 | putStrLn $ "\n-- testGetArrayFromByteStream --" 142 | sOutBS <- makeTestStructByteStream eng 143 | sOutFromBS <- getArrayFromByteStream eng sOutBS 144 | sOut <- makeTestStruct eng 145 | sSumFromBS <- useTestStruct eng sOutFromBS 146 | sSum <- useTestStruct eng sOut 147 | let sSumRes = assert (sSumFromBS == sSum) sSumFromBS 148 | putStrLn $ " deserialized struct sum is: " <> (show sSumRes) 149 | 150 | makeTestStructByteStream :: Engine -> IO [MUint8] 151 | makeTestStructByteStream eng = do 152 | [res] <- engineEvalFun eng "makeTestStructByteStream" [] 1 153 | mxArrMay <- castMXArray res 154 | case mxArrMay of 155 | Just mxArr -> mxArrayGetAll mxArr 156 | Nothing -> pure [] 157 | 158 | -- TODO: display cell array and extracted values in test 159 | testCellGet :: Engine -> IO () 160 | testCellGet eng = do 161 | putStrLn "\n-- testCellGet --" 162 | [ca] <- engineEvalFun eng "mcellTest" [] 1 163 | Just (ca :: MXArray MCell) <- castMXArray ca 164 | caLen <- mxArrayLength ca 165 | let caLenMsg = assert (caLen == 6) "cell array has length 6" 166 | putStrLn caLenMsg 167 | dCells :: [MXArray MDouble] <- mxCellGetArraysOfType ca 168 | let dCellsMsg = assert (length dCells == 4) "cell array has 4 double arrays" 169 | putStrLn dCellsMsg 170 | dVals :: [MDouble] <- mxCellGetAllOfType ca 171 | let dValsMsg = assert (length dVals == 4) "cell array has 4 double values" 172 | putStrLn dValsMsg 173 | 174 | testClearVar :: Engine -> IO () 175 | testClearVar eng = do 176 | putStrLn $ "\n-- testClearVar --" 177 | let foopi = "foopi" 178 | x <- createMXScalar (pi :: MDouble) 179 | engineSetVar eng foopi x 180 | ei1 :: Either SomeException MAnyArray <- try $ engineGetVar eng foopi 181 | putStrLn $ assert (isRight ei1) " Can clearVar once" 182 | clearVar eng foopi 183 | ei2 :: Either SomeException MAnyArray <- try $ engineGetVar eng foopi 184 | putStrLn $ assert (isLeft ei2) $ 185 | " Can't clearVar twice: " <> (show $ lefts [ei2]) 186 | putStrLn " Finished testClearVar" 187 | 188 | 189 | testRel :: Path Rel Dir 190 | testRel = $(mkRelDir "test") 191 | 192 | repoDir :: Path Abs Dir 193 | repoDir = $(mkAbsDir getRepoDirStatic) 194 | -------------------------------------------------------------------------------- /Foreign/Matlab/Internal.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Foreign.Matlab.Internal ( 5 | CBool, boolC, cBool, 6 | MIO, 7 | MType(..), 8 | MXClassID, MXClass(..), 9 | MXChar, MChar, 10 | MXLogical, MLogical, 11 | MXDouble, MDouble, 12 | MXSingle, MSingle, 13 | MXInt8, MInt8, 14 | MXInt16, MInt16, 15 | MXInt32, MInt32, 16 | MXInt64, MInt64, 17 | MXUint8, MUint8, 18 | MXUint16, MUint16, 19 | MXUint32, MUint32, 20 | MXUint64, MUint64, 21 | MXArrayType, 22 | MXArrayPtr, MXArray(..), 23 | mkMXArray, withMXArray, 24 | unsafeCastMXArray, 25 | MAny, MAnyArray, 26 | MNull, mNullArray, isMNull, 27 | MCell(..), 28 | MStruct(..), mStruct, 29 | MXFun, MFun, 30 | MWSize, MWIndex, MWSignedIndex 31 | ) where 32 | 33 | import qualified Data.Map.Strict as DM 34 | 35 | 36 | import Foreign 37 | import Foreign.C.Types 38 | import qualified Data.Char 39 | import Foreign.Matlab.Optics 40 | import Foreign.Matlab.Util 41 | 42 | #include 43 | 44 | type MIO a = IO a 45 | 46 | boolC :: CBool -> Bool 47 | boolC = (0 /=) 48 | 49 | cBool :: Bool -> CBool 50 | cBool = ii . fromEnum 51 | 52 | type MXClassID = #type mxClassID 53 | data MXClass = 54 | MXClassNull 55 | | MXClassCell 56 | | MXClassStruct 57 | | MXClassLogical 58 | | MXClassChar 59 | | MXClassDouble 60 | | MXClassSingle 61 | | MXClassInt8 62 | | MXClassUint8 63 | | MXClassInt16 64 | | MXClassUint16 65 | | MXClassInt32 66 | | MXClassUint32 67 | | MXClassInt64 68 | | MXClassUint64 69 | | MXClassFun 70 | | MXClassObject 71 | deriving (Eq, Show) 72 | 73 | -- |A type equivalence between a Matlab and Haskell type 74 | class MType mx a | a -> mx where 75 | hs2mx :: a -> mx 76 | mx2hs :: mx -> a 77 | mxClassOf :: a -> MXClass 78 | 79 | instance MType MXClassID MXClass where 80 | mx2hs (#const mxVOID_CLASS) = MXClassNull 81 | mx2hs (#const mxCELL_CLASS) = MXClassCell 82 | mx2hs (#const mxSTRUCT_CLASS) = MXClassStruct 83 | mx2hs (#const mxLOGICAL_CLASS) = MXClassLogical 84 | mx2hs (#const mxCHAR_CLASS) = MXClassChar 85 | mx2hs (#const mxDOUBLE_CLASS) = MXClassDouble 86 | mx2hs (#const mxSINGLE_CLASS) = MXClassSingle 87 | mx2hs (#const mxINT8_CLASS) = MXClassInt8 88 | mx2hs (#const mxUINT8_CLASS) = MXClassUint8 89 | mx2hs (#const mxINT16_CLASS) = MXClassInt16 90 | mx2hs (#const mxUINT16_CLASS) = MXClassUint16 91 | mx2hs (#const mxINT32_CLASS) = MXClassInt32 92 | mx2hs (#const mxUINT32_CLASS) = MXClassUint32 93 | mx2hs (#const mxINT64_CLASS) = MXClassInt64 94 | mx2hs (#const mxUINT64_CLASS) = MXClassUint64 95 | mx2hs (#const mxFUNCTION_CLASS)= MXClassFun 96 | mx2hs (#const mxOBJECT_CLASS) = MXClassObject 97 | mx2hs c = error ("MXClass: unknown mxClassID " ++ show c) 98 | hs2mx MXClassNull = #const mxVOID_CLASS 99 | hs2mx MXClassCell = #const mxCELL_CLASS 100 | hs2mx MXClassStruct = #const mxSTRUCT_CLASS 101 | hs2mx MXClassLogical = #const mxLOGICAL_CLASS 102 | hs2mx MXClassChar = #const mxCHAR_CLASS 103 | hs2mx MXClassDouble = #const mxDOUBLE_CLASS 104 | hs2mx MXClassSingle = #const mxSINGLE_CLASS 105 | hs2mx MXClassInt8 = #const mxINT8_CLASS 106 | hs2mx MXClassUint8 = #const mxUINT8_CLASS 107 | hs2mx MXClassInt16 = #const mxINT16_CLASS 108 | hs2mx MXClassUint16 = #const mxUINT16_CLASS 109 | hs2mx MXClassInt32 = #const mxINT32_CLASS 110 | hs2mx MXClassUint32 = #const mxUINT32_CLASS 111 | hs2mx MXClassInt64 = #const mxINT64_CLASS 112 | hs2mx MXClassUint64 = #const mxUINT64_CLASS 113 | hs2mx MXClassFun = #const mxFUNCTION_CLASS 114 | hs2mx MXClassObject = #const mxOBJECT_CLASS 115 | mxClassOf _ = error "mxClassOf: no class for MXClassID" 116 | 117 | type MXChar = #type mxChar 118 | type MChar = Char 119 | instance MType MXChar MChar where 120 | hs2mx = ii . Data.Char.ord 121 | mx2hs = Data.Char.chr . ii 122 | mxClassOf _ = MXClassChar 123 | 124 | type MXLogical = CBool 125 | type MLogical = Bool 126 | instance MType MXLogical MLogical where 127 | hs2mx = cBool 128 | mx2hs = boolC 129 | mxClassOf _ = MXClassLogical 130 | 131 | type MXDouble = Double 132 | type MDouble = Double 133 | instance MType MXDouble MDouble where 134 | hs2mx = id 135 | mx2hs = id 136 | mxClassOf _ = MXClassDouble 137 | type MXSingle = Float 138 | type MSingle = Float 139 | instance MType MXSingle MSingle where 140 | hs2mx = id 141 | mx2hs = id 142 | mxClassOf _ = MXClassSingle 143 | 144 | #let inttype u, v, n = "\ 145 | type MX%s%u = %s%u\r\n\ 146 | type M%s%u = %s%u\r\n\ 147 | instance MType MX%s%u M%s%u where { hs2mx = id ; mx2hs = id ; mxClassOf _ = MXClass%s%u }\ 148 | ", u, n, v, n, u, n, v, n, u, n, u, n, u, n 149 | 150 | #inttype "Int", "Int", 8 151 | #inttype "Int", "Int", 16 152 | #inttype "Int", "Int", 32 153 | #inttype "Int", "Int", 64 154 | #inttype "Uint", "Word", 8 155 | #inttype "Uint", "Word", 16 156 | #inttype "Uint", "Word", 32 157 | #inttype "Uint", "Word", 64 158 | 159 | data MXArrayType 160 | type MXArrayPtr = Ptr MXArrayType 161 | 162 | -- |The general Matlab Array type, used for most all Matlab data 163 | newtype MXArray a = MXArray { mxArray :: MXArrayPtr } 164 | 165 | mkMXArray :: MXArrayPtr -> IO (MXArray a) 166 | mkMXArray = return . MXArray 167 | 168 | withMXArray :: With (MXArray x) MXArrayPtr a 169 | withMXArray (MXArray a) f = f a 170 | 171 | unsafeCastMXArray :: MXArray a -> MXArray b 172 | unsafeCastMXArray = MXArray . castPtr . mxArray 173 | 174 | -- |Determine whether the given array is NULL 175 | isMNull :: MXArray a -> Bool 176 | isMNull (MXArray a) = nullPtr == a 177 | 178 | -- |Tag for a generic array 179 | data MAny 180 | -- |A generic, untyped (void) array, which must be cast (using 'Foreign.Matlab.Array.castMXArray') 181 | type MAnyArray = MXArray MAny 182 | 183 | -- |Tag for a NULL array 184 | data MNull 185 | instance MType MNull MNull where 186 | hs2mx = id 187 | mx2hs = id 188 | mxClassOf _ = MXClassNull 189 | 190 | mNullArray :: MXArray MNull 191 | mNullArray = MXArray nullPtr 192 | 193 | -- |A wrapper for a member of a cell array, which itself simply any other array 194 | newtype MCell = MCell { mCell :: MAnyArray } 195 | instance MType MCell MCell where 196 | hs2mx = id 197 | mx2hs = id 198 | mxClassOf _ = MXClassCell 199 | 200 | -- |A single struct in an array, represented by an (ordered) list of key-value pairs 201 | newtype MStruct = MStruct { _mStruct :: DM.Map String MAnyArray } 202 | instance MType MStruct MStruct where 203 | hs2mx = id 204 | mx2hs = id 205 | mxClassOf _ = MXClassStruct 206 | 207 | mStruct :: Iso' MStruct (DM.Map String MAnyArray) 208 | mStruct = coerced 209 | 210 | type MXFun = CInt -> Ptr MXArrayPtr -> CInt -> Ptr MXArrayPtr -> IO () 211 | -- |A Matlab function 212 | type MFun = 213 | [MAnyArray] -- ^ RHS input arguments 214 | -> Int -- ^ LHS output argument count 215 | -> IO [MAnyArray] -- ^ LHS output arguments 216 | instance MType MXFun MFun where 217 | hs2mx fun outn outp argn argp = do 218 | arg <- map MXArray =.< peekArray (ii argn) argp 219 | out <- fun arg (ii outn) 220 | pokeArray outp $ map mxArray out 221 | mx2hs fun arg no = 222 | withArrayLen (map mxArray arg) $ \argn argp -> 223 | allocaArray no $ \outp -> do 224 | fun (ii no) outp (ii argn) argp 225 | map MXArray =.< peekArray no outp 226 | mxClassOf _ = MXClassFun 227 | 228 | #ifdef mingw32_HOST_OS 229 | type MWSize = Word32 230 | type MWIndex = Word32 231 | type MWSignedIndex = Int32 232 | #else 233 | type MWSize = #type mwSize 234 | type MWIndex = #type mwIndex 235 | type MWSignedIndex = #type mwSignedIndex 236 | #endif 237 | -------------------------------------------------------------------------------- /Foreign/Matlab/Array/IMX.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Safe immutable intermediate (functional) Matlab data structures. 3 | 4 | This provides an alternative representation of Matlab data structures which can be marshalled to and from 'MXArray'. 5 | An instance of 'Show' is provided which creates Matlab expressions. 6 | -} 7 | module Foreign.Matlab.Array.IMX ( 8 | IMXData(..), 9 | IMXArray, 10 | IMXArrayElem (imxConstr, imxArray), 11 | 12 | -- * Interface with "Foreign.Matlab.Array" 13 | imxData, iMXData, 14 | imxFun, iMXFun, 15 | withIMXData, takeIMXData, 16 | withIMXDataList, 17 | 18 | -- * Construction and access 19 | imxSize, 20 | listIMX, scalarIMX, 21 | imxList, imxScalar, 22 | listIMXStruct, 23 | imxStructList 24 | ) where 25 | 26 | import Control.Monad 27 | import Data.Array.IArray 28 | import Data.Complex 29 | import Data.List 30 | import qualified Data.Map.Strict as DM 31 | import Foreign.Matlab.Util 32 | import Foreign.Matlab.Internal 33 | import Foreign.Matlab.Types 34 | import Foreign.Matlab.Array 35 | 36 | type IMXArray a = Array MIndex a 37 | -- |The basic immutable (functional) representation of Matlab data structures, representing a generic 'MXArray' 38 | data IMXData = 39 | IMXNull 40 | | IMXCell (IMXArray IMXData) 41 | | IMXStruct [String] (Array (MIndex,Int) IMXData) -- ^ field name list and array mapping (index,field index) to values 42 | | IMXLogical (IMXArray MLogical) 43 | | IMXChar (IMXArray MChar) 44 | | IMXDouble (IMXArray MDouble) 45 | | IMXSingle (IMXArray MSingle) 46 | | IMXInt8 (IMXArray MInt8) 47 | | IMXUint8 (IMXArray MUint8) 48 | | IMXInt16 (IMXArray MInt16) 49 | | IMXUint16 (IMXArray MUint16) 50 | | IMXInt32 (IMXArray MInt32) 51 | | IMXUint32 (IMXArray MUint32) 52 | | IMXInt64 (IMXArray MInt64) 53 | | IMXUint64 (IMXArray MUint64) 54 | | IMXComplexDouble (IMXArray (MComplex MDouble)) 55 | | IMXComplexSingle (IMXArray (MComplex MSingle)) 56 | | IMXObject String IMXData -- ^ object class name and object data, currently always IMXStruct 57 | deriving (Eq) 58 | 59 | type IMXFun = [IMXData] -> Int -> IO [IMXData] 60 | 61 | fixMSize :: MSize -> [a] -> MSize 62 | fixMSize s l = maybe s (\i -> replaceIndex s i (length l `div` negate (product s))) $ elemIndex (-1) s 63 | 64 | -- |Create an sized array for 'IMXData' from a sequential list of elements. 'MSize' may contain at most one -1 value, which will be inferred from the length of the list. 65 | listIMXArray :: MSize -> [e] -> IMXArray e 66 | listIMXArray s l = listArray (mSizeRange (fixMSize s l)) l 67 | 68 | -- |Create a scalar (array) for 'IMXData' 69 | scalarIMXArray :: e -> IMXArray e 70 | scalarIMXArray e = listIMXArray [] [e] 71 | 72 | class IMXArrayElem a where 73 | -- |Generic 'IMXData' 'IMXArray' constructor 74 | imxConstr :: IMXArray a -> IMXData 75 | -- |Generic 'IMXData' 'IMXArray' accessor 76 | imxArray :: IMXData -> Maybe (IMXArray a) 77 | instance IMXArrayElem IMXData where { imxConstr = IMXCell ; imxArray (IMXCell a) = Just a ; imxArray _ = Nothing } 78 | instance IMXArrayElem MLogical where { imxConstr = IMXLogical ; imxArray (IMXLogical a) = Just a ; imxArray _ = Nothing } 79 | instance IMXArrayElem MChar where { imxConstr = IMXChar ; imxArray (IMXChar a) = Just a ; imxArray _ = Nothing } 80 | instance IMXArrayElem MDouble where { imxConstr = IMXDouble ; imxArray (IMXDouble a) = Just a ; imxArray _ = Nothing } 81 | instance IMXArrayElem MSingle where { imxConstr = IMXSingle ; imxArray (IMXSingle a) = Just a ; imxArray _ = Nothing } 82 | instance IMXArrayElem MInt8 where { imxConstr = IMXInt8 ; imxArray (IMXInt8 a) = Just a ; imxArray _ = Nothing } 83 | instance IMXArrayElem MUint8 where { imxConstr = IMXUint8 ; imxArray (IMXUint8 a) = Just a ; imxArray _ = Nothing } 84 | instance IMXArrayElem MInt16 where { imxConstr = IMXInt16 ; imxArray (IMXInt16 a) = Just a ; imxArray _ = Nothing } 85 | instance IMXArrayElem MUint16 where { imxConstr = IMXUint16 ; imxArray (IMXUint16 a) = Just a ; imxArray _ = Nothing } 86 | instance IMXArrayElem MInt32 where { imxConstr = IMXInt32 ; imxArray (IMXInt32 a) = Just a ; imxArray _ = Nothing } 87 | instance IMXArrayElem MUint32 where { imxConstr = IMXUint32 ; imxArray (IMXUint32 a) = Just a ; imxArray _ = Nothing } 88 | instance IMXArrayElem MInt64 where { imxConstr = IMXInt64 ; imxArray (IMXInt64 a) = Just a ; imxArray _ = Nothing } 89 | instance IMXArrayElem MUint64 where { imxConstr = IMXUint64 ; imxArray (IMXUint64 a) = Just a ; imxArray _ = Nothing } 90 | instance IMXArrayElem (MComplex MDouble) where { imxConstr = IMXComplexDouble ; imxArray (IMXComplexDouble a) = Just a ; imxArray _ = Nothing } 91 | instance IMXArrayElem (MComplex MSingle) where { imxConstr = IMXComplexSingle ; imxArray (IMXComplexSingle a) = Just a ; imxArray _ = Nothing } 92 | 93 | -- |Generic 'IMXData' list constructor. Specified 'MSize' may contain at most one -1 value, which will be inferred from the length of the list. 94 | listIMX :: IMXArrayElem a => MSize -> [a] -> IMXData 95 | listIMX s = imxConstr . listIMXArray s 96 | -- |Generic 'IMXData' scalar constructor 97 | scalarIMX :: IMXArrayElem a => a -> IMXData 98 | scalarIMX = imxConstr . scalarIMXArray 99 | --emptyIMX :: IMXArrayElem a => a -> IMXData 100 | --emptyIMX a = listIMX [0] ([] `asTypeOf` [a]) 101 | 102 | -- |Generic 'IMXData' array size accessor 103 | imxSize :: IMXData -> MSize 104 | imxSize IMXNull = [0] 105 | imxSize (IMXCell a) = mRangeSize (bounds a) 106 | imxSize (IMXLogical a) = mRangeSize (bounds a) 107 | imxSize (IMXChar a) = mRangeSize (bounds a) 108 | imxSize (IMXDouble a) = mRangeSize (bounds a) 109 | imxSize (IMXSingle a) = mRangeSize (bounds a) 110 | imxSize (IMXInt8 a) = mRangeSize (bounds a) 111 | imxSize (IMXUint8 a) = mRangeSize (bounds a) 112 | imxSize (IMXInt16 a) = mRangeSize (bounds a) 113 | imxSize (IMXUint16 a) = mRangeSize (bounds a) 114 | imxSize (IMXInt32 a) = mRangeSize (bounds a) 115 | imxSize (IMXUint32 a) = mRangeSize (bounds a) 116 | imxSize (IMXInt64 a) = mRangeSize (bounds a) 117 | imxSize (IMXUint64 a) = mRangeSize (bounds a) 118 | imxSize (IMXComplexDouble a) = mRangeSize (bounds a) 119 | imxSize (IMXComplexSingle a) = mRangeSize (bounds a) 120 | imxSize (IMXStruct _ a) = mRangeSize (r0,r1) where ((r0,_),(r1,_)) = bounds a 121 | imxSize (IMXObject _ d) = imxSize d 122 | 123 | -- |Generic 'IMXData' list accessor 124 | imxList :: IMXArrayElem a => IMXData -> Maybe [a] 125 | imxList = fmap elems . imxArray 126 | -- |Generic 'IMXData' scalar accessor 127 | imxScalar :: IMXArrayElem a => IMXData -> Maybe a 128 | imxScalar a = case imxList a of 129 | Just [x] -> Just x 130 | _ -> Nothing 131 | 132 | -- |Create a sized struct array from a sequential list of consecutive field values (@[i0f0,i0f1,...,i0fM,i1f0,i1f1,....,iNfM]@). 133 | listIMXStruct :: [String] -> MSize -> [IMXData] -> IMXData 134 | listIMXStruct f s l = IMXStruct f $ listArray r l where 135 | n = length f 136 | r = ((r0,0),(r1,pred n)) 137 | (r0,r1) = mSizeRange $ tail $ fixMSize (n:s) l 138 | 139 | -- |Access a struct as list of fields and list of consecutive field values 140 | imxStructList :: IMXData -> Maybe ([String], [IMXData]) 141 | imxStructList (IMXStruct f v) = Just (f, elems v) 142 | imxStructList _ = Nothing 143 | 144 | -- |Create an immutable representation from an 'MXArray' 145 | imxData :: MXArray a -> IO IMXData 146 | imxData a = do 147 | t <- mxArrayClass a 148 | c <- if t /= MXClassNull then mxArrayIsComplex a else return undefined 149 | imxc t c where 150 | 151 | imxc :: MXClass -> Bool -> IO IMXData 152 | imxc MXClassNull _ = return IMXNull 153 | imxc MXClassCell False = IMXCell =.< imxa (imxData . mCell) 154 | imxc MXClassStruct False = do 155 | s <- mxArraySize a' 156 | fv <- mxArrayGetAll a' 157 | f <- if null fv then mStructFields a' else return (map fst (DM.toList $ _mStruct (head fv))) 158 | listIMXStruct f s =.< mapM imxData (concatMap (map snd . DM.toList . _mStruct) fv) 159 | imxc MXClassLogical False = IMXLogical =.< imxa return 160 | imxc MXClassChar False = IMXChar =.< imxa return 161 | imxc MXClassDouble False = IMXDouble =.< imxa return 162 | imxc MXClassSingle False = IMXSingle =.< imxa return 163 | imxc MXClassInt8 False = IMXInt8 =.< imxa return 164 | imxc MXClassUint8 False = IMXUint8 =.< imxa return 165 | imxc MXClassInt16 False = IMXInt16 =.< imxa return 166 | imxc MXClassUint16 False = IMXUint16 =.< imxa return 167 | imxc MXClassInt32 False = IMXInt32 =.< imxa return 168 | imxc MXClassUint32 False = IMXUint32 =.< imxa return 169 | imxc MXClassInt64 False = IMXInt64 =.< imxa return 170 | imxc MXClassUint64 False = IMXUint64 =.< imxa return 171 | imxc MXClassDouble True = IMXComplexDouble =.< imxa return 172 | imxc MXClassSingle True = IMXComplexSingle =.< imxa return 173 | imxc MXClassObject False = do 174 | Just c <- mObjectGetClass a' 175 | IMXObject c =.< imxc MXClassStruct False 176 | imxc t c = fail ("imxData: unhandled mxArray type " ++ show t ++ if c then "(complex)" else "") 177 | 178 | imxa :: MXArrayComponent a => (a -> IO b) -> IO (IMXArray b) 179 | imxa f = do 180 | s <- mxArraySize a' 181 | listIMXArray s =.< mapM f =<< mxArrayGetAll a' 182 | 183 | a' = unsafeCastMXArray a 184 | 185 | -- |Create a new 'MXArray' from a functional representation. 186 | iMXData :: IMXData -> IO MAnyArray 187 | iMXData = imxd where 188 | imxd :: IMXData -> IO MAnyArray 189 | imxd IMXNull = return $ anyMXArray mNullArray 190 | imxd (IMXCell a) = imxa a (MCell .=< iMXData) 191 | imxd (IMXStruct f a) = do 192 | let ((r0,_),(r1,_)) = bounds a 193 | m <- createStruct (mRangeSize (r0,r1)) f 194 | zipWithM_ (\i -> mStructSetFields m (mOffset i) <=< mapM iMXData) [0..] (segment (length f) (elems a)) 195 | return $ anyMXArray m 196 | imxd (IMXLogical a) = imxa a return 197 | imxd (IMXChar a) = imxa a return 198 | imxd (IMXDouble a) = imxa a return 199 | imxd (IMXSingle a) = imxa a return 200 | imxd (IMXInt8 a) = imxa a return 201 | imxd (IMXUint8 a) = imxa a return 202 | imxd (IMXInt16 a) = imxa a return 203 | imxd (IMXUint16 a) = imxa a return 204 | imxd (IMXInt32 a) = imxa a return 205 | imxd (IMXUint32 a) = imxa a return 206 | imxd (IMXInt64 a) = imxa a return 207 | imxd (IMXUint64 a) = imxa a return 208 | imxd (IMXComplexDouble a) = imxa a return 209 | imxd (IMXComplexSingle a) = imxa a return 210 | imxd (IMXObject c a) = do 211 | m <- imxd a 212 | mObjectSetClass (unsafeCastMXArray m) c 213 | return m 214 | 215 | imxa :: MXArrayComponent b => IMXArray a -> (a -> IO b) -> IO MAnyArray 216 | imxa a f = do 217 | m <- createMXArray (mRangeSize (bounds a)) 218 | mxArraySetAll m =<< mapM f (elems a) 219 | return $ anyMXArray m 220 | 221 | withIMXData :: IMXData -> (MAnyArray -> IO a) -> IO a 222 | withIMXData d f = do 223 | a <- iMXData d 224 | r <- f a 225 | freeMXArray a 226 | return r 227 | 228 | withIMXDataList :: [IMXData] -> ([MAnyArray] -> IO a) -> IO a 229 | withIMXDataList = mapWith withIMXData 230 | 231 | takeIMXData :: MXArray a -> IO IMXData 232 | takeIMXData a = do 233 | d <- imxData a 234 | freeMXArray a 235 | return d 236 | 237 | imxFun :: MFun -> IMXFun 238 | imxFun fun a no = 239 | mapWith withIMXData a $ \m -> 240 | fun m no >>= mapM takeIMXData 241 | 242 | iMXFun :: IMXFun -> MFun 243 | iMXFun fun a no = do 244 | ia <- mapM imxData a 245 | fun ia no >>= mapM iMXData 246 | 247 | 248 | showsApp :: String -> ShowS -> ShowS 249 | showsApp f a s = f ++ '(' : a (')' : s) 250 | 251 | {- 252 | showsReshape :: (MIndex,MIndex) -> ShowS -> ShowS 253 | showsReshape (MSubs [],MSubs []) a s = a s 254 | showsReshape (MSubs [],MSubs []) a s = a s 255 | showsReshape r a s = "reshape(" ++ a (',' : shows (realMSize $ mRangeSize r) (')' : s)) 256 | 257 | showsIMXArrayDelimWith :: (Char,Char,Char) -> (a -> ShowS) -> IMXArray a -> ShowS 258 | showsIMXArrayDelimWith d f a = showsReshape (bounds a) $ showsMListWith d f (elems a) 259 | showsIMXArrayWith :: (a -> ShowS) -> IMXArray a -> ShowS 260 | showsIMXArrayWith = showsIMXArrayDelimWith ('[',',',']') 261 | showsIMXArray :: Show a => IMXArray a -> ShowS 262 | showsIMXArray = showsIMXArrayWith shows 263 | -} 264 | 265 | showsMList :: (Char,Char,Char) -> (a -> ShowS) -> [a] -> ShowS 266 | showsMList (l,_,r) _ [] s = l : r : s 267 | showsMList (l,d,r) f (x:xs) s = l : f x (shml xs) where 268 | shml [] = r : s 269 | shml (x:xs) = d : f x (shml xs) 270 | 271 | showsReshape :: MSize -> (Char -> ShowS) -> ShowS 272 | showsReshape [] f s = f ' ' s 273 | showsReshape [_] f s = f ';' s 274 | showsReshape [1,_] f s = f ',' s 275 | showsReshape z f s = "reshape(" ++ f ' ' (',' : showsMList ('[',' ',']') shows (realMSize z) (')' : s)) 276 | 277 | showsIMXGenArray :: (Char,Char) -> (a -> ShowS) -> IMXArray a -> ShowS 278 | showsIMXGenArray (l,r) f a = showsReshape (mRangeSize $ bounds a) $ \d -> showsMList (l,d,r) f (elems a) 279 | showsIMXArrayWith :: (a -> ShowS) -> IMXArray a -> ShowS 280 | showsIMXArrayWith = showsIMXGenArray ('[',']') 281 | showsIMXArray :: Show a => IMXArray a -> ShowS 282 | showsIMXArray = showsIMXArrayWith shows 283 | 284 | showsComplex :: (Show a, RealFloat a) => Complex a -> ShowS 285 | showsComplex (x:+y) s = "complex(" ++ shows x (',' : shows y (')' : s)) 286 | 287 | showsMString :: String -> ShowS 288 | showsMString s = showChar '\'' . showString s . showChar '\'' 289 | 290 | showsIMX :: IMXData -> ShowS 291 | showsIMX IMXNull = showString "[]" 292 | showsIMX (IMXCell a) = showsIMXGenArray ('{','}') shows a 293 | showsIMX (IMXStruct f a) = showsReshape (mRangeSize (r0,r1)) $ \d -> 294 | showString "struct" . showsMList ('(',',',')') (shf d) (zip f v) where 295 | shf d (f,v) s = showsMString f $ ',' : showsMList ('{',d,'}') showsIMX v s 296 | v = transpose $ segment (length f) $ elems a 297 | ((r0,_),(r1,_)) = bounds a 298 | showsIMX (IMXLogical a) = showsApp "logical" $ showsIMXArray a 299 | showsIMX (IMXChar a) = showsApp "char" $ showsIMXArray a 300 | showsIMX (IMXDouble a) = showsIMXArray a 301 | showsIMX (IMXSingle a) = showsApp "single" $ showsIMXArray a 302 | showsIMX (IMXInt8 a) = showsApp "int8" $ showsIMXArray a 303 | showsIMX (IMXUint8 a) = showsApp "uint8" $ showsIMXArray a 304 | showsIMX (IMXInt16 a) = showsApp "int16" $ showsIMXArray a 305 | showsIMX (IMXUint16 a) = showsApp "uint16" $ showsIMXArray a 306 | showsIMX (IMXInt32 a) = showsApp "int32" $ showsIMXArray a 307 | showsIMX (IMXUint32 a) = showsApp "uint32" $ showsIMXArray a 308 | showsIMX (IMXInt64 a) = showsApp "int64" $ showsIMXArray a 309 | showsIMX (IMXUint64 a) = showsApp "uint64" $ showsIMXArray a 310 | showsIMX (IMXComplexDouble a) = showsIMXArrayWith showsComplex a 311 | showsIMX (IMXComplexSingle a) = showsApp "single" $ showsIMXArrayWith showsComplex a 312 | showsIMX (IMXObject c a) = showsApp "class" $ showsIMX a . showChar ',' . showsMString c 313 | 314 | instance Show IMXData where 315 | showsPrec _ = showsIMX 316 | -------------------------------------------------------------------------------- /Foreign/Matlab/Array.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-} 2 | {-| 3 | Array access, including cell arrays and structures. 4 | 5 | Functions here are primarily thin wrappers to the underlying Matlab functions, and the same memory-management semantics hold. 6 | In particular, created arrays must be freed, 'copyMXArray' and 'freeMXArray' are deep operations, other set operations do not make copies. 7 | -} 8 | 9 | module Foreign.Matlab.Array ( 10 | -- * Array manipulation 11 | anyMXArray, 12 | MNullArray, castMNull, 13 | mxArrayClass, 14 | mxArrayIsComplex, 15 | mxArraySize, 16 | mxArraySetSize, 17 | mxArrayLength, 18 | freeMXArray, 19 | copyMXArray, 20 | mIndexOffset, 21 | 22 | -- * Array element access 23 | MXArrayComponent (mxArrayGetOffset, mxArraySetOffset 24 | , mxArrayGetOffsetList, mxArraySetOffsetList 25 | , mxScalarGet, isMXScalar 26 | , createMXArray, createMXScalar 27 | , createColVector, createRowVector), 28 | castMXArray, 29 | -- | array element access 30 | mxArrayGet, mxArraySet, 31 | -- | array list access 32 | mxArrayGetList, mxArraySetList, 33 | mxArrayGetAll, mxArraySetAll, 34 | mxArrayGetOffsetSafe, mxArrayGetFirst, mxArrayGetLast, 35 | -- mxArrayGetSafe, --TODO-- 36 | fromListIO, cellFromListsIO, 37 | isMNull, 38 | 39 | -- * Struct access 40 | -- |Structs in Matlab are always arrays, and so can be accessed using most array accessors. 41 | -- |However, the modification functions such as 'mxArraySet' are not implemented because they could disrupt field data in the entire struct array, and so some specialized functions are necessary. 42 | MStructArray, 43 | createStruct, 44 | mStructFields, 45 | mStructGet, mStructSet, 46 | mStructSetFields, 47 | mStructAddField, mStructRemoveField, 48 | mxCellGetAllOfType, mxCellGetArraysOfType, 49 | 50 | -- ** Object access 51 | -- |Some structs are also validated (blessed) user objects. 52 | mObjectGetClass, mObjectSetClass 53 | ) where 54 | 55 | import Control.Monad 56 | import Data.Foldable (toList) 57 | import Foreign 58 | import Foreign.C.String 59 | import Foreign.C.Types 60 | import Data.Complex 61 | import qualified Data.Map.Strict as DM 62 | import Data.Maybe (catMaybes) 63 | import Foreign.Matlab.Util 64 | import Foreign.Matlab.Internal 65 | import Foreign.Matlab.Types 66 | 67 | #include 68 | 69 | -- |(Un)cast an array to a generic type. 70 | anyMXArray :: MXArray a -> MAnyArray 71 | anyMXArray a = unsafeCastMXArray a 72 | 73 | -- |A NULL (empty) array 74 | type MNullArray = MXArray MNull 75 | -- |Safely cast a generic array to a NULL array, or return Nothing if the array is not NULL 76 | castMNull :: MAnyArray -> MIO (Maybe MNullArray) 77 | castMNull a 78 | | isMNull a = pure $ Just (unsafeCastMXArray a) 79 | | otherwise = pure Nothing 80 | 81 | foreign import ccall unsafe mxGetClassID :: MXArrayPtr -> IO MXClassID 82 | -- |Return the representation of the type of the elements of an array 83 | mxArrayClass :: MXArray a -> IO MXClass 84 | mxArrayClass a 85 | | isMNull a = pure $ MXClassNull 86 | | otherwise = withMXArray a mxGetClassID >.= mx2hs 87 | 88 | ndims :: MWSize -> Ptr MWSize -> IO MSize 89 | ndims n s = map ii =.< peekArray (ii n) s 90 | --nsubs = ndims 91 | 92 | withNSubs :: With MSubs (MWSize, Ptr MWSize) (IO a) 93 | withNSubs l f = withArrayLen (map ii l) (\l a -> f (ii l, a)) 94 | withNDims :: With MSize (MWSize, Ptr MWSize) (IO a) 95 | withNDims = withNSubs . realMSize 96 | 97 | foreign import ccall unsafe mxGetNumberOfDimensions :: MXArrayPtr -> IO MWSize 98 | foreign import ccall unsafe mxGetDimensions :: MXArrayPtr -> IO (Ptr MWSize) 99 | -- |Get the size (dimensions) of an array 100 | mxArraySize :: MXArray a -> MIO MSize 101 | mxArraySize a = withMXArray a $ \a -> do 102 | n <- mxGetNumberOfDimensions a 103 | s <- mxGetDimensions a 104 | ndims n s 105 | 106 | foreign import ccall unsafe mxSetDimensions :: MXArrayPtr -> Ptr MWSize -> MWSize -> IO CInt 107 | -- |Set dimension array and number of dimensions 108 | mxArraySetSize :: MXArray a -> MSize -> IO () 109 | mxArraySetSize a s = do 110 | r <- withMXArray a (\a -> withNDims s (\(nd,d) -> mxSetDimensions a d nd)) 111 | when (r /= 0) $ fail "mxArraySetSize" 112 | 113 | foreign import ccall unsafe mxGetNumberOfElements :: MXArrayPtr -> IO CSize 114 | -- |Like `numel` in MATLAB. 115 | mxArrayLength :: MXArray a -> MIO Int 116 | mxArrayLength a = ii =.< withMXArray a mxGetNumberOfElements 117 | 118 | foreign import ccall unsafe mxCalcSingleSubscript :: MXArrayPtr -> MWSize -> Ptr MWIndex -> IO MWIndex 119 | -- |Convert an array subscript into an offset 120 | mIndexOffset :: MXArray a -> MIndex -> MIO Int 121 | mIndexOffset _ (MSubs []) = pure 0 122 | mIndexOffset _ (MSubs [i]) = pure i 123 | mIndexOffset a (MSubs i) = ii =.< withMXArray a (withNSubs i . uncurry . mxCalcSingleSubscript) 124 | 125 | foreign import ccall unsafe mxDuplicateArray :: MXArrayPtr -> IO MXArrayPtr 126 | -- |Make a deep copy of an array 127 | copyMXArray :: MXArray a -> MIO (MXArray a) 128 | copyMXArray a = withMXArray a mxDuplicateArray >>= mkMXArray 129 | 130 | foreign import ccall unsafe mxDestroyArray :: MXArrayPtr -> IO () 131 | -- |Destroy an array and all of its contents. 132 | freeMXArray :: MXArray a -> MIO () 133 | freeMXArray a = do 134 | withMXArray a mxDestroyArray 135 | mxArraySetSize a [0, 0] 136 | 137 | -- | Create and populate an MXArray in one go. Named without 'mx' due to possible 138 | -- | conformity to a typeclass function. 139 | fromListIO :: (Foldable t, MXArrayComponent a) => t a -> MIO (MXArray a) 140 | fromListIO xs = do 141 | arr <- createMXArray [length xs] 142 | mxArraySetAll arr xsList 143 | pure arr 144 | where 145 | xsList = toList xs 146 | 147 | -- | Like fromListIO but wraps elements in a cell. Most useful for converting a list of strings 148 | -- | to a MATLAB cell array of strings. Named in conjunction with `fromListIO`, which is used 149 | -- | as part of the implementation. 150 | cellFromListsIO :: (Traversable s, Foldable t, MXArrayComponent a) => s (t a) -> MIO (MXArray MCell) 151 | cellFromListsIO xss = do 152 | listOfStructArrays <- sequence $ fromListIO <$> xss 153 | arr <- createMXArray [length xss] 154 | mxArraySetAll arr (toList $ (MCell . anyMXArray) <$> listOfStructArrays) 155 | pure arr 156 | 157 | -- |The class of standardly typeable array elements 158 | class MXArrayComponent a where 159 | -- |Determine whether the given array is of the correct type 160 | isMXArray :: MXArray a -> MIO Bool 161 | -- |Create an array and initialize all its data elements to some default value, usually 0 or [] 162 | createMXArray :: MSize -> MIO (MXArray a) 163 | 164 | -- |Determine if an array is singleton. Equivalent to 165 | -- 166 | -- > liftM (all (1 ==)) . mxArraySize 167 | isMXScalar :: MXArray a -> MIO Bool 168 | 169 | mxArrayGetOffset :: MXArray a -> Int -> MIO a 170 | mxArraySetOffset :: MXArray a -> Int -> a -> MIO () 171 | 172 | mxArrayGetOffsetList :: MXArray a -> Int -> Int -> MIO [a] 173 | mxArraySetOffsetList :: MXArray a -> Int -> [a] -> MIO () 174 | 175 | -- |Get the value of the first data element in an array or, more specifically, the value that the array will be interpreted as in scalar context 176 | mxScalarGet :: MXArray a -> MIO a 177 | 178 | -- |Create a singleton (scalar) array having the specified value 179 | createMXScalar :: a -> MIO (MXArray a) 180 | -- |Create a column vector from the given list. 181 | createColVector :: [a] -> MIO (MXArray a) 182 | -- |Create a row vector from the given list. 183 | createRowVector :: [a] -> MIO (MXArray a) 184 | 185 | isMXArray _ = pure False 186 | isMXScalar a = liftM2 (&&) (isMXArray a) (all (1 ==) =.< mxArraySize a) 187 | 188 | mxArrayGetOffsetList a o n = mapM (mxArrayGetOffset a) [o..o+n-1] 189 | mxArraySetOffsetList a o = zipWithM_ (mxArraySetOffset a . (o+)) [0..] 190 | 191 | mxScalarGet a = mxArrayGetOffset a 0 192 | 193 | createMXScalar x = do 194 | a <- createMXArray [1] 195 | mxArraySetOffset a 0 x 196 | pure a 197 | createRowVector l = do 198 | a <- createMXArray [1,length l] 199 | mxArraySetOffsetList a 0 l 200 | pure a 201 | createColVector l = do 202 | a <- createMXArray [length l] 203 | mxArraySetOffsetList a 0 l 204 | pure a 205 | 206 | -- |Get the value of the specified array element. Does not check bounds. 207 | mxArrayGet :: MXArrayComponent a => MXArray a -> MIndex -> MIO a 208 | mxArrayGet a i = mIndexOffset a i >>= mxArrayGetOffset a 209 | -- |Set an element in an array to the specified value. Does not check bounds. 210 | mxArraySet :: MXArrayComponent a => MXArray a -> MIndex -> a -> MIO () 211 | mxArraySet a i v = do 212 | o <- mIndexOffset a i 213 | mxArraySetOffset a o v 214 | 215 | -- |@'mxArrayGetList' a i n@ gets the sequential list of @n@ items from array @a@ starting at index @i@. Does not check bounds. 216 | mxArrayGetList :: MXArrayComponent a => MXArray a -> MIndex -> Int -> MIO [a] 217 | mxArrayGetList a i n = do 218 | o <- mIndexOffset a i 219 | n <- if n == -1 then subtract o =.< mxArrayLength a else pure n 220 | mxArrayGetOffsetList a o n 221 | -- |@'mxArraySetList' a i l@ sets the sequential items in array @a@ starting at index @i@ to @l@. Does not check bounds. 222 | mxArraySetList :: MXArrayComponent a => MXArray a -> MIndex -> [a] -> MIO () 223 | mxArraySetList a i l = do 224 | o <- mIndexOffset a i 225 | mxArraySetOffsetList a o l 226 | 227 | -- |Get a flat list of all elements in the array. 228 | mxArrayGetAll :: MXArrayComponent a => MXArray a -> IO [a] 229 | mxArrayGetAll a = mxArrayGetList a mStart (-1) 230 | 231 | -- |Set a flat list of all elements in the array. 232 | mxArraySetAll :: MXArrayComponent a => MXArray a -> [a] -> IO () 233 | mxArraySetAll a = mxArraySetList a mStart 234 | 235 | mxArrayGetFirst :: MXArrayComponent a => MXArray a -> MIO (Either String a) 236 | mxArrayGetFirst arr = mxArrayGetOffsetSafe arr 0 237 | 238 | mxArrayGetLast :: MXArrayComponent a => MXArray a -> MIO (Either String a) 239 | mxArrayGetLast arr = do 240 | arrLen <- mxArrayLength arr 241 | mxArrayGetOffsetSafe arr (arrLen - 1) 242 | 243 | -- |Like mxArrayGetOffset but safe. 244 | mxArrayGetOffsetSafe :: forall a. MXArrayComponent a => MXArray a -> Int -> MIO (Either String a) 245 | mxArrayGetOffsetSafe arr ix 246 | | isMNull arr = pure $ Left "Couldn't get element of null array" 247 | | otherwise = do 248 | arrLen <- mxArrayLength arr 249 | safeGetElem arrLen ix 250 | where 251 | safeGetElem :: Int -> Int -> MIO (Either String a) 252 | safeGetElem aLen aIx 253 | | aIx < aLen = Right <$> mxArrayGetOffset arr aIx 254 | | otherwise = pure $ Left $ "Couldn't get element at index " 255 | <> (show aIx) <> " of " <> (show aLen) <> "-length array" 256 | 257 | -- |Safely cast a generic array to a type, or return Nothing if the array does not have the proper type 258 | castMXArray :: forall a. MXArrayComponent a => MAnyArray -> MIO (Maybe (MXArray a)) 259 | castMXArray a 260 | | isMNull a = pure Nothing 261 | | otherwise = do 262 | y <- isMXArray b 263 | pure $ if y then Just b else Nothing 264 | where 265 | b :: MXArray a 266 | b = unsafeCastMXArray a 267 | 268 | -- | Extract all arrays of a given type from a Cell Array. 269 | mxCellGetArraysOfType :: MXArrayComponent a => MXArray MCell -> MIO ([MXArray a]) 270 | mxCellGetArraysOfType ca = do 271 | cellVals <- (fmap . fmap) mCell (mxArrayGetAll ca) 272 | mxaMays :: [Maybe (MXArray a)] <- sequence $ castMXArray <$> cellVals 273 | pure $ catMaybes mxaMays 274 | 275 | -- | A convenience function to extract all arrays of a given type from a Cell Array; 276 | -- | may have larger dimensions than the original Cell Array due to flattening. 277 | mxCellGetAllOfType :: MXArrayComponent a => MXArray MCell -> MIO [a] 278 | mxCellGetAllOfType ca = do 279 | as <- mxCellGetArraysOfType ca 280 | join <$> (sequence $ mxArrayGetAll <$> as) 281 | 282 | foreign import ccall unsafe mxGetData :: MXArrayPtr -> IO (Ptr a) 283 | 284 | class (MXArrayComponent a, MType mx a, Storable mx) => MXArrayData mx a where 285 | withArrayData :: MXArray a -> (Ptr mx -> IO b) -> IO b 286 | withArrayDataOff :: MXArray a -> Int -> (Ptr mx -> IO b) -> IO b 287 | arrayDataGet :: MXArray a -> Int -> IO a 288 | arrayDataSet :: MXArray a -> Int -> a -> IO () 289 | 290 | arrayDataGetList :: MXArray a -> Int -> Int -> IO [a] 291 | arrayDataSetList :: MXArray a -> Int -> [a] -> IO () 292 | 293 | withArrayData a f = withMXArray a (mxGetData >=> f) 294 | withArrayDataOff a o f = withArrayData a (\p -> f (advancePtr p o)) 295 | arrayDataGet a o = withArrayDataOff a o (mx2hs .=< peek) 296 | arrayDataSet a o v = withArrayDataOff a o (\p -> poke p (hs2mx v)) 297 | arrayDataGetList a o n = withArrayDataOff a o (map mx2hs .=< peekArray n) 298 | arrayDataSetList a o l = withArrayDataOff a o (\p -> pokeArray p (map hs2mx l)) 299 | #let arrayDataComponent = "\ 300 | mxArrayGetOffset = arrayDataGet ;\ 301 | mxArraySetOffset = arrayDataSet ;\ 302 | mxArrayGetOffsetList = arrayDataGetList ;\ 303 | mxArraySetOffsetList = arrayDataSetList\ 304 | " 305 | --" 306 | 307 | foreign import ccall unsafe mxIsLogical :: MXArrayPtr -> IO CBool 308 | foreign import ccall unsafe mxCreateLogicalArray :: MWSize -> Ptr MWSize -> IO MXArrayPtr 309 | foreign import ccall unsafe mxGetLogicals :: MXArrayPtr -> IO (Ptr MXLogical) 310 | foreign import ccall unsafe mxCreateLogicalScalar :: CBool -> IO MXArrayPtr 311 | foreign import ccall unsafe mxIsLogicalScalar :: MXArrayPtr -> IO CBool 312 | foreign import ccall unsafe mxIsLogicalScalarTrue :: MXArrayPtr -> IO CBool 313 | instance MXArrayComponent MLogical where 314 | isMXArray a = boolC =.< withMXArray a mxIsLogical 315 | createMXArray s = withNDims s (uncurry mxCreateLogicalArray) >>= mkMXArray 316 | createMXScalar = mxCreateLogicalScalar . cBool >=> mkMXArray 317 | isMXScalar a = boolC =.< withMXArray a mxIsLogicalScalar 318 | mxScalarGet a = boolC =.< withMXArray a mxIsLogicalScalarTrue 319 | #arrayDataComponent 320 | instance MXArrayData MXLogical MLogical where 321 | withArrayData a f = withMXArray a (mxGetLogicals >=> f) 322 | 323 | foreign import ccall unsafe mxIsChar :: MXArrayPtr -> IO CBool 324 | foreign import ccall unsafe mxCreateCharArray :: MWSize -> Ptr MWSize -> IO MXArrayPtr 325 | foreign import ccall unsafe mxGetChars :: MXArrayPtr -> IO (Ptr MXChar) 326 | foreign import ccall unsafe mxCreateStringFromNChars :: CString -> MWSize -> IO MXArrayPtr 327 | instance MXArrayComponent MChar where 328 | isMXArray a = boolC =.< withMXArray a mxIsChar 329 | createMXArray s = withNDims s (uncurry mxCreateCharArray) >>= mkMXArray 330 | createRowVector s = 331 | mkMXArray =<< withCStringLen s (\(s,n) -> mxCreateStringFromNChars s (ii n)) 332 | #arrayDataComponent 333 | instance MXArrayData MXChar MChar where 334 | withArrayData a f = withMXArray a (mxGetChars >=> f) 335 | 336 | foreign import ccall unsafe mxCreateNumericArray :: MWSize -> Ptr MWSize -> MXClassID -> (#type mxComplexity) -> IO MXArrayPtr 337 | createNumericArray :: MXClass -> Bool -> MWSize -> Ptr MWSize -> IO MXArrayPtr 338 | createNumericArray t c n s = mxCreateNumericArray n s (hs2mx t) (if c then (#const mxCOMPLEX) else (#const mxREAL)) 339 | 340 | #let numarray t = "\ 341 | foreign import ccall unsafe mxIs%s :: MXArrayPtr -> IO CBool\n\ 342 | instance MXArrayComponent M%s where\n\ 343 | isMXArray a = boolC =.< withMXArray a mxIs%s\n\ 344 | createMXArray s = withNDims s (uncurry $ createNumericArray (mxClassOf (undefined :: M%s)) False) >>= mkMXArray\n\ 345 | \ 346 | mxArrayGetOffset = arrayDataGet ;\ 347 | mxArraySetOffset = arrayDataSet ;\ 348 | mxArrayGetOffsetList = arrayDataGetList ;\ 349 | mxArraySetOffsetList = arrayDataSetList\ 350 | \n\ 351 | instance MXArrayData MX%s M%s\ 352 | ", #t, #t, #t, #t, #t, #t 353 | 354 | foreign import ccall unsafe mxIsDouble :: MXArrayPtr -> IO CBool 355 | foreign import ccall unsafe mxCreateDoubleScalar :: MXDouble -> IO MXArrayPtr 356 | foreign import ccall unsafe mxGetScalar :: MXArrayPtr -> IO MXDouble 357 | instance MXArrayComponent MDouble where 358 | isMXArray a = boolC =.< withMXArray a mxIsDouble 359 | createMXScalar = mxCreateDoubleScalar . hs2mx >=> mkMXArray 360 | mxScalarGet a = withMXArray a mxGetScalar 361 | createMXArray s = withNDims s (uncurry $ createNumericArray (mxClassOf (undefined :: Double)) False) >>= mkMXArray 362 | #arrayDataComponent 363 | instance MXArrayData MXDouble MDouble 364 | 365 | #numarray Single 366 | #numarray Int8 367 | #numarray Int16 368 | #numarray Int32 369 | #numarray Int64 370 | #numarray Uint8 371 | #numarray Uint16 372 | #numarray Uint32 373 | #numarray Uint64 374 | 375 | 376 | foreign import ccall unsafe mxIsCell :: MXArrayPtr -> IO CBool 377 | foreign import ccall unsafe mxCreateCellArray :: MWSize -> Ptr MWSize -> IO MXArrayPtr 378 | foreign import ccall unsafe mxGetCell :: MXArrayPtr -> MWIndex -> IO MXArrayPtr 379 | foreign import ccall unsafe mxSetCell :: MXArrayPtr -> MWIndex -> MXArrayPtr -> IO () 380 | instance MXArrayComponent MCell where 381 | isMXArray a = boolC =.< withMXArray a mxIsCell 382 | createMXArray s = withNDims s (uncurry mxCreateCellArray) >>= mkMXArray 383 | -- Get a the specified cell element (not a copy). 384 | mxArrayGetOffset a o = withMXArray a (\a -> mxGetCell a (ii o) >>= mkMXArray >.= MCell) 385 | -- Set an element in a cell array to the specified value. The cell takes ownership of the array: and no copy is made. Any existing value should be freed first. 386 | mxArraySetOffset a o (MCell v) = withMXArray a (\a -> withMXArray v (mxSetCell a (ii o))) 387 | 388 | -- |A (array of) structs 389 | type MStructArray = MXArray MStruct 390 | 391 | foreign import ccall unsafe mxIsStruct :: MXArrayPtr -> IO CBool 392 | foreign import ccall unsafe mxIsObject :: MXArrayPtr -> IO CBool 393 | 394 | foreign import ccall unsafe mxCreateStructArray :: MWSize -> Ptr MWSize -> CInt -> Ptr CString -> IO MXArrayPtr 395 | -- |Create an N-Dimensional structure array having the specified fields; initialize all values to 'MNullArray' 396 | createStruct :: MSize -> [String] -> MIO MStructArray 397 | createStruct s f = 398 | withNDims s (\(nd,d) -> 399 | mapWithArrayLen withCString f (\(f,nf) -> 400 | mxCreateStructArray nd d (ii nf) f)) 401 | >>= mkMXArray 402 | 403 | foreign import ccall unsafe mxGetNumberOfFields :: MXArrayPtr -> IO CInt 404 | foreign import ccall unsafe mxGetFieldNameByNumber :: MXArrayPtr -> CInt -> IO CString 405 | foreign import ccall unsafe mxGetFieldNumber :: MXArrayPtr -> CString -> IO CInt 406 | -- |Get the names of the fields 407 | mStructFields :: MStructArray -> MIO [String] 408 | mStructFields a = withMXArray a $ \a -> do 409 | n <- mxGetNumberOfFields a 410 | forM [0..pred n] (mxGetFieldNameByNumber a >=> peekCString) 411 | 412 | foreign import ccall unsafe mxGetField :: MXArrayPtr -> MWIndex -> CString -> IO MXArrayPtr 413 | foreign import ccall unsafe mxSetField :: MXArrayPtr -> MWIndex -> CString -> MXArrayPtr -> IO () 414 | foreign import ccall unsafe mxGetFieldByNumber :: MXArrayPtr -> MWIndex -> CInt -> IO MXArrayPtr 415 | foreign import ccall unsafe mxSetFieldByNumber :: MXArrayPtr -> MWIndex -> CInt -> MXArrayPtr -> IO () 416 | 417 | -- |Return the contents of the named field for the given element. 418 | -- |Returns 'MNullArray' on no such field or if the field itself is NULL 419 | mStructGet :: MStructArray -> MIndex -> String -> MIO MAnyArray 420 | -- |Sets the contents of the named field for the given element. The input is stored in the array -- no copy is made. 421 | mStructSet :: MStructArray -> MIndex -> String -> MXArray a -> MIO () 422 | mStructGet a i f = do 423 | o <- mIndexOffset a i 424 | withMXArray a (\a -> withCString f (mxGetField a (ii o) >=> mkMXArray)) 425 | mStructSet a i f v = do 426 | o <- mIndexOffset a i 427 | withMXArray a (\a -> withCString f (withMXArray v . mxSetField a (ii o))) 428 | 429 | foreign import ccall unsafe mxAddField :: MXArrayPtr -> CString -> IO CInt 430 | foreign import ccall unsafe mxRemoveField :: MXArrayPtr -> CInt -> IO () 431 | -- |Add a field to a structure array. 432 | mStructAddField :: MStructArray -> String -> MIO () 433 | -- |Remove a field from a structure array. Does nothing if no such field exists. 434 | mStructRemoveField :: MStructArray -> String -> MIO () 435 | mStructAddField a f = do 436 | i <- withMXArray a (withCString f . mxAddField) 437 | when (i < 0) $ fail "mxAddField" 438 | mStructRemoveField a f = withMXArray a $ \a -> do 439 | i <- withCString f (mxGetFieldNumber a) 440 | if i < 0 441 | then fail "mxRemoveField" 442 | else mxRemoveField a i 443 | 444 | structGetOffsetFields :: MStructArray -> [String] -> Int -> IO MStruct 445 | structGetOffsetFields a f o = 446 | MStruct =.< withMXArray a (\a -> DM.fromList <$> 447 | (zipWithM (\f -> ((,) f) .=< (mxGetFieldByNumber a (ii o) >=> mkMXArray)) f [0..])) 448 | 449 | -- |Set the fields of a struct index to the given value list. The list corresponds to the field list and must match in size. 450 | mStructSetFields :: MStructArray -> MIndex -> [MXArray a] -> MIO () 451 | mStructSetFields a i v = do 452 | o <- mIndexOffset a i 453 | withMXArray a (\a -> zipWithM_ (\v -> withMXArray v . mxSetFieldByNumber a (ii o)) v [0..]) 454 | 455 | instance MXArrayComponent MStruct where 456 | isMXArray a = liftM2 (||) (boolC =.< withMXArray a mxIsStruct) (boolC =.< withMXArray a mxIsObject) 457 | createMXArray s = createStruct s [] 458 | mxArrayGetOffset a o = do 459 | f <- mStructFields a 460 | structGetOffsetFields a f o 461 | mxArraySetOffset = error "mxArraySet undefined for MStruct: use mStructSet" 462 | mxArrayGetOffsetList a o n = do 463 | f <- mStructFields a 464 | mapM (structGetOffsetFields a f) [o..o+n-1] 465 | createMXScalar (MStruct fv) = do 466 | a <- createStruct [1] f 467 | withMXArray a $ \a -> zipWithM_ (\i v -> withMXArray v (mxSetFieldByNumber a 0 i)) [0..] v 468 | pure a 469 | where 470 | (f,v) = unzip $ DM.toList fv 471 | 472 | foreign import ccall unsafe mxGetClassName :: MXArrayPtr -> IO CString 473 | -- |Determine if a struct array is a user defined object, and return its class name, if any. 474 | mObjectGetClass :: MStructArray -> IO (Maybe String) 475 | mObjectGetClass a = do 476 | b <- boolC =.< withMXArray a mxIsObject 477 | if b 478 | then Just =.< withMXArray a (mxGetClassName >=> peekCString) 479 | else pure Nothing 480 | 481 | foreign import ccall unsafe mxSetClassName :: MXArrayPtr -> CString -> IO CInt 482 | -- |Set classname of an unvalidated object array. It is illegal to call this function on a previously validated object array. 483 | mObjectSetClass :: MStructArray -> String -> IO () 484 | mObjectSetClass a c = do 485 | r <- withMXArray a (withCString c . mxSetClassName) 486 | when (r /= 0) $ fail "mObjectSetClass" 487 | 488 | castReal :: MXArray (Complex a) -> MXArray a 489 | castReal = unsafeCastMXArray 490 | 491 | foreign import ccall unsafe mxGetImagData :: MXArrayPtr -> IO (Ptr a) 492 | withRealDataOff :: MXArrayData mx a => MXArray (Complex a) -> Int -> (Ptr mx -> IO b) -> IO b 493 | withRealDataOff = withArrayDataOff . castReal 494 | withImagDataOff :: MXArrayData mx a => MXArray (Complex a) -> Int -> (Ptr mx -> IO b) -> IO b 495 | withImagDataOff a o f = withMXArray a (mxGetImagData >=> \p -> f (advancePtr p o)) 496 | 497 | foreign import ccall unsafe mxIsComplex :: MXArrayPtr -> IO CBool 498 | mxArrayIsComplex :: MXArray a -> IO Bool 499 | mxArrayIsComplex a = boolC =.< withMXArray a mxIsComplex 500 | 501 | -- |Complex array access. 502 | instance (RealFloat a, MNumeric a, MXArrayData mx a) => MXArrayComponent (MComplex a) where 503 | isMXArray a = liftM2 (&&) (isMXArray (castReal a)) (mxArrayIsComplex a) 504 | createMXArray s = withNDims s (uncurry $ createNumericArray (mxClassOf (undefined :: a)) True) >>= mkMXArray 505 | 506 | mxArrayGetOffset a o = do 507 | r <- withRealDataOff a o (mx2hs .=< peek) 508 | c <- withImagDataOff a o (mx2hs .=< peek) 509 | pure $ r :+ c 510 | mxArraySetOffset a o (r :+ c) = do 511 | withRealDataOff a o (\p -> poke p (hs2mx r)) 512 | withImagDataOff a o (\p -> poke p (hs2mx c)) 513 | mxArrayGetOffsetList a o n = do 514 | r <- withRealDataOff a o (map mx2hs .=< peekArray n) 515 | c <- withImagDataOff a o (map mx2hs .=< peekArray n) 516 | pure $ zipWith (:+) r c 517 | mxArraySetOffsetList a o v = do 518 | withRealDataOff a o (\p -> pokeArray p (map hs2mx r)) 519 | withImagDataOff a o (\p -> pokeArray p (map hs2mx c)) 520 | where (r,c) = unzip $ map (\(r:+c) -> (r,c)) v 521 | --------------------------------------------------------------------------------