diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Your name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/wrapper.c b/cbits/wrapper.c new file mode 100644 --- /dev/null +++ b/cbits/wrapper.c @@ -0,0 +1,15 @@ + +#include "libmyo.h" +#include + +void myo_string_free(libmyo_string_t s) { + libmyo_string_free(s); +} + +void myo_error_details_free(libmyo_error_details_t t) { + if (t != NULL) libmyo_free_error_details(t); +} + +void myo_hub_free(libmyo_hub_t h) { + if (h != NULL) libmyo_shutdown_hub(h, NULL); +} diff --git a/examples/WS.hs b/examples/WS.hs new file mode 100644 --- /dev/null +++ b/examples/WS.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import qualified Data.Aeson as JSON +import Network.WebSockets +import Myo.WebSockets +import Control.Monad +import Lens.Family2 + +main :: IO () +main = runClient "localhost" 10138 "/myo/3?appid=com.example.appid" myoWS + +myoWS :: Connection -> IO () +myoWS conn = forever $ do + newData <- receiveData conn + let (msg :: Either String MyoFrame) = JSON.eitherDecode' newData + case msg of + Left e -> do + putStrLn e + putStrLn (show newData) + Right (Event my) -> case my ^. mye_type of + EVT_Paired -> putStrLn "MYO PAIRED!" + EVT_Connected -> putStrLn "MYO CONNECTED!" + EVT_Pose -> case my ^. mye_pose of + Nothing -> putStrLn "GOT A POSE!" + Just p -> putStrLn $ "GOT POSE: " ++ show p + EVT_Arm_Synced -> putStrLn "MYO ARM SYNCED" + EVT_Arm_Unsynced -> putStrLn "MYO ARM UNSYNCED" + _ -> return () diff --git a/myo.cabal b/myo.cabal new file mode 100644 --- /dev/null +++ b/myo.cabal @@ -0,0 +1,91 @@ +name: myo +version: 0.1.0.0 +synopsis: Haskell binding to the Myo armband +description: Please see README.md +homepage: http://github.com/adinapoli/myo +license: MIT +license-file: LICENSE +author: Alfredo Di Napoli +maintainer: alfredo.dinapoli@gmail.com +-- copyright: +category: System +build-type: Simple +-- extra-source-files: + +cabal-version: >=1.10 + +library + hs-source-dirs: src + include-dirs: + include + exposed-modules: + Myo + Myo.WebSockets + Myo.WebSockets.Types + Myo.Foreign.Hub + Myo.Foreign.Hub.Types + Myo.Foreign.Types + Myo.Foreign.Result + Myo.Foreign.String + Myo.Foreign.String.Types + Myo.Foreign.Device + Myo.Foreign.Locking + Myo.Foreign.Event + Myo.Foreign.Handler + build-depends: + base >= 4.7 && < 5, + containers, + template-haskell, + websockets, + aeson, + lens-family, + lens-family-th, + vector, + text, + scientific, + inline-c + extra-libraries: + stdc++ + ld-options: + -framework myo + other-extensions: + TemplateHaskell + QuasiQuotes + OverloadedStrings + c-sources: + cbits/wrapper.c + src/Myo.c + src/Myo/Foreign/String.c + src/Myo/Foreign/String/Types.c + src/Myo/Foreign/Types.c + src/Myo/Foreign/Hub.c + src/Myo/Foreign/Hub/Types.c + ghc-options: + -Wall + + default-language: Haskell2010 + +executable myo-ws-example + hs-source-dirs: examples + main-is: WS.hs + build-depends: base + , myo + , websockets + , aeson + ,lens-family + default-language: Haskell2010 + +test-suite myo-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Tests.hs + build-depends: base + , myo + , tasty + , tasty-hunit + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/adinapoli/myo diff --git a/src/Myo.c b/src/Myo.c new file mode 100644 --- /dev/null +++ b/src/Myo.c @@ -0,0 +1,74 @@ + +#include "libmyo.h" + +#include + +#include "wrapper.h" + +void inline_c_Myo_0_8a356f0fa910bb8b8831c109c51000723e3c4d4b(libmyo_error_details_t ed_27_inline_c_0, libmyo_result_t * resPtr_inline_c_1) { + + libmyo_result_t r = libmyo_error_kind(ed_27_inline_c_0); + memmove(resPtr_inline_c_1 + , &r + , sizeof(libmyo_result_t) + ); + +} + + +const char * inline_c_Myo_1_79bcd9dad570978d588a7fdfd305a8c8c5dc82db(libmyo_error_details_t ed_27_inline_c_0) { +return ( libmyo_error_cstring(ed_27_inline_c_0) ); +} + + +void inline_c_Myo_2_b1135c706f85aba73a458ba622c6082422b76325(libmyo_hub_t h_27_inline_c_0, libmyo_locking_policy_t * lp_27_inline_c_1, libmyo_error_details_t ed_27_inline_c_2, libmyo_result_t * resPtr_inline_c_3) { + + libmyo_result_t r = libmyo_set_locking_policy( + h_27_inline_c_0 + , *lp_27_inline_c_1 + , &ed_27_inline_c_2 + ); + memmove(resPtr_inline_c_3 + , &r + , sizeof(libmyo_result_t) + ); + +} + + +uint64_t inline_c_Myo_3_76ef5b24d42ab668d1d8851f3f948fc2a44c31fe(libmyo_myo_t myo_inline_c_0) { +return ( libmyo_get_mac_address(myo_inline_c_0)); +} + + +void inline_c_Myo_4_6a9cce20aa4bf910286093a6c81fd50a27a8f95d(libmyo_myo_t d_inline_c_0, libmyo_vibration_type_t * vibPtr_inline_c_1, libmyo_error_details_t ed_inline_c_2, libmyo_result_t * resPtr_inline_c_3) { + + libmyo_result_t r = libmyo_vibrate( + d_inline_c_0 + , *vibPtr_inline_c_1 + , &ed_inline_c_2 + ); + memmove(resPtr_inline_c_3 + , &r + , sizeof(libmyo_result_t) + ); + +} + + +void inline_c_Myo_5_1a45ee2e6fc626f18feb7a5e33f1bd7f0ca56492(libmyo_hub_t h_27_inline_c_0, unsigned dur_inline_c_1, libmyo_handler_t hdlr_inline_c_2, void * ud_27_inline_c_3, libmyo_error_details_t ed_27_inline_c_4, libmyo_result_t * resPtr_inline_c_5) { + + libmyo_result_t r = libmyo_run( + h_27_inline_c_0 + , dur_inline_c_1 + , hdlr_inline_c_2 + , ud_27_inline_c_3 + , ed_27_inline_c_4 + ); + memmove(resPtr_inline_c_5 + , &r + , sizeof(libmyo_result_t) + ); + +} + diff --git a/src/Myo.hs b/src/Myo.hs new file mode 100644 --- /dev/null +++ b/src/Myo.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards #-} +module Myo ( + module Myo.Foreign.Types + , module Myo.Foreign.Hub + , module Myo.Foreign.String + , errorKind + , errorCString + , getMacAddress + , setLockingPolicy + , vibrate + , run +) where + +import qualified Language.C.Inline as C + +import Data.Word +import Data.Monoid +import Myo.Foreign.Types +import Myo.Foreign.String +import Myo.Foreign.Hub +import Myo.Foreign.Hub.Types +import Foreign.C.String +import Foreign.ForeignPtr +import Foreign.Storable +import Foreign.Marshal.Alloc + +C.context (myoCtx <> hubCtx) +C.include "libmyo.h" +C.include "" +C.include "wrapper.h" + +------------------------------------------------------------------------------- +errorKind :: ErrorDetails -> IO Result +errorKind ed = withForeignPtr ed $ \ed' -> do + alloca $ \resPtr -> do + [C.block| void { + libmyo_result_t r = libmyo_error_kind($(libmyo_error_details_t ed')); + memmove($(libmyo_result_t* resPtr) + , &r + , sizeof(libmyo_result_t) + ); + } + |] + peek resPtr + +------------------------------------------------------------------------------- +errorCString :: ErrorDetails -> IO CString +errorCString ed = withForeignPtr ed $ \ed' -> do + [C.exp| const char* { libmyo_error_cstring($(libmyo_error_details_t ed')) }|] + +------------------------------------------------------------------------------- +-- Set the locking policy for Myos connected to the hub. +-- @returns libmyo_success if the locking policy is successfully set, otherwise +-- - libmyo_error_invalid_argument if \a hub is NULL +-- - libmyo_error if \a hub is not a valid hub +-- libmyo_result_t libmyo_set_locking_policy(libmyo_hub_t hub, libmyo_locking_policy_t locking_policy, +-- libmyo_error_details_t* out_error); +setLockingPolicy :: MyoHub -> LockingPolicy -> ErrorDetails -> IO Result +setLockingPolicy h lp ed = withForeignPtr h $ \h' -> + withForeignPtr ed $ \ed' -> do + alloca $ \lp' -> do + poke lp' lp + alloca $ \resPtr -> do + [C.block| void { + libmyo_result_t r = libmyo_set_locking_policy( + $(libmyo_hub_t h') + , *$(libmyo_locking_policy_t* lp') + , &$(libmyo_error_details_t ed') + ); + memmove($(libmyo_result_t* resPtr) + , &r + , sizeof(libmyo_result_t) + ); + } + |] + peek resPtr + +-- | Retrieve the MAC address of a Myo. +-- The MAC address is unique to the physical Myo, and is a 48-bit number. +-- uint64_t libmyo_get_mac_address(libmyo_myo_t myo); +getMacAddress :: MyoDevice -> IO Word64 +getMacAddress md = withForeignPtr md $ \myo -> do + [C.exp| uint64_t { libmyo_get_mac_address($(libmyo_myo_t myo))} |] + +-- | Vibrate the given myo. +-- Can be called when a Myo is paired. +-- @returns libmyo_success if the Myo successfully vibrated, otherwise +-- - libmyo_error_invalid_argument if \a myo is NULL +vibrate :: MyoDevice -> Vibration -> ErrorDetails -> IO Result +vibrate device vib eDetails = withForeignPtr device $ \d -> + withForeignPtr eDetails $ \ed -> do + alloca $ \resPtr -> do + alloca $ \vibPtr -> do + poke vibPtr vib + [C.block| void { + libmyo_result_t r = libmyo_vibrate( + $(libmyo_myo_t d) + , *$(libmyo_vibration_type_t* vibPtr) + , &$(libmyo_error_details_t ed) + ); + memmove($(libmyo_result_t* resPtr) + , &r + , sizeof(libmyo_result_t) + ); + } + |] + peek resPtr + +type Duration = Int + +-- | Process events and call the provided callback as they occur. +-- Runs for up to approximately \a duration_ms milliseconds or until a called handler returns libmyo_handler_stop. +-- @returns libmyo_success after a successful run, otherwise +-- - libmyo_error_invalid_argument if \a hub is NULL +-- - libmyo_error_invalid_argument if \a handler is NULL +-- libmyo_result_t libmyo_run(libmyo_hub_t hub, unsigned int duration_ms, libmyo_handler_t handler, void* user_data, +-- libmyo_error_details_t* out_error); +run :: MyoHub + -> Duration + -> Handler + -> UserData + -> ErrorDetails + -> IO Result +run h dur_ms hdlr ud ed = do + let dur = fromIntegral dur_ms + withForeignPtr h $ \h' -> do + withForeignPtr ed $ \ed' -> do + withForeignPtr ud $ \ud' -> do + alloca $ \resPtr -> do + [C.block| void { + libmyo_result_t r = libmyo_run( + $(libmyo_hub_t h') + , $(unsigned int dur) + , $(libmyo_handler_t hdlr) + , $(void * ud') + , $(libmyo_error_details_t ed') + ); + memmove($(libmyo_result_t* resPtr) + , &r + , sizeof(libmyo_result_t) + ); + } + |] + peek resPtr diff --git a/src/Myo/Foreign/Device.hsc b/src/Myo/Foreign/Device.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Device.hsc @@ -0,0 +1,30 @@ +module Myo.Foreign.Device where + +import Foreign.Storable +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C.Types + +#include "libmyo.h" + +data MyoDevice_t +type MyoDevice = ForeignPtr MyoDevice_t + +data Vibration = + VibrationShort + | VibrationMedium + | VibrationLong + +instance Storable Vibration where + sizeOf _ = (#size libmyo_vibration_type_t) + alignment _ = alignment (undefined :: Ptr Vibration) + peek ptr = do + v <- peekByteOff ptr 0 + return $ case (v :: CInt) of + 0 -> VibrationShort + 1 -> VibrationMedium + _ -> VibrationLong + poke p v = case v of + VibrationShort -> pokeByteOff p 0 (0 :: Int) + VibrationMedium -> pokeByteOff p 1 (1 :: Int) + VibrationLong -> pokeByteOff p 2 (2 :: Int) diff --git a/src/Myo/Foreign/Event.hsc b/src/Myo/Foreign/Event.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Event.hsc @@ -0,0 +1,42 @@ + +module Myo.Foreign.Event where + +import Foreign.Storable +import Foreign.Ptr +import Foreign.ForeignPtr + +#include "libmyo.h" + +data EventType = + Paired -- ^ Successfully paired with a Myo. + | Unpaired -- ^ Successfully unpaired from a Myo. + | Connected -- ^ A Myo has successfully connected. + | Disconnected -- ^ A Myo has been disconnected. + | ArmSynced -- ^ A Myo has recognized that the sync gesture has been successfully performed. + | ArmUnsynced -- ^ A Myo has been moved or removed from the arm. + | Orientation -- ^ Orientation data has been received. + | Pose -- ^ A change in pose has been detected. @see libmyo_pose_t. + | Rssi -- ^ An RSSI value has been received. + | Unlocked -- ^ A Myo has become unlocked. + | Locked -- ^ A Myo has become locked. + | Emg -- ^ EMG data has been received. + | BatteryLevel -- ^ A battery level value has been received. + | WarmupCompleted -- ^ The warmup period has completed. + deriving (Show, Eq, Ord, Bounded, Enum) + +instance Storable EventType where + sizeOf _ = (#size libmyo_event_type_t) + alignment _ = alignment (undefined :: Ptr EventType) + peek ptr = do + v <- peekByteOff ptr 0 + return $ toEnum v + poke p v = let e = fromEnum v in pokeByteOff p e e + +data Event_t +type Event = ForeignPtr Event_t + +instance Storable Event_t where + sizeOf _ = (#size libmyo_event_t) + alignment _ = alignment (undefined :: Ptr Event_t) + peek _ = error "Event_t.peek: Absurd" + poke _ _ = error "Event_t.poke: Absurd" diff --git a/src/Myo/Foreign/Handler.hsc b/src/Myo/Foreign/Handler.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Handler.hsc @@ -0,0 +1,27 @@ +module Myo.Foreign.Handler where + +import Foreign.Storable +import Foreign.Ptr +import Foreign.ForeignPtr + +import Myo.Foreign.Event + +#include "libmyo.h" + +data HandlerResult = + Continue -- ^ Continue processing events + | Stop -- ^ Stop processing events + deriving (Show, Eq, Ord, Bounded, Enum) + +instance Storable HandlerResult where + sizeOf _ = (#size libmyo_handler_result_t) + alignment _ = alignment (undefined :: Ptr HandlerResult) + peek ptr = do + v <- peekByteOff ptr 0 + return $ toEnum v + poke p v = let e = fromEnum v in pokeByteOff p e e + + +type Handler = FunPtr (UserData -> Event -> HandlerResult) + +type UserData = ForeignPtr () diff --git a/src/Myo/Foreign/Hub.c b/src/Myo/Foreign/Hub.c new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Hub.c @@ -0,0 +1,14 @@ + +#include "libmyo.h" + +#include + +void inline_c_Myo_Foreign_Hub_0_6d0ace92dadbe060f2a38f3d76d724cdf8afc520(libmyo_hub_t h_27_inline_c_0, const char * aid_inline_c_1, libmyo_error_details_t e_27_inline_c_2, libmyo_result_t * resPtr_inline_c_3) { + + libmyo_result_t r = libmyo_init_hub( &h_27_inline_c_0 + , aid_inline_c_1 + , &e_27_inline_c_2); + memmove(resPtr_inline_c_3 ,&r, sizeof(libmyo_result_t)); + +} + diff --git a/src/Myo/Foreign/Hub.hsc b/src/Myo/Foreign/Hub.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Hub.hsc @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards #-} +module Myo.Foreign.Hub ( + -- * Low level functions + initHub + , freeHub + , freeErrorDetails + -- * High level functions + , newHub + ) where + +import qualified Language.C.Inline as C +import Data.Monoid +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.C.String +import Foreign.Storable +import Foreign.Marshal.Alloc + +import Myo.Foreign.Types +import Myo.Foreign.Hub.Types + +C.context (myoCtx <> hubCtx) +C.include "libmyo.h" +C.include "" + +{- +Initialize a connection to the hub. +\a application_identifier must follow a reverse domain name format (ex. com.domainname.appname). Application +identifiers can be formed from the set of alphanumeric ASCII characters (a-z, A-Z, 0-9). The hyphen (-) and +underscore (_) characters are permitted if they are not adjacent to a period (.) character (i.e. not at the start or +end of each segment), but are not permitted in the top-level domain. Application identifiers must have three or more +segments. For example, if a company's domain is example.com and the application is named hello-world, one could use +"com.example.hello-world" as a valid application identifier. \a application_identifier can be NULL or empty. +@returns libmyo_success if the connection is successfully established, otherwise: + - libmyo_error_runtime if a connection could not be established + - libmyo_error_invalid_argument if \a out_hub is NULL + - libmyo_error_invalid_argument if \a application_identifier is longer than 255 characters + - libmyo_error_invalid_argument if \a application_identifier is not in the proper reverse domain name format +-} + +initHub :: MyoHub -> ApplicationID -> ErrorDetails -> IO Result +initHub h aid e = withForeignPtr h $ \h' -> + withForeignPtr e $ \e' -> do + alloca $ \resPtr -> do + [C.block| void { + libmyo_result_t r = libmyo_init_hub( &$(libmyo_hub_t h') + , $(const char* aid) + , &$(libmyo_error_details_t e')); + memmove($(libmyo_result_t* resPtr) ,&r, sizeof(libmyo_result_t)); + } + |] + peek resPtr + +------------------------------------------------------------------------------- +-- | Free the resources allocated by the ErrorDetails object. +foreign import ccall "wrapper.h &myo_error_details_free" + freeErrorDetails :: FunPtr (Ptr ErrorDetails_t -> IO ()) + +------------------------------------------------------------------------------- +-- | Free the resources allocated by the ErrorDetails object. +foreign import ccall "wrapper.h &myo_hub_free" + freeHub :: FunPtr (Ptr Hub_t -> IO ()) + +------------------------------------------------------------------------------- +-- | High-level function to create a new Hub. +newHub :: String -> IO (Either ErrorReport MyoHub) +newHub aid = do + hub <- malloc >>= newForeignPtr_ -- freeHub + eDetails <- malloc >>= newForeignPtr_ --freeErrorDetails + aId <- newCString aid + r <- initHub hub aId eDetails + case r of + Success -> return $ Right hub + _ -> return $ Left (ErrorReport r eDetails) diff --git a/src/Myo/Foreign/Hub/Types.c b/src/Myo/Foreign/Hub/Types.c new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Hub/Types.c @@ -0,0 +1,4 @@ + +#include "libmyo.h" + +#include diff --git a/src/Myo/Foreign/Hub/Types.hsc b/src/Myo/Foreign/Hub/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Hub/Types.hsc @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards #-} +module Myo.Foreign.Hub.Types where + +import qualified Language.C.Inline as C +import Language.C.Inline.Context +import qualified Language.Haskell.TH as TH +import qualified Language.C.Types as C +import qualified Data.Map.Strict as Map +import Data.Monoid +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable + +#include "libmyo.h" +C.include "libmyo.h" +C.include "" + +data Hub_t +type MyoHub = ForeignPtr Hub_t + +instance Storable Hub_t where + sizeOf _ = (#size libmyo_hub_t) + alignment _ = alignment (undefined :: Ptr Hub_t) + peek _ = error "Hub_t.peek: Absurd" + poke _ _ = error "Hub_t.poke: Absurd" + +hubCtx :: Context +hubCtx = mempty { ctxTypesTable = hubTable } + +hubTable :: Map.Map C.TypeSpecifier TH.TypeQ +hubTable = Map.fromList + [ (C.TypeName "libmyo_hub_t", [t| Ptr Hub_t |]) + ] diff --git a/src/Myo/Foreign/Locking.hsc b/src/Myo/Foreign/Locking.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Locking.hsc @@ -0,0 +1,17 @@ +module Myo.Foreign.Locking where + +import Foreign.Ptr +import Foreign.Storable + +#include "libmyo.h" + +data LockingPolicy = None | Standard + deriving (Show, Eq, Ord, Bounded, Enum) + +instance Storable LockingPolicy where + sizeOf _ = (#size libmyo_locking_policy_t) + alignment _ = alignment (undefined :: Ptr LockingPolicy) + peek ptr = do + v <- peekByteOff ptr 0 + return $ toEnum v + poke p v = let e = fromEnum v in pokeByteOff p e e diff --git a/src/Myo/Foreign/Result.hsc b/src/Myo/Foreign/Result.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Result.hsc @@ -0,0 +1,35 @@ +module Myo.Foreign.Result where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable + +#include "libmyo.h" + +data Result = + Success + | Error + | InvalidArgument + | RuntimeError + deriving (Show, Eq, Ord, Bounded, Enum) + +data ErrorReport = + ErrorReport Result ErrorDetails + deriving (Show, Eq, Ord) + +data ErrorDetails_t +type ErrorDetails = ForeignPtr ErrorDetails_t + +instance Storable ErrorDetails_t where + sizeOf _ = (#size libmyo_error_details_t) + alignment _ = alignment (undefined :: Ptr ErrorDetails) + peek _ = error "ErrorDetails_t.peek: Absurd" + poke _ _ = error "ErrorDetails_t.poke: Absurd" + +instance Storable Result where + sizeOf _ = (#size libmyo_result_t) + alignment _ = alignment (undefined :: Ptr Result) + peek ptr = do + v <- peekByteOff ptr 0 + return $ toEnum v + poke p v = let e = fromEnum v in pokeByteOff p e e diff --git a/src/Myo/Foreign/String.c b/src/Myo/Foreign/String.c new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/String.c @@ -0,0 +1,21 @@ + +#include "libmyo.h" + +#include "wrapper.h" + +const char * inline_c_Myo_Foreign_String_0_817cf39fc030b767c64bf15739f8ce47d8341d52(libmyo_string_t ms_inline_c_0) { +return ( libmyo_string_c_str(ms_inline_c_0) ); +} + + +libmyo_string_t inline_c_Myo_Foreign_String_1_322eef913ad66043ba6f6f6786116e88e2976984(uint64_t i_inline_c_0) { +return ( + libmyo_mac_address_to_string(i_inline_c_0) + ); +} + + +uint64_t inline_c_Myo_Foreign_String_2_509e55339657b08ea171a116a2858442cc7a7b25(const char * sPtr_inline_c_0) { +return ( libmyo_string_to_mac_address(sPtr_inline_c_0) ); +} + diff --git a/src/Myo/Foreign/String.hs b/src/Myo/Foreign/String.hs new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/String.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Myo.Foreign.String where + +import qualified Language.C.Inline as C + +import Myo.Foreign.String.Types +import Myo.Foreign.Types +import Foreign.C.String +import Foreign.ForeignPtr +import Foreign.Ptr +import Data.Word +import Data.Monoid + +C.context (myoCtx <> stringCtx) +C.include "libmyo.h" +C.include "wrapper.h" + +------------------------------------------------------------------------------- +fromMyoString :: MyoString -> IO CString +fromMyoString sPtr = withForeignPtr sPtr $ \ms -> do + [C.exp| const char* { libmyo_string_c_str($(libmyo_string_t ms)) } |] + +------------------------------------------------------------------------------- +macAddressToString :: Word64 -> IO MyoString +macAddressToString i = do + newStr <- [C.exp| libmyo_string_t { + libmyo_mac_address_to_string($(uint64_t i)) + } + |] + newForeignPtr freeMyoString newStr + +------------------------------------------------------------------------------- +stringToMacAddress :: CString -> Word64 +stringToMacAddress sPtr = [C.pure| uint64_t { libmyo_string_to_mac_address($(const char* sPtr)) } |] + +------------------------------------------------------------------------------- +-- | Free the resources allocated by the string object. +foreign import ccall "wrapper.h &myo_string_free" + freeMyoString :: FunPtr (Ptr MyoString_t -> IO ()) diff --git a/src/Myo/Foreign/String/Types.c b/src/Myo/Foreign/String/Types.c new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/String/Types.c @@ -0,0 +1,2 @@ + +#include "libmyo.h" diff --git a/src/Myo/Foreign/String/Types.hsc b/src/Myo/Foreign/String/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/String/Types.hsc @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards #-} +module Myo.Foreign.String.Types ( + MyoString_t + , MyoString + , stringCtx + ) where + +import Data.Monoid + +import Language.C.Inline.Context +import qualified Language.Haskell.TH as TH +import qualified Language.C.Types as C +import qualified Language.C.Inline as C +import qualified Data.Map.Strict as Map + +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable + +#include "libmyo.h" +C.include "libmyo.h" + +data MyoString_t +type MyoString = ForeignPtr MyoString_t + +instance Storable MyoString_t where + sizeOf _ = (#size libmyo_string_t) + alignment _ = alignment (undefined :: Ptr MyoString) + peek _ = error "MyoString_t.peek: Absurd" + poke _ _ = error "MyoString_t.poke: Absurd" + +stringCtx :: Context +stringCtx = mempty { ctxTypesTable = typesTable } + +typesTable :: Map.Map C.TypeSpecifier TH.TypeQ +typesTable = Map.fromList + [ (C.TypeName "libmyo_string_t", [t| Ptr MyoString_t |]) ] diff --git a/src/Myo/Foreign/Types.c b/src/Myo/Foreign/Types.c new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Types.c @@ -0,0 +1,2 @@ + +#include "libmyo.h" diff --git a/src/Myo/Foreign/Types.hsc b/src/Myo/Foreign/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Myo/Foreign/Types.hsc @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, RecordWildCards #-} +module Myo.Foreign.Types ( + module Myo.Foreign.Device + , module Myo.Foreign.Result + , module Myo.Foreign.Locking + , module Myo.Foreign.Event + , module Myo.Foreign.Handler + , myoCtx + , ApplicationID + ) where + +import Data.Monoid + +import Language.C.Inline.Context +import qualified Language.Haskell.TH as TH +import qualified Language.C.Types as C +import qualified Language.C.Inline as C +import qualified Data.Map.Strict as Map + +import Foreign.Ptr +import Foreign.C.String +import Myo.Foreign.Device +import Myo.Foreign.Result +import Myo.Foreign.Locking +import Myo.Foreign.Event +import Myo.Foreign.Handler + +#include "libmyo.h" +C.include "libmyo.h" + +type ApplicationID = CString + +myoCtx :: Context +myoCtx = baseCtx <> funCtx <> vecCtx <> mempty { ctxTypesTable = typesTable } + +typesTable :: Map.Map C.TypeSpecifier TH.TypeQ +typesTable = Map.fromList + [ (C.TypeName "libmyo_vibration_type_t", [t| Vibration |]) + , (C.TypeName "libmyo_result_t", [t| Result |]) + , (C.TypeName "libmyo_error_details_t", [t| Ptr ErrorDetails_t |]) + , (C.TypeName "libmyo_myo_t", [t| Ptr MyoDevice_t |]) + , (C.TypeName "libmyo_locking_policy_t", [t| LockingPolicy |]) + , (C.TypeName "libmyo_event_type_t", [t| EventType |]) + , (C.TypeName "libmyo_event_t", [t| Ptr Event_t |]) + , (C.TypeName "libmyo_handler_result_t", [t| HandlerResult |]) + , (C.TypeName "libmyo_handler_t", [t| Handler |]) + ] diff --git a/src/Myo/WebSockets.hs b/src/Myo/WebSockets.hs new file mode 100644 --- /dev/null +++ b/src/Myo/WebSockets.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +module Myo.WebSockets ( + module Myo.WebSockets.Types + , ApplicationID + , APIVersion(..) + , renderAPIVersion + ) where + +--import Network.WebSockets +import Myo.WebSockets.Types +import qualified Data.Text as T + +data APIVersion = V3 + +type ApplicationID = T.Text + +renderAPIVersion :: APIVersion -> T.Text +renderAPIVersion V3 = "3" + +{- +connect :: APIVersion + -> ApplicationID + -- ^ The Myo ApplicationID + -> String + -- ^ Host + -> Int + -- ^ Port + -> IO a +connect apiVr aId host port = do + runClient host port (T.unpack $ "/myo/" <> renderAPIVersion <> "?appid=" <> aId) + 127.0.0.1:10138/myo/?appid=com.example.appid +-} diff --git a/src/Myo/WebSockets/Types.hs b/src/Myo/WebSockets/Types.hs new file mode 100644 --- /dev/null +++ b/src/Myo/WebSockets/Types.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Myo.WebSockets.Types where + +import Data.Aeson.TH +import Data.Int +import Data.Scientific +import Data.Aeson.Types +import Data.Char +import Control.Monad +import Control.Applicative +import Lens.Family2.TH +import qualified Data.Vector as V +import qualified Data.Text as T + +------------------------------------------------------------------------------- +data MyoEventType = + EVT_Paired + | EVT_Battery_Level + | EVT_Locked + | EVT_Unlocked + | EVT_Warmup_Completed + | EVT_Connected + | EVT_Disconnected + | EVT_Arm_Synced + | EVT_Arm_Unsynced + | EVT_Orientation + | EVT_Pose + | EVT_RSSI + | EVT_EMG + deriving (Show, Eq) + +------------------------------------------------------------------------------- +type MyoID = Integer + +------------------------------------------------------------------------------- +data MyoVersion = MyoVersion { + _myv_major :: !Integer + , _myv_minor :: !Integer + , _myv_patch :: !Integer + , _myv_hardware :: !Integer + } deriving (Show, Eq) + +------------------------------------------------------------------------------- +-- It's an 8 bit integer +data EMG = EMG Int8 deriving (Show, Eq) + +------------------------------------------------------------------------------- +data MyoPose = + Rest + | Fist + | Wave_In + | Wave_Out + | Fingers_Spread + | Double_Tap + | Unknown + deriving (Show, Eq) + +data Orientation = Orientation { + _ori_x :: !Double + , _ori_y :: !Double + , _ori_z :: !Double + , _ori_w :: !Double + } deriving (Show, Eq) + +data Accelerometer = Accelerometer { + _acc_x :: !Double + , _acc_y :: !Double + , _acc_z :: !Double + } deriving (Show, Eq) + +data Gyroscope = Gyroscope { + _gyr_x :: !Double + , _gyr_y :: !Double + , _gyr_z :: !Double + } deriving (Show, Eq) + +------------------------------------------------------------------------------- +data MyoArm = Arm_Left | Arm_Right deriving (Show, Eq) + +------------------------------------------------------------------------------- +data MyoDirection = Toward_wrist | Toward_elbow deriving (Show, Eq) + +------------------------------------------------------------------------------- +data MyoFrame = Event MyoEvent + | Command MyoCommand + deriving (Show, Eq) + +instance FromJSON MyoFrame where + parseJSON (Array v) = case V.toList v of + [String "event", o@(Object _)] -> Event <$> parseJSON o + [String "command", o@(Object _)] -> Command <$> parseJSON o + _ -> mzero + parseJSON v = typeMismatch "MyoFrame: Expecting an Array of frames." v + +------------------------------------------------------------------------------- +data MyoEvent = MyoEvent { + _mye_type :: !MyoEventType + , _mye_timestamp :: !T.Text + , _mye_myo :: !MyoID + , _mye_arm :: !(Maybe MyoArm) + , _mye_x_direction :: !(Maybe MyoDirection) + , _mye_version :: !(Maybe MyoVersion) + , _mye_warmup_result :: !(Maybe MyoResult) + , _mye_rssi :: !(Maybe Int) + , _mye_pose :: !(Maybe MyoPose) + , _mye_emg :: !(Maybe EMG) + , _mye_orientation :: !(Maybe Orientation) + , _mye_accelerometer :: !(Maybe Accelerometer) + , _mye_gyroscope :: !(Maybe Gyroscope) + } deriving (Show, Eq) + + +data MyoResult = Success | Fail deriving (Show, Eq) + +data MyoCommandType = + COM_vibrate + | COM_request_rssi + | COM_set_stream_emg + | COM_set_locking_policy + | COM_unlock + | COM_lock + | COM_notify_user_action + deriving (Show, Eq) + +------------------------------------------------------------------------------- +data MyoCommand = MyoCommand { + _myc_command :: !MyoCommandType + , _myc_timestamp :: !T.Text + , _myc_myo :: !MyoID + , _myc_type :: !T.Text -- Use an ADT + } deriving (Show, Eq) + +------------------------------------------------------------------------------- +instance FromJSON MyoVersion where + parseJSON (Array v) = do + let lst = V.toList v + case liftM2 (,) (Just $ length lst) (mapM toNumber lst) of + Just (4, x) -> case mapM floatingOrInteger x of + Right [ma, mi, pa, ha] -> return $ MyoVersion ma mi pa ha + _ -> mzero + _ -> mzero + parseJSON v = typeMismatch "MyoVersion: Expecting an Array like [major, minor, patch, hardware]" v + + +toNumber :: Value -> Maybe Scientific +toNumber (Number v) = Just v +toNumber _ = Nothing + +-- TODO: Create an Int8 in a better way than this one! +instance FromJSON EMG where + parseJSON (Array v) = do + let lst = V.toList v + case liftM2 (,) (Just $ length lst) (mapM toNumber lst) of + Just (8, x) -> case mapM floatingOrInteger x of + Right res -> return . EMG . read $ concatMap show res + _ -> mzero + _ -> mzero + parseJSON v = typeMismatch "EMG: Expecting an Array of size 8." v + +instance FromJSON Gyroscope where + parseJSON (Array v) = case V.toList v of + [Number x, Number y, Number z] -> return $ Gyroscope (toRealFloat x) (toRealFloat y) (toRealFloat z) + _ -> mzero + parseJSON v = typeMismatch "Gyroscope: Expecting an Array of Double like [x,y,z]" v + +instance FromJSON Accelerometer where + parseJSON (Array v) = case V.toList v of + [Number x, Number y, Number z] -> return $ Accelerometer (toRealFloat x) (toRealFloat y) (toRealFloat z) + _ -> mzero + parseJSON v = typeMismatch "Accelerometer: Expecting an Array of Double like [x,y,z]" v + +------------------------------------------------------------------------------- +-- JSON +deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''MyoEvent +deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''MyoCommand +deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoCommandType +deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoResult +deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''Orientation +deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoEventType +deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''MyoPose +deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''MyoDirection +deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''MyoArm + +------------------------------------------------------------------------------- +-- Lenses +makeLenses ''MyoEvent +makeLenses ''MyoCommand +makeLenses ''MyoVersion diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +module Main where + +import Test.Tasty +import Test.Tasty.HUnit + +import Myo +import Myo.Foreign.Types + +import Control.Monad +import Foreign.C.String +import Foreign.Ptr +import Foreign.Storable +import Foreign.ForeignPtr +import Data.Either +import Foreign.Marshal.Alloc + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Myo Tests" [unitTests] + +unitTests = testGroup "Unit tests" + [ testCase "stringToMacAddress" testStringToMacAddress + , testCase "MAC roundtrip" testMACRoundtrip + , testGroup "Hub tests" [ + testCase "initHub succeeds" testInitHub + , testCase "initHub correctly fails for wrong app id" testInitHubWrongAppId + , testCase "newHub succeeds" testNewHub + ] + , testGroup "Myo-specific tests" [ + testCase "run succeeds" testRunMyo + ] + ] + +testStringToMacAddress :: Assertion +testStringToMacAddress = do + input <- newCString "0A-00-00-00-00-00" + let res = stringToMacAddress input + assertBool (show res) (res `compare` 10 == EQ) + +testMACRoundtrip :: Assertion +testMACRoundtrip = do + let mac = "0a-00-00-00-00-00" + input <- newCString mac + let res = stringToMacAddress input + mString <- macAddressToString res + ms <- fromMyoString mString + expected <- peekCString ms + assertBool (show expected) (expected `compare` mac == EQ) + +testHubFinalise :: Assertion +testHubFinalise = do + hub <- malloc >>= newForeignPtr freeHub + aId <- newCString "com.example.hello-world" + eDetails <- mallocForeignPtr + _ <- initHub hub aId eDetails + return () + +testInitHub :: Assertion +testInitHub = do + hub <- mallocForeignPtr + eDetails <- mallocForeignPtr + aId <- newCString "com.example.hello-world" + r <- initHub hub aId eDetails + assertBool (show r) (r == Success) + +testInitHubWrongAppId :: Assertion +testInitHubWrongAppId = do + hub <- mallocForeignPtr + eDetails <- mallocForeignPtr + aId <- newCString "eoueoue" + r <- initHub hub aId eDetails + assertBool (show r) (r == InvalidArgument) + +testNewHub :: Assertion +testNewHub = do + res <- newHub "com.example.hello-world" + assertBool (show res) (isRight res) + +testRunMyo :: Assertion +testRunMyo = return ()