matlab 0.2.0.0 → 0.3.0.0
raw patch · 18 files changed
+719/−173 lines, 18 filesdep +containersdep +exceptionsdep +matlabdep ~Cabaldep ~arraydep ~basesetup-changednew-component:exe:haskell-hellonew-component:exe:matlab-engine-testnew-uploader
Dependencies added: containers, exceptions, matlab, path, profunctors, template-haskell, text
Dependency ranges changed: Cabal, array, base, filepath, unix
Files
- Foreign/Matlab/Array.hsc +103/−34
- Foreign/Matlab/Array/IMX.hs +69/−68
- Foreign/Matlab/Engine.hsc +41/−9
- Foreign/Matlab/Engine/Wrappers.hs +68/−0
- Foreign/Matlab/Internal.hsc +23/−15
- Foreign/Matlab/MAT.hsc +9/−9
- Foreign/Matlab/Optics.hsc +53/−0
- Foreign/Matlab/Runtime.hsc +0/−1
- Foreign/Matlab/Runtime/Generic.hs +1/−1
- Foreign/Matlab/Types.hs +3/−2
- Setup.hs +8/−8
- hello/SpecHello.hs +8/−0
- matlab.cabal +67/−14
- test/SpecEngine.hs +7/−0
- test/Test/Engine.hs +193/−0
- test/Test/Util.hs +48/−0
- test/Test/UtilTemplate.hs +18/−0
- test/engine.hs +0/−12
Foreign/Matlab/Array.hsc view
@@ -31,7 +31,11 @@ -- | array list access mxArrayGetList, mxArraySetList, mxArrayGetAll, mxArraySetAll,- + mxArrayGetOffsetSafe, mxArrayGetFirst, mxArrayGetLast,+ -- mxArrayGetSafe, --TODO--+ fromListIO, cellFromListsIO,+ isMNull,+ -- * Struct access -- |Structs in Matlab are always arrays, and so can be accessed using most array accessors. -- |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.@@ -41,20 +45,24 @@ mStructGet, mStructSet, mStructSetFields, mStructAddField, mStructRemoveField,+ mxCellGetAllOfType, mxCellGetArraysOfType, -- ** Object access -- |Some structs are also validated (blessed) user objects. mObjectGetClass, mObjectSetClass ) where -import Control.Monad-import Foreign-import Foreign.C.String-import Foreign.C.Types-import Data.Complex-import Foreign.Matlab.Util-import Foreign.Matlab.Internal-import Foreign.Matlab.Types+import Control.Monad+import Data.Foldable (toList)+import Foreign+import Foreign.C.String+import Foreign.C.Types+import Data.Complex+import qualified Data.Map.Strict as DM+import Data.Maybe (catMaybes)+import Foreign.Matlab.Util+import Foreign.Matlab.Internal+import Foreign.Matlab.Types #include <matrix.h> @@ -66,15 +74,15 @@ type MNullArray = MXArray MNull -- |Safely cast a generic array to a NULL array, or return Nothing if the array is not NULL castMNull :: MAnyArray -> MIO (Maybe MNullArray)-castMNull a - | isMNull a = return $ Just (unsafeCastMXArray a)- | otherwise = return Nothing+castMNull a+ | isMNull a = pure $ Just (unsafeCastMXArray a)+ | otherwise = pure Nothing foreign import ccall unsafe mxGetClassID :: MXArrayPtr -> IO MXClassID -- |Return the representation of the type of the elements of an array mxArrayClass :: MXArray a -> IO MXClass mxArrayClass a- | isMNull a = return $ MXClassNull+ | isMNull a = pure $ MXClassNull | otherwise = withMXArray a mxGetClassID >.= mx2hs ndims :: MWSize -> Ptr MWSize -> IO MSize@@ -103,14 +111,15 @@ when (r /= 0) $ fail "mxArraySetSize" foreign import ccall unsafe mxGetNumberOfElements :: MXArrayPtr -> IO CSize+-- |Like `numel` in MATLAB. mxArrayLength :: MXArray a -> MIO Int mxArrayLength a = ii =.< withMXArray a mxGetNumberOfElements foreign import ccall unsafe mxCalcSingleSubscript :: MXArrayPtr -> MWSize -> Ptr MWIndex -> IO MWIndex -- |Convert an array subscript into an offset mIndexOffset :: MXArray a -> MIndex -> MIO Int-mIndexOffset _ (MSubs []) = return 0-mIndexOffset _ (MSubs [i]) = return i+mIndexOffset _ (MSubs []) = pure 0+mIndexOffset _ (MSubs [i]) = pure i mIndexOffset a (MSubs i) = ii =.< withMXArray a (withNSubs i . uncurry . mxCalcSingleSubscript) foreign import ccall unsafe mxDuplicateArray :: MXArrayPtr -> IO MXArrayPtr@@ -121,8 +130,30 @@ foreign import ccall unsafe mxDestroyArray :: MXArrayPtr -> IO () -- |Destroy an array and all of its contents. freeMXArray :: MXArray a -> MIO ()-freeMXArray a = withMXArray a mxDestroyArray+freeMXArray a = do+ withMXArray a mxDestroyArray+ mxArraySetSize a [0, 0] +-- | Create and populate an MXArray in one go. Named without 'mx' due to possible+-- | conformity to a typeclass function.+fromListIO :: (Foldable t, MXArrayComponent a) => t a -> MIO (MXArray a)+fromListIO xs = do+ arr <- createMXArray [length xs]+ mxArraySetAll arr xsList+ pure arr+ where+ xsList = toList xs++-- | Like fromListIO but wraps elements in a cell. Most useful for converting a list of strings+-- | to a MATLAB cell array of strings. Named in conjunction with `fromListIO`, which is used+-- | as part of the implementation.+cellFromListsIO :: (Traversable s, Foldable t, MXArrayComponent a) => s (t a) -> MIO (MXArray MCell)+cellFromListsIO xss = do+ listOfStructArrays <- sequence $ fromListIO <$> xss+ arr <- createMXArray [length xss]+ mxArraySetAll arr (toList $ (MCell . anyMXArray) <$> listOfStructArrays)+ pure arr+ -- |The class of standardly typeable array elements class MXArrayComponent a where -- |Determine whether the given array is of the correct type@@ -151,7 +182,7 @@ -- |Create a row vector from the given list. createRowVector :: [a] -> MIO (MXArray a) - isMXArray _ = return False+ isMXArray _ = pure False isMXScalar a = liftM2 (&&) (isMXArray a) (all (1 ==) =.< mxArraySize a) mxArrayGetOffsetList a o n = mapM (mxArrayGetOffset a) [o..o+n-1]@@ -162,15 +193,15 @@ createMXScalar x = do a <- createMXArray [1] mxArraySetOffset a 0 x- return a+ pure a createRowVector l = do a <- createMXArray [1,length l] mxArraySetOffsetList a 0 l- return a+ pure a createColVector l = do a <- createMXArray [length l] mxArraySetOffsetList a 0 l- return a+ pure a -- |Get the value of the specified array element. Does not check bounds. mxArrayGet :: MXArrayComponent a => MXArray a -> MIndex -> MIO a@@ -185,7 +216,7 @@ mxArrayGetList :: MXArrayComponent a => MXArray a -> MIndex -> Int -> MIO [a] mxArrayGetList a i n = do o <- mIndexOffset a i- n <- if n == -1 then subtract o =.< mxArrayLength a else return n+ n <- if n == -1 then subtract o =.< mxArrayLength a else pure n mxArrayGetOffsetList a o n -- |@'mxArraySetList' a i l@ sets the sequential items in array @a@ starting at index @i@ to @l@. Does not check bounds. mxArraySetList :: MXArrayComponent a => MXArray a -> MIndex -> [a] -> MIO ()@@ -201,17 +232,53 @@ mxArraySetAll :: MXArrayComponent a => MXArray a -> [a] -> IO () mxArraySetAll a = mxArraySetList a mStart +mxArrayGetFirst :: MXArrayComponent a => MXArray a -> MIO (Either String a)+mxArrayGetFirst arr = mxArrayGetOffsetSafe arr 0++mxArrayGetLast :: MXArrayComponent a => MXArray a -> MIO (Either String a)+mxArrayGetLast arr = do+ arrLen <- mxArrayLength arr+ mxArrayGetOffsetSafe arr (arrLen - 1)++-- |Like mxArrayGetOffset but safe.+mxArrayGetOffsetSafe :: forall a. MXArrayComponent a => MXArray a -> Int -> MIO (Either String a)+mxArrayGetOffsetSafe arr ix+ | isMNull arr = pure $ Left "Couldn't get element of null array"+ | otherwise = do+ arrLen <- mxArrayLength arr+ safeGetElem arrLen ix+ where+ safeGetElem :: Int -> Int -> MIO (Either String a)+ safeGetElem aLen aIx+ | aIx < aLen = Right <$> mxArrayGetOffset arr aIx+ | otherwise = pure $ Left $ "Couldn't get element at index "+ <> (show aIx) <> " of " <> (show aLen) <> "-length array"+ -- |Safely cast a generic array to a type, or return Nothing if the array does not have the proper type castMXArray :: forall a. MXArrayComponent a => MAnyArray -> MIO (Maybe (MXArray a)) castMXArray a- | isMNull a = return Nothing+ | isMNull a = pure Nothing | otherwise = do y <- isMXArray b- return $ if y then Just b else Nothing+ pure $ if y then Just b else Nothing where- b :: MXArray a- b = unsafeCastMXArray a+ b :: MXArray a+ b = unsafeCastMXArray a +-- | Extract all arrays of a given type from a Cell Array.+mxCellGetArraysOfType :: MXArrayComponent a => MXArray MCell -> MIO ([MXArray a])+mxCellGetArraysOfType ca = do+ cellVals <- (fmap . fmap) mCell (mxArrayGetAll ca)+ mxaMays :: [Maybe (MXArray a)] <- sequence $ castMXArray <$> cellVals+ pure $ catMaybes mxaMays++-- | A convenience function to extract all arrays of a given type from a Cell Array;+-- | may have larger dimensions than the original Cell Array due to flattening.+mxCellGetAllOfType :: MXArrayComponent a => MXArray MCell -> MIO [a]+mxCellGetAllOfType ca = do+ as <- mxCellGetArraysOfType ca+ join <$> (sequence $ mxArrayGetAll <$> as)+ foreign import ccall unsafe mxGetData :: MXArrayPtr -> IO (Ptr a) class (MXArrayComponent a, MType mx a, Storable mx) => MXArrayData mx a where@@ -327,8 +394,8 @@ foreign import ccall unsafe mxCreateStructArray :: MWSize -> Ptr MWSize -> CInt -> Ptr CString -> IO MXArrayPtr -- |Create an N-Dimensional structure array having the specified fields; initialize all values to 'MNullArray' createStruct :: MSize -> [String] -> MIO MStructArray-createStruct s f = - withNDims s (\(nd,d) -> +createStruct s f =+ withNDims s (\(nd,d) -> mapWithArrayLen withCString f (\(f,nf) -> mxCreateStructArray nd d (ii nf) f)) >>= mkMXArray@@ -347,7 +414,8 @@ foreign import ccall unsafe mxGetFieldByNumber :: MXArrayPtr -> MWIndex -> CInt -> IO MXArrayPtr foreign import ccall unsafe mxSetFieldByNumber :: MXArrayPtr -> MWIndex -> CInt -> MXArrayPtr -> IO () --- |Return the contents of the named field for the given element. Returns 'MNullArray' on no such field or if the field itself is NULL+-- |Return the contents of the named field for the given element.+-- |Returns 'MNullArray' on no such field or if the field itself is NULL mStructGet :: MStructArray -> MIndex -> String -> MIO MAnyArray -- |Sets the contents of the named field for the given element. The input is stored in the array -- no copy is made. mStructSet :: MStructArray -> MIndex -> String -> MXArray a -> MIO ()@@ -375,7 +443,8 @@ structGetOffsetFields :: MStructArray -> [String] -> Int -> IO MStruct structGetOffsetFields a f o =- MStruct =.< withMXArray a (\a -> zipWithM (\f -> ((,) f) .=< (mxGetFieldByNumber a (ii o) >=> mkMXArray)) f [0..])+ MStruct =.< withMXArray a (\a -> DM.fromList <$> + (zipWithM (\f -> ((,) f) .=< (mxGetFieldByNumber a (ii o) >=> mkMXArray)) f [0..])) -- |Set the fields of a struct index to the given value list. The list corresponds to the field list and must match in size. mStructSetFields :: MStructArray -> MIndex -> [MXArray a] -> MIO ()@@ -396,9 +465,9 @@ createMXScalar (MStruct fv) = do a <- createStruct [1] f withMXArray a $ \a -> zipWithM_ (\i v -> withMXArray v (mxSetFieldByNumber a 0 i)) [0..] v- return a+ pure a where- (f,v) = unzip fv+ (f,v) = unzip $ DM.toList fv foreign import ccall unsafe mxGetClassName :: MXArrayPtr -> IO CString -- |Determine if a struct array is a user defined object, and return its class name, if any.@@ -407,7 +476,7 @@ b <- boolC =.< withMXArray a mxIsObject if b then Just =.< withMXArray a (mxGetClassName >=> peekCString)- else return Nothing+ else pure Nothing foreign import ccall unsafe mxSetClassName :: MXArrayPtr -> CString -> IO CInt -- |Set classname of an unvalidated object array. It is illegal to call this function on a previously validated object array.@@ -437,14 +506,14 @@ mxArrayGetOffset a o = do r <- withRealDataOff a o (mx2hs .=< peek) c <- withImagDataOff a o (mx2hs .=< peek)- return $ r :+ c+ pure $ r :+ c mxArraySetOffset a o (r :+ c) = do withRealDataOff a o (\p -> poke p (hs2mx r)) withImagDataOff a o (\p -> poke p (hs2mx c)) mxArrayGetOffsetList a o n = do r <- withRealDataOff a o (map mx2hs .=< peekArray n) c <- withImagDataOff a o (map mx2hs .=< peekArray n)- return $ zipWith (:+) r c+ pure $ zipWith (:+) r c mxArraySetOffsetList a o v = do withRealDataOff a o (\p -> pokeArray p (map hs2mx r)) withImagDataOff a o (\p -> pokeArray p (map hs2mx c))
Foreign/Matlab/Array/IMX.hs view
@@ -23,35 +23,36 @@ imxStructList ) where -import Control.Monad-import Data.Array.IArray-import Data.Complex-import Data.List-import Foreign.Matlab.Util-import Foreign.Matlab.Internal-import Foreign.Matlab.Types-import Foreign.Matlab.Array+import Control.Monad+import Data.Array.IArray+import Data.Complex+import Data.List+import qualified Data.Map.Strict as DM+import Foreign.Matlab.Util+import Foreign.Matlab.Internal+import Foreign.Matlab.Types+import Foreign.Matlab.Array type IMXArray a = Array MIndex a -- |The basic immutable (functional) representation of Matlab data structures, representing a generic 'MXArray' data IMXData = IMXNull- | IMXCell (IMXArray IMXData)+ | IMXCell (IMXArray IMXData) | IMXStruct [String] (Array (MIndex,Int) IMXData) -- ^ field name list and array mapping (index,field index) to values- | IMXLogical (IMXArray MLogical)- | IMXChar (IMXArray MChar)- | IMXDouble (IMXArray MDouble)- | IMXSingle (IMXArray MSingle)- | IMXInt8 (IMXArray MInt8)- | IMXUint8 (IMXArray MUint8)- | IMXInt16 (IMXArray MInt16)- | IMXUint16 (IMXArray MUint16)- | IMXInt32 (IMXArray MInt32)- | IMXUint32 (IMXArray MUint32)- | IMXInt64 (IMXArray MInt64)- | IMXUint64 (IMXArray MUint64)- | IMXComplexDouble (IMXArray (MComplex MDouble))- | IMXComplexSingle (IMXArray (MComplex MSingle))+ | IMXLogical (IMXArray MLogical)+ | IMXChar (IMXArray MChar)+ | IMXDouble (IMXArray MDouble)+ | IMXSingle (IMXArray MSingle)+ | IMXInt8 (IMXArray MInt8)+ | IMXUint8 (IMXArray MUint8)+ | IMXInt16 (IMXArray MInt16)+ | IMXUint16 (IMXArray MUint16)+ | IMXInt32 (IMXArray MInt32)+ | IMXUint32 (IMXArray MUint32)+ | IMXInt64 (IMXArray MInt64)+ | IMXUint64 (IMXArray MUint64)+ | IMXComplexDouble (IMXArray (MComplex MDouble))+ | IMXComplexSingle (IMXArray (MComplex MSingle)) | IMXObject String IMXData -- ^ object class name and object data, currently always IMXStruct deriving (Eq) @@ -148,28 +149,28 @@ imxc t c where imxc :: MXClass -> Bool -> IO IMXData- imxc MXClassNull _ = return IMXNull- imxc MXClassCell False = IMXCell =.< imxa (imxData . mCell)- imxc MXClassStruct False = do+ imxc MXClassNull _ = return IMXNull+ imxc MXClassCell False = IMXCell =.< imxa (imxData . mCell)+ imxc MXClassStruct False = do s <- mxArraySize a' fv <- mxArrayGetAll a'- f <- if null fv then mStructFields a' else return (map fst (mStruct (head fv)))- listIMXStruct f s =.< mapM imxData (concatMap (map snd . mStruct) fv)- imxc MXClassLogical False = IMXLogical =.< imxa return- imxc MXClassChar False = IMXChar =.< imxa return- imxc MXClassDouble False = IMXDouble =.< imxa return- imxc MXClassSingle False = IMXSingle =.< imxa return- imxc MXClassInt8 False = IMXInt8 =.< imxa return- imxc MXClassUint8 False = IMXUint8 =.< imxa return- imxc MXClassInt16 False = IMXInt16 =.< imxa return- imxc MXClassUint16 False = IMXUint16 =.< imxa return- imxc MXClassInt32 False = IMXInt32 =.< imxa return- imxc MXClassUint32 False = IMXUint32 =.< imxa return- imxc MXClassInt64 False = IMXInt64 =.< imxa return- imxc MXClassUint64 False = IMXUint64 =.< imxa return- imxc MXClassDouble True = IMXComplexDouble =.< imxa return- imxc MXClassSingle True = IMXComplexSingle =.< imxa return- imxc MXClassObject False = do+ f <- if null fv then mStructFields a' else return (map fst (DM.toList $ _mStruct (head fv)))+ listIMXStruct f s =.< mapM imxData (concatMap (map snd . DM.toList . _mStruct) fv)+ imxc MXClassLogical False = IMXLogical =.< imxa return+ imxc MXClassChar False = IMXChar =.< imxa return+ imxc MXClassDouble False = IMXDouble =.< imxa return+ imxc MXClassSingle False = IMXSingle =.< imxa return+ imxc MXClassInt8 False = IMXInt8 =.< imxa return+ imxc MXClassUint8 False = IMXUint8 =.< imxa return+ imxc MXClassInt16 False = IMXInt16 =.< imxa return+ imxc MXClassUint16 False = IMXUint16 =.< imxa return+ imxc MXClassInt32 False = IMXInt32 =.< imxa return+ imxc MXClassUint32 False = IMXUint32 =.< imxa return+ imxc MXClassInt64 False = IMXInt64 =.< imxa return+ imxc MXClassUint64 False = IMXUint64 =.< imxa return+ imxc MXClassDouble True = IMXComplexDouble =.< imxa return+ imxc MXClassSingle True = IMXComplexSingle =.< imxa return+ imxc MXClassObject False = do Just c <- mObjectGetClass a' IMXObject c =.< imxc MXClassStruct False imxc t c = fail ("imxData: unhandled mxArray type " ++ show t ++ if c then "(complex)" else "")@@ -192,18 +193,18 @@ m <- createStruct (mRangeSize (r0,r1)) f zipWithM_ (\i -> mStructSetFields m (mOffset i) <=< mapM iMXData) [0..] (segment (length f) (elems a)) return $ anyMXArray m- imxd (IMXLogical a) = imxa a return- imxd (IMXChar a) = imxa a return- imxd (IMXDouble a) = imxa a return- imxd (IMXSingle a) = imxa a return- imxd (IMXInt8 a) = imxa a return- imxd (IMXUint8 a) = imxa a return- imxd (IMXInt16 a) = imxa a return- imxd (IMXUint16 a) = imxa a return- imxd (IMXInt32 a) = imxa a return- imxd (IMXUint32 a) = imxa a return- imxd (IMXInt64 a) = imxa a return- imxd (IMXUint64 a) = imxa a return+ imxd (IMXLogical a) = imxa a return+ imxd (IMXChar a) = imxa a return+ imxd (IMXDouble a) = imxa a return+ imxd (IMXSingle a) = imxa a return+ imxd (IMXInt8 a) = imxa a return+ imxd (IMXUint8 a) = imxa a return+ imxd (IMXInt16 a) = imxa a return+ imxd (IMXUint16 a) = imxa a return+ imxd (IMXInt32 a) = imxa a return+ imxd (IMXUint32 a) = imxa a return+ imxd (IMXInt64 a) = imxa a return+ imxd (IMXUint64 a) = imxa a return imxd (IMXComplexDouble a) = imxa a return imxd (IMXComplexSingle a) = imxa a return imxd (IMXObject c a) = do@@ -295,19 +296,19 @@ v = transpose $ segment (length f) $ elems a ((r0,_),(r1,_)) = bounds a showsIMX (IMXLogical a) = showsApp "logical" $ showsIMXArray a-showsIMX (IMXChar a) = showsApp "char" $ showsIMXArray a-showsIMX (IMXDouble a) = showsIMXArray a-showsIMX (IMXSingle a) = showsApp "single" $ showsIMXArray a-showsIMX (IMXInt8 a) = showsApp "int8" $ showsIMXArray a-showsIMX (IMXUint8 a) = showsApp "uint8" $ showsIMXArray a-showsIMX (IMXInt16 a) = showsApp "int16" $ showsIMXArray a-showsIMX (IMXUint16 a) = showsApp "uint16" $ showsIMXArray a-showsIMX (IMXInt32 a) = showsApp "int32" $ showsIMXArray a-showsIMX (IMXUint32 a) = showsApp "uint32" $ showsIMXArray a-showsIMX (IMXInt64 a) = showsApp "int64" $ showsIMXArray a-showsIMX (IMXUint64 a) = showsApp "uint64" $ showsIMXArray a-showsIMX (IMXComplexDouble a) = showsIMXArrayWith showsComplex a-showsIMX (IMXComplexSingle a) = showsApp "single" $ showsIMXArrayWith showsComplex a+showsIMX (IMXChar a) = showsApp "char" $ showsIMXArray a+showsIMX (IMXDouble a) = showsIMXArray a+showsIMX (IMXSingle a) = showsApp "single" $ showsIMXArray a+showsIMX (IMXInt8 a) = showsApp "int8" $ showsIMXArray a+showsIMX (IMXUint8 a) = showsApp "uint8" $ showsIMXArray a+showsIMX (IMXInt16 a) = showsApp "int16" $ showsIMXArray a+showsIMX (IMXUint16 a) = showsApp "uint16" $ showsIMXArray a+showsIMX (IMXInt32 a) = showsApp "int32" $ showsIMXArray a+showsIMX (IMXUint32 a) = showsApp "uint32" $ showsIMXArray a+showsIMX (IMXInt64 a) = showsApp "int64" $ showsIMXArray a+showsIMX (IMXUint64 a) = showsApp "uint64" $ showsIMXArray a+showsIMX (IMXComplexDouble a) = showsIMXArrayWith showsComplex a+showsIMX (IMXComplexSingle a) = showsApp "single" $ showsIMXArrayWith showsComplex a showsIMX (IMXObject c a) = showsApp "class" $ showsIMX a . showChar ',' . showsMString c instance Show IMXData where
Foreign/Matlab/Engine.hsc view
@@ -12,7 +12,10 @@ engineGetVar, engineSetVar, EngineEvalArg(..),- engineEvalFun+ engineEvalFun,+ engineEvalProc,+ HasEngine(..), SetEngine(..),+ qt ) where import Control.Monad@@ -20,6 +23,8 @@ import Foreign.C.String import Foreign.C.Types import Data.List+import Foreign.Matlab.Array (createMXScalar)+import Foreign.Matlab.Optics import Foreign.Matlab.Util import Foreign.Matlab.Internal @@ -28,16 +33,27 @@ data EngineType type EnginePtr = Ptr EngineType ++class HasEngine env where+ getEngine :: env -> Engine++class HasEngine env => SetEngine env where+ setEngine :: env -> Engine -> env++ engine :: Lens' env Engine+ engine = lens getEngine setEngine+ -- |A Matlab engine instance newtype Engine = Engine (ForeignPtr EngineType)+ deriving Eq foreign import ccall unsafe engOpen :: CString -> IO EnginePtr foreign import ccall unsafe "&" engClose :: FunPtr (EnginePtr -> IO ()) -- CInt -- |Start Matlab server process. It will automatically be closed down when no longer in use. newEngine :: FilePath -> IO Engine-newEngine bin = do- eng <- withCString bin engOpen+newEngine host = do+ eng <- withCString host engOpen if eng == nullPtr then fail "engOpen" else Engine =.< newForeignPtr engClose eng@@ -48,7 +64,7 @@ foreign import ccall unsafe engEvalString :: EnginePtr -> CString -> IO CInt -- |Execute matlab statement engineEval :: Engine -> String -> IO ()-engineEval eng s = do +engineEval eng s = do r <- withEngine eng (withCString s . engEvalString) when (r /= 0) $ fail "engineEval" @@ -64,13 +80,13 @@ r <- withEngine eng (\eng -> withCString v (withMXArray x . engPutVariable eng)) when (r /= 0) $ fail "engineSetVar" -data EngineEvalArg a = EvalArray (MXArray a) | EvalVar String+data EngineEvalArg a = EvalArray (MXArray a) | EvalStruct MStruct | EvalVar String | EvalStr String -- |Evaluate a function with the given arguments and number of results. -- This automates 'engineSetVar' on arguments (using \"hseval_inN\"), 'engineEval', and 'engineGetVar' on results (using \"hseval_outN\"). engineEvalFun :: Engine -> String -> [EngineEvalArg a] -> Int -> IO [MAnyArray]-engineEvalFun eng fun arg no = do- arg <- zipWithM makearg arg [1 :: Int ..]+engineEvalFun eng fun args no = do+ arg <- zipWithM makearg args [1 :: Int ..] let out = map makeout [1..no] let outs = if out == [] then "" else "[" ++ unwords out ++ "] = " engineEval eng (outs ++ fun ++ "(" ++ intercalate "," arg ++ ")")@@ -79,6 +95,22 @@ makearg (EvalArray x) i = do let v = "hseval_in" ++ show i engineSetVar eng v x- return v- makearg (EvalVar v) _ = return v+ pure v+ makearg (EvalStruct x) i = do+ xa <- createMXScalar x+ let v = "hseval_in" ++ show i+ engineSetVar eng v xa+ pure v+ makearg (EvalVar v) _ = pure v+ makearg (EvalStr v) _ = pure $ qt v makeout i = "hseval_out" ++ show i++-- |Convenience function for calling functions that do not return values (i.e. "procedures").+engineEvalProc :: Engine -> String -> [EngineEvalArg a] -> IO ()+engineEvalProc eng fun args = do+ _ <- engineEvalFun eng fun args 0+ pure ()++-- |Utility function to quote a string+qt :: String -> String+qt s = "'" <> s <> "'"
+ Foreign/Matlab/Engine/Wrappers.hs view
@@ -0,0 +1,68 @@+{-|+ Wrappers to common (and some uncommon) MATLAB functions using the MATLAB Engine.++ Note that you cannot use "Foreign.Matlab.Engine" and "Foreign.Matlab.Runtime" in the same program.+ This seems to be a Matlab limitation.+ -}++module Foreign.Matlab.Engine.Wrappers (+ addpath+, clearVar+, getArrayFromByteStream+, getByteStreamFromArray+, MEither(..), isMLeft, isMRight+, VarArgIn, mxVarArgs+) where++import qualified Data.Map.Strict as DM+import Foreign.Matlab+import Foreign.Matlab.Engine+import Path++type VarArgIn = DM.Map String MAnyArray++-- | We require an absolute path in this case+addpath :: Engine -> Path Abs Dir -> IO ()+addpath eng p = engineEvalProc eng "addpath" [EvalStr $ toFilePath p]++-- | TODO: add a test for this, likely not working as expected.+-- | Clears a variable from the engine's workspace+clearVar :: Engine -> String -> IO ()+clearVar eng var = engineEvalProc eng "clear" [EvalStr var]++-- | Wraps an undocumented function to serialize a MATLAB object.+getByteStreamFromArray :: Engine -> MAnyArray -> IO (Either String [MUint8])+getByteStreamFromArray eng mObj = do+ [byteStream] <- engineEvalFun eng "getByteStreamFromArray" [EvalArray mObj] 1+ mxArrMay <- castMXArray byteStream+ case mxArrMay of+ Just mxArr -> Right <$> mxArrayGetAll mxArr+ Nothing -> pure $ Left+ "getByteStreamFromArray: Couldn't convert MATLAB bytestream to [MUint8]"++-- | Wraps an undocumented function to deserialize a MATLAB object.+getArrayFromByteStream :: Engine -> [MUint8] -> IO MAnyArray+getArrayFromByteStream eng bytes = do+ matBsArr <- createMXArray [length bytes]+ mxArraySetAll matBsArr bytes+ [mObj] <- engineEvalFun eng "getArrayFromByteStream" [EvalArray matBsArr] 1+ pure mObj++newtype MEither = MEither {unMXEither :: MStructArray}++isMLeft :: MEither -> IO Bool+isMLeft me = do+ sFields <- mStructFields $ unMXEither me+ pure $ "left" `elem` sFields++isMRight :: MEither -> IO Bool+isMRight me = do+ sFields <- mStructFields $ unMXEither me+ pure $ "right" `elem` sFields++-- | Utility function to create an eval-able list of arguments for a vararg map.+mxVarArgs :: VarArgIn -> [EngineEvalArg MAny]+mxVarArgs varargin = DM.toList varargin >>= kvToArg+ where+ kvToArg :: (String, MAnyArray) -> [EngineEvalArg MAny]+ kvToArg kv = [EvalStr $ fst kv, EvalArray $ snd kv]
Foreign/Matlab/Internal.hsc view
@@ -1,3 +1,6 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Foreign.Matlab.Internal ( CBool, boolC, cBool, MIO,@@ -22,22 +25,24 @@ MAny, MAnyArray, MNull, mNullArray, isMNull, MCell(..),- MStruct(..),- MFun,+ MStruct(..), mStruct,+ MXFun, MFun, MWSize, MWIndex, MWSignedIndex ) where -import Foreign-import Foreign.C.Types+import qualified Data.Map.Strict as DM+++import Foreign+import Foreign.C.Types import qualified Data.Char-import Foreign.Matlab.Util+import Foreign.Matlab.Optics+import Foreign.Matlab.Util #include <matrix.h> type MIO a = IO a -type CBool = #type bool- boolC :: CBool -> Bool boolC = (0 /=) @@ -45,9 +50,9 @@ cBool = ii . fromEnum type MXClassID = #type mxClassID-data MXClass = +data MXClass = MXClassNull- | MXClassCell + | MXClassCell | MXClassStruct | MXClassLogical | MXClassChar@@ -88,7 +93,7 @@ mx2hs (#const mxINT64_CLASS) = MXClassInt64 mx2hs (#const mxUINT64_CLASS) = MXClassUint64 mx2hs (#const mxFUNCTION_CLASS)= MXClassFun- mx2hs (#const mxOBJECT_CLASS) = MXClassObject+ mx2hs (#const mxOBJECT_CLASS) = MXClassObject mx2hs c = error ("MXClass: unknown mxClassID " ++ show c) hs2mx MXClassNull = #const mxVOID_CLASS hs2mx MXClassCell = #const mxCELL_CLASS@@ -106,7 +111,7 @@ hs2mx MXClassInt64 = #const mxINT64_CLASS hs2mx MXClassUint64 = #const mxUINT64_CLASS hs2mx MXClassFun = #const mxFUNCTION_CLASS- hs2mx MXClassObject = #const mxOBJECT_CLASS + hs2mx MXClassObject = #const mxOBJECT_CLASS mxClassOf _ = error "mxClassOf: no class for MXClassID" type MXChar = #type mxChar@@ -116,7 +121,7 @@ mx2hs = Data.Char.chr . ii mxClassOf _ = MXClassChar -type MXLogical = #type mxLogical+type MXLogical = CBool type MLogical = Bool instance MType MXLogical MLogical where hs2mx = cBool@@ -176,7 +181,7 @@ type MAnyArray = MXArray MAny -- |Tag for a NULL array-data MNull +data MNull instance MType MNull MNull where hs2mx = id mx2hs = id@@ -193,15 +198,18 @@ mxClassOf _ = MXClassCell -- |A single struct in an array, represented by an (ordered) list of key-value pairs-newtype MStruct = MStruct { mStruct :: [(String,MAnyArray)] }+newtype MStruct = MStruct { _mStruct :: DM.Map String MAnyArray } instance MType MStruct MStruct where hs2mx = id mx2hs = id mxClassOf _ = MXClassStruct +mStruct :: Iso' MStruct (DM.Map String MAnyArray)+mStruct = coerced+ type MXFun = CInt -> Ptr MXArrayPtr -> CInt -> Ptr MXArrayPtr -> IO () -- |A Matlab function-type MFun = +type MFun = [MAnyArray] -- ^ RHS input arguments -> Int -- ^ LHS output argument count -> IO [MAnyArray] -- ^ LHS output arguments
Foreign/Matlab/MAT.hsc view
@@ -39,7 +39,7 @@ -- |Open a MAT-file using mode. matOpen :: FilePath -> MATMode -> IO MATFile-matOpen f m = do +matOpen f m = do throwErrnoIfNull ("matOpen: " ++ f) (withCString f (withCString (ms m) . matOpen_c)) >.= MATFile@@ -55,7 +55,7 @@ foreign import ccall unsafe matPutVariable :: MATFilePtr -> CString -> MXArrayPtr -> IO CInt foreign import ccall unsafe matPutVariableAsGlobal :: MATFilePtr -> CString -> MXArrayPtr -> IO CInt -- |Write array value with the specified name to the MAT-file, deleting any previously existing variable with that name in the MAT-file.-matSet :: MATFile +matSet :: MATFile -> 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. -> String -> MXArray a -> IO () matSet m g n v = do@@ -66,7 +66,7 @@ -- |Read the array value for the specified variable name from a MAT-file. matGet :: MATFile -> String -> IO (Maybe MAnyArray) matGet m n = do- a <- withMATFile m (withCString n . matGetVariable) + a <- withMATFile m (withCString n . matGetVariable) if a == nullPtr then return Nothing else Just =.< mkMXArray a@@ -103,12 +103,12 @@ where load m = alloca $ \n -> do a <- matGetNextVariable m n- if a == nullPtr - then return [] - else do- a <- mkMXArray a- n <- peek n >>= peekCString- ((n,a) :) =.< load m+ if a == nullPtr+ then return []+ else do+ a <- mkMXArray a+ n <- peek n >>= peekCString+ ((n,a) :) =.< load m -- |Write all the variables to a new MAT file matSave :: FilePath -> [(String,MXArray a)] -> IO ()
+ Foreign/Matlab/Optics.hsc view
@@ -0,0 +1,53 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A few Optics definitions used by this project. These definitions are either+-- | copied or copmatible with those from the `lens` package.+module Foreign.Matlab.Optics where++import Data.Coerce (Coercible, coerce)+import Data.Profunctor+import Data.Profunctor.Unsafe ((.#))++type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++type Lens' s a = Lens s s a a+++-- | Build a 'Lens' from a getter and a setter.+--+-- @+-- 'lens' :: 'Functor' f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t+-- @+--+-- >>> s ^. lens getter setter+-- getter s+--+-- >>> s & lens getter setter .~ b+-- setter s b+--+-- >>> s & lens getter setter %~ f+-- setter s (f (getter s))+--+-- @+-- 'lens' :: (s -> a) -> (s -> a -> s) -> 'Lens'' s a+-- @+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens sa sbt afb s = sbt s <$> afb (sa s)+{-# INLINE lens #-}++type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)+type Iso' s a = Iso s s a a++coerce' :: forall a b. Coercible a b => b -> a+coerce' = coerce (id :: a -> a)+{-# INLINE coerce' #-}++coerced :: forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b+# if __GLASGOW_HASKELL__ >= 710+coerced l = rmap (fmap coerce') l .# coerce+# else+coerced l = case sym Coercion :: Coercion a s of+ Coercion -> rmap (fmap coerce') l .# coerce+# endif+
Foreign/Matlab/Runtime.hsc view
@@ -28,7 +28,6 @@ , (<.>), (</>)) import Foreign.Matlab.Util import Foreign.Matlab.Internal- import System.IO.Unsafe (unsafePerformIO) #include "hsc_sym.h"
Foreign/Matlab/Runtime/Generic.hs view
@@ -60,7 +60,7 @@ mlGenericSetVar mlg v x = do b <- createRowVector "base" v <- createRowVector v- _ <- mlGenericFun mlg "assignin" [anyMXArray b,anyMXArray v,anyMXArray x] 0+ [] <- mlGenericFun mlg "assignin" [anyMXArray b,anyMXArray v,anyMXArray x] 0 freeMXArray v freeMXArray b
Foreign/Matlab/Types.hs view
@@ -35,11 +35,12 @@ -- * Opaque types MXArray,- MAnyArray,+ MAny, MAnyArray, MCell(MCell), mCell,- MStruct,+ MStruct, mStruct, MFun ) where+ import Data.Complex import Data.Ix
Setup.hs view
@@ -14,26 +14,26 @@ programs = [ simpleProgram "mcc" ] -runtime desc = maybe False (elem ["Foreign","Matlab","Runtime"] +runtime desc = maybe False (elem ["Foreign","Matlab","Runtime"] . map components . exposedModules) $ library desc build desc binfo hooks flags = do- when (runtime desc) $ + when (runtime desc) $ rawSystemExit (fromFlag $ buildVerbosity flags) "make" ["-Csrc"] buildHook defhooks desc binfo hooks flags clean desc binfo hooks flags = do makeExists <- doesFileExist "src/Makefile"- when makeExists $ + when makeExists $ rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["-Csrc", "clean"] cleanHook defhooks desc binfo hooks flags install desc binfo hooks flags = do instHook defhooks desc binfo hooks flags- when (runtime desc) $ mapM_ (\f -> - copyFileVerbose (fromFlag $ installVerbosity flags) - ("src" </> f) - (libdir (absoluteInstallDirs desc binfo NoCopyDest) </> f))+ when (runtime desc) $ mapM_ (\f ->+ copyFileVerbose (fromFlag $ installVerbosity flags)+ ("src" </> f)+ (libdir (absoluteInstallDirs desc binfo NoCopyDest) </> f)) ["libhsmatlab.so"] reg desc binfo hooks flags = do@@ -41,7 +41,7 @@ let desc' = desc{ library = fmap lm (library desc) } lm l = l { libBuildInfo = (libBuildInfo l)- { ldOptions = map ("-Wl,-rpath," ++) (extraLibDirs (libBuildInfo l) )+ { ldOptions = map ("-Wl,-rpath," ++) (extraLibDirs (libBuildInfo l) ) ++ ldOptions (libBuildInfo l), extraLibDirs = lib : extraLibDirs (libBuildInfo l) } } lib
+ hello/SpecHello.hs view
@@ -0,0 +1,8 @@+module Main where++-- This is mainly here to help in differential diagnosis,+-- as it is a Haskell program that does not touch MATLAB++main :: IO ()+main = putStrLn "Hello, world!"+
matlab.cabal view
@@ -1,8 +1,8 @@ Name: matlab-Version: 0.2.0.0+Version: 0.3.0.0 Cabal-Version: >= 1.10-Author: Dylan Simon, Ben Sherman-Maintainer: Ben Sherman <benmsherman@gmail.com>+Author: Dylan Simon, Ben Sherman, Brandon Barker+Maintainer: Brandon Barker <brandon.barker@cornell.edu> License: BSD3 License-file: LICENSE Synopsis: Matlab bindings and interface@@ -23,10 +23,11 @@ Bug-reports: https://github.com/bmsherman/haskell-matlab/issues build-type: Custom-tested-with: GHC == 7.8.3+tested-with: GHC == 8.6.5 extra-source-files: src/Makefile src/hsmatlab.m src/hsmatlab.c src/hsc_sym.h- test/Makefile test/engine.hs test/runtime.hs + test/Makefile test/runtime.hs test/generic.hs test/mtest.m test/hsmli.hs+ test/Test/Engine.hs Flag Engine Description: Enable Matlab engine (spawned eng process) support@@ -35,12 +36,14 @@ Description: Enable Matlab runtime (linked library) support default: False -Library+library default-language: Haskell2010- Build-depends: base >= 4 && < 5,- array < 0.6,- filepath < 1.4,- Cabal < 1.21+ Build-depends: base >= 4.0 && < 4.16,+ array >= 0.5 && < 0.6,+ filepath >= 1.4 && < 1.5,+ path >= 0.6 && < 0.7,+ profunctors >= 5.3 && < 5.4,+ Cabal >= 2.1 && < 2.5 Exposed-modules: Foreign.Matlab, Foreign.Matlab.Types, Foreign.Matlab.Array,@@ -48,8 +51,11 @@ Foreign.Matlab.Array.MArray, Foreign.Matlab.Array.IMX, Foreign.Matlab.Array.Able,+ Foreign.Matlab.Engine.Wrappers, Foreign.Matlab.MAT- Other-modules: Foreign.Matlab.Util, Foreign.Matlab.Internal+ Other-modules: Foreign.Matlab.Optics+ Foreign.Matlab.Util,+ Foreign.Matlab.Internal default-extensions: ForeignFunctionInterface, MultiParamTypeClasses, FunctionalDependencies,@@ -60,11 +66,12 @@ if flag(runtime) build-tools: mcc- Build-depends: unix < 2.8+ Build-depends: unix >= 2.7 && < 2.8 Exposed-modules: Foreign.Matlab.Runtime, Foreign.Matlab.Runtime.Generic if flag(engine) Exposed-modules: Foreign.Matlab.Engine+ Build-depends: containers >= 0.6 && < 0.7 extra-libraries: eng Source-repository head@@ -73,6 +80,52 @@ Source-repository this Type: git- Location: git://github.com/bmsherman/haskell-matlab/releases/tag/0.2.0.0.git- Tag: 0.2.0.0+ Location: git://github.com/bmsherman/haskell-matlab/releases/tag/0.3.0.0.git+ Tag: 0.3.0.0 +-- test-suite matlab-test+-- type: exitcode-stdio-1.0+-- main-is: Spec.hs+-- other-modules:+-- Test.Engine+-- hs-source-dirs:+-- test+-- ghc-options: -threaded -rtsopts -with-rtsopts=-N+-- build-depends:+-- base >= 4 && <5+-- , filepath+-- , matlab+-- , turtle >= 1.5+-- default-language: Haskell2010+-- extra-libraries: eng, mx, mat++executable matlab-engine-test+ main-is: SpecEngine.hs+ other-modules:+ Test.Engine+ Test.Util+ Test.UtilTemplate+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts+ build-depends:+ base+ , exceptions >= 0.10 && < 0.11+ , filepath+ , matlab+ , path+ , template-haskell >= 2.14 && < 2.15+ , text >= 1.2 && < 1.3+ default-language: Haskell2010+ extra-libraries: eng, mx, mat++executable haskell-hello+ main-is: SpecHello.hs+ other-modules:+ hs-source-dirs:+ hello+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base+ default-language: Haskell2010+ extra-libraries:
+ test/SpecEngine.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.Engine (engineTests)++main :: IO ()+main = engineTests+
+ test/Test/Engine.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Engine where++import Control.Exception (SomeException, assert, try)+import Data.Either (isLeft, isRight, lefts)+import Foreign.Matlab+import Foreign.Matlab.Engine+import Foreign.Matlab.Engine.Wrappers+import Language.Haskell.TH (Q, runIO)+import Language.Haskell.TH.Syntax (lift)+import Path+import Test.Util++engineTests = runEngineTests ""++runEngineTests :: String -> IO ()+runEngineTests host = do+ putStrLn "-- Starting engine --"+ eng <- newEngine host+ putStrLn "-- Engine created --"+ let testPath = repoDir </> testRel+ addpath eng testPath+ runLocalMatFun eng+ cosOfPi eng+ testIsMNull eng+ testGetFirstLast eng+ testAbstractValueUse eng+ testTypedAbstractValueUse eng+ testGetByteStreamFromArray eng+ testGetArrayFromByteStream eng+ testCellGet eng+ testClearVar eng++cosOfPi :: Engine -> IO ()+cosOfPi eng = do+ putStrLn "\n-- cos pi --"+ x <- createMXScalar (pi :: MDouble)+ cosBody eng "cos" x++runLocalMatFun :: Engine -> IO ()+runLocalMatFun eng = do+ putStrLn "\n-- mtest: cos pi --"+ x <- createMXScalar (pi :: MDouble)+ cosBody eng "mtest" x++cosBody :: Engine -> String -> MXArray MDouble -> IO ()+cosBody eng cosFun x = do+ [y] <- engineEvalFun eng cosFun [EvalArray x] 1+ mxArrayClass y >>= print+ Just y <- castMXArray y+ y <- mxScalarGet y+ print (y :: MDouble)++testIsMNull :: Engine -> IO ()+testIsMNull eng = do+ putStrLn $ "\n-- testIsMNull --"+ xa <- createMXScalar (1.0 :: MDouble)+ let xaRes = assert (isMNull xa == False) xa+ xaResEi <- mxArrayGetFirst xaRes+ putStrLn $ " xaResEi is Right: " <> (show xaResEi)+ xae :: MXArray MChar <- createMXArray []+ freeMXArray xae+ mxLen <- mxArrayLength xae+ mxDims <- mxArraySize xae+ putStrLn $ "length is " <> (show mxLen) <> " dims are " <> (show $ mxDims)+ let xaeRes = assert (isMNull xae == False) xae+ xaeResEi <- mxArrayGetFirst xaeRes+ putStrLn $ " xaeResEi is Left: " <> (show xaeResEi)++testGetFirstLast :: Engine -> IO ()+testGetFirstLast eng = do+ putStrLn $ "\n-- testGetFirstLast --"+ let testVal :: MDouble = 1.0+ xa <- createMXScalar testVal+ xfEi <- mxArrayGetFirst xa+ xlEi <- mxArrayGetLast xa+ let xRes = assert (xlEi == Right 1.0 && xfEi == xlEi) xfEi+ putStrLn $ " xRes is : " <> (show xRes)+ threeArray :: MXArray MDouble <- fromListIO [5.0, 6.0, 7.0]+ txfEi <- mxArrayGetFirst threeArray+ txlEi <- mxArrayGetLast threeArray+ let txfRes = assert (txfEi == Right 5.0) txfEi+ putStrLn $ " txfRes is : " <> (show txfRes)+ let txlRes = assert (txlEi == Right 7.0) txlEi+ putStrLn $ " txlRes is : " <> (show txlRes)+ +testAbstractValueUse :: Engine -> IO ()+testAbstractValueUse eng = do+ putStrLn $ "\n-- testAbstractValueUse --"+ sOut <- makeTestStruct eng+ sSum <- useTestStruct eng sOut+ let sSumRes = assert (sSum == 7.0) sSum+ putStrLn $ " struct sum is: " <> (show sSumRes)++makeTestStruct :: Engine -> IO MAnyArray+makeTestStruct eng = do+ [res] <- engineEvalFun eng "makeTestStruct" [] 1+ pure res++useTestStruct :: Engine -> MAnyArray -> IO MDouble+useTestStruct eng sIn = do+ [res] <- engineEvalFun eng "useTestStruct" [EvalArray sIn] 1+ mxArrMay <- castMXArray res+ case mxArrMay of+ Just mxArr -> mxScalarGet mxArr+ Nothing -> pure 0.0+++newtype MyAbsType = MyAbsType { unMyAbsType :: MAnyArray }++-- |Similar to testAbstractValueUse, but instead of using+-- |MAnyArray, we use newtypes for better type safety+testTypedAbstractValueUse :: Engine -> IO ()+testTypedAbstractValueUse eng = do+ putStrLn $ "\n-- testTypedAbstractValueUse --"+ sOut <- makeTestStructTyped eng+ sSum <- useTestStructTyped eng sOut+ let sSumRes = assert (sSum == 7.0) sSum+ putStrLn $ " struct sum is: " <> (show sSumRes)++makeTestStructTyped :: Engine -> IO MyAbsType+makeTestStructTyped eng = MyAbsType <$> (makeTestStruct eng)++useTestStructTyped :: Engine -> MyAbsType -> IO MDouble+useTestStructTyped eng (MyAbsType sIn) = useTestStruct eng sIn++testGetByteStreamFromArray :: Engine -> IO ()+testGetByteStreamFromArray eng = do+ putStrLn $ "\n-- testGetByteStreamFromArray --"+ sOutBSMatlab <- makeTestStructByteStream eng+ sOut <- makeTestStruct eng+ Right sOutBSHaskell <- getByteStreamFromArray eng sOut+ let bsSum = sum $ fromIntegral <$> (assert (sOutBSMatlab == sOutBSHaskell) sOutBSHaskell)+ putStrLn $ " bytestream sum is: " <> (show bsSum)++testGetArrayFromByteStream :: Engine -> IO ()+testGetArrayFromByteStream eng = do+ putStrLn $ "\n-- testGetArrayFromByteStream --"+ sOutBS <- makeTestStructByteStream eng+ sOutFromBS <- getArrayFromByteStream eng sOutBS+ sOut <- makeTestStruct eng+ sSumFromBS <- useTestStruct eng sOutFromBS+ sSum <- useTestStruct eng sOut+ let sSumRes = assert (sSumFromBS == sSum) sSumFromBS+ putStrLn $ " deserialized struct sum is: " <> (show sSumRes)++makeTestStructByteStream :: Engine -> IO [MUint8]+makeTestStructByteStream eng = do+ [res] <- engineEvalFun eng "makeTestStructByteStream" [] 1+ mxArrMay <- castMXArray res+ case mxArrMay of+ Just mxArr -> mxArrayGetAll mxArr+ Nothing -> pure []++-- TODO: display cell array and extracted values in test+testCellGet :: Engine -> IO ()+testCellGet eng = do+ putStrLn "\n-- testCellGet --"+ [ca] <- engineEvalFun eng "mcellTest" [] 1+ Just (ca :: MXArray MCell) <- castMXArray ca+ caLen <- mxArrayLength ca+ let caLenMsg = assert (caLen == 6) "cell array has length 6"+ putStrLn caLenMsg+ dCells :: [MXArray MDouble] <- mxCellGetArraysOfType ca+ let dCellsMsg = assert (length dCells == 4) "cell array has 4 double arrays"+ putStrLn dCellsMsg+ dVals :: [MDouble] <- mxCellGetAllOfType ca+ let dValsMsg = assert (length dVals == 4) "cell array has 4 double values"+ putStrLn dValsMsg++testClearVar :: Engine -> IO ()+testClearVar eng = do+ putStrLn $ "\n-- testClearVar --"+ let foopi = "foopi"+ x <- createMXScalar (pi :: MDouble)+ engineSetVar eng foopi x+ ei1 :: Either SomeException MAnyArray <- try $ engineGetVar eng foopi+ putStrLn $ assert (isRight ei1) " Can clearVar once"+ clearVar eng foopi+ ei2 :: Either SomeException MAnyArray <- try $ engineGetVar eng foopi+ putStrLn $ assert (isLeft ei2) $+ " Can't clearVar twice: " <> (show $ lefts [ei2])+ putStrLn " Finished testClearVar"+++testRel :: Path Rel Dir+testRel = $(mkRelDir "test")++repoDir :: Path Abs Dir+repoDir = $(mkAbsDir getRepoDirStatic)
+ test/Test/Util.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Util where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class+import qualified Control.Exception as E+import Control.Monad (join)+-- import Data.AEq+-- import Data.CallStack+import Data.Either (fromRight)+import qualified Data.Text as Txt+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Path+import System.Environment+-- import Test.HUnit.Lang (FailureReason(..), HUnitFailure(..))+import Test.UtilTemplate++getRepoDirStatic :: String+getRepoDirStatic = $(lift . toFilePath =<< runIO getRepoDir)+++-- fromRightTst :: Either a b -> b+-- fromRightTst = (fromRight undefined)++-- assertEqualFP :: (AEq a, Show a) => [Char] -> a -> a -> IO ()+-- assertEqualFP preface e a = unless (a === e) $ unequalBody preface e a++-- assertApproxFP :: (AEq a, Show a) => [Char] -> a -> a -> IO ()+-- assertApproxFP preface e a = unless (a ~== e) $ unequalBody preface e a++-- unequalBody :: (Show a1, Show a2) => [Char] -> a2 -> a1 -> IO ()+-- unequalBody preface expected actual = do+-- (prefaceMsg `deepseq` expectedMsg `deepseq` actualMsg `deepseq` E.throwIO+-- (HUnitFailure location $ ExpectedButGot prefaceMsg expectedMsg actualMsg))+-- where+-- prefaceMsg+-- | null preface = Nothing+-- | otherwise = Just preface+-- expectedMsg = show expected+-- actualMsg = show actual++-- -- | As copied from https://hackage.haskell.org/package/HUnit-1.6.0.0/docs/src/Test.HUnit.Lang.html#location+-- location :: HasCallStack => Maybe SrcLoc+-- location = case reverse callStack of+-- (_, loc) : _ -> Just loc+-- [] -> Nothing
+ test/Test/UtilTemplate.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.UtilTemplate where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class+import qualified Control.Exception as E+import qualified Data.Text as Txt+import Language.Haskell.TH (Exp, Q, runIO)+import Path+import System.Environment++getRepoDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)+getRepoDir = do+ testExePath <- liftIO $ getEnv "PWD"+ repoPath <- pure $ parseAbsDir $ Txt.unpack $ fst $ Txt.breakOn+ (Txt.pack "FarmDataServer/.stack-work") (Txt.pack testExePath)+ repoPath
− test/engine.hs
@@ -1,12 +0,0 @@-import Foreign.Matlab-import Foreign.Matlab.Engine--main = do- eng <- newEngine Nothing- putStrLn "ready"- x <- createMXScalar (pi :: MDouble)- [y] <- engineEvalFun eng "cos" [EvalArray x] 1- mxArrayClass y >>= print- Just y <- castMXArray y- y <- mxScalarGet y- print (y :: MDouble)