myo 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+300/−124 lines, 4 filesdep +string-convdep +unordered-containers
Dependencies added: string-conv, unordered-containers
Files
- examples/WS.hs +29/−16
- myo.cabal +60/−43
- src/Myo/WebSockets.hs +17/−11
- src/Myo/WebSockets/Types.hs +194/−54
examples/WS.hs view
@@ -1,29 +1,42 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} module Main where -import qualified Data.Aeson as JSON-import Network.WebSockets import Myo.WebSockets+import Network.WebSockets+import qualified Data.Aeson as JSON import Control.Monad+import Data.String.Conv import Lens.Family2 main :: IO ()-main = runClient "localhost" 10138 "/myo/3?appid=com.example.appid" myoWS+main = connect V3 "com.example.appid" "localhost" 10138 myoApp -myoWS :: Connection -> IO ()-myoWS conn = forever $ do+myoApp :: Connection -> IO ()+myoApp conn = forever $ do newData <- receiveData conn- let (msg :: Either String MyoFrame) = JSON.eitherDecode' newData+ let msg = 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 ()+ print newData+ Right r -> case r of+ Evt 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 Double_Tap -> do+ putStrLn $ "GOT POSE: " ++ show Double_Tap+ let vCmd = newCommand (my ^. mye_myo) (Set_Locking_Policy LKP_standard)+ putStrLn $ toS $ JSON.encode vCmd+ sendCommand conn vCmd+ Just p -> putStrLn $ "GOT POSE: " ++ show p+ EVT_Arm_Synced -> do+ putStrLn "MYO ARM SYNCED"+ EVT_Arm_Unsynced -> putStrLn "MYO ARM UNSYNCED"+ _ -> return ()+ Cmd c -> print c+ Ack a -> do+ putStrLn "Acknowledged command!"+ print a
myo.cabal view
@@ -1,5 +1,5 @@ name: myo-version: 0.1.0.0+version: 0.2.0.0 synopsis: Haskell binding to the Myo armband description: Please see README.md homepage: http://github.com/adinapoli/myo@@ -14,54 +14,70 @@ cabal-version: >=1.10 +flag foreign-api+ default: False+ library- hs-source-dirs: src- include-dirs:- include+ hs-source-dirs: src+ include-dirs: include+ if flag(foreign-api)+ exposed-modules:+ Myo+ 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,+ unordered-containers,+ inline-c+ extra-libraries:+ stdc+++ ld-options:+ -framework myo+ 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+ 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+ Myo.WebSockets+ Myo.WebSockets.Types 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+ base >= 4.7 && < 5,+ containers,+ websockets,+ aeson,+ lens-family,+ lens-family-th,+ vector,+ text,+ scientific,+ unordered-containers+ 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 @@ -71,8 +87,9 @@ build-depends: base , myo , websockets+ , string-conv , aeson- ,lens-family+ , lens-family default-language: Haskell2010 test-suite myo-test
src/Myo/WebSockets.hs view
@@ -3,21 +3,23 @@ module Myo.WebSockets.Types , ApplicationID , APIVersion(..)- , renderAPIVersion+ , connect+ , sendCommand ) where ---import Network.WebSockets+import Network.WebSockets+import Data.Monoid+import qualified Data.Aeson as JSON+import qualified Data.Vector as V import Myo.WebSockets.Types-import qualified Data.Text as T data APIVersion = V3 -type ApplicationID = T.Text+instance Show APIVersion where+ show V3 = "3" -renderAPIVersion :: APIVersion -> T.Text-renderAPIVersion V3 = "3"+type ApplicationID = String -{- connect :: APIVersion -> ApplicationID -- ^ The Myo ApplicationID@@ -25,8 +27,12 @@ -- ^ Host -> Int -- ^ Port+ -> ClientApp a -> 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--}+connect apiVr aId host port app = do+ runClient host port ("/myo/" <> show apiVr <> "?appid=" <> aId) app++--------------------------------------------------------------------------------+sendCommand :: Connection -> Command -> IO ()+sendCommand conn cmd = do+ sendBinaryData conn (JSON.encode $ JSON.Array (V.fromList ["command", JSON.toJSON cmd]))
src/Myo/WebSockets/Types.hs view
@@ -1,23 +1,74 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}-module Myo.WebSockets.Types where+module Myo.WebSockets.Types (+ EventType(..)+ , MyoID+ , Version(..)+ , EMG(..)+ , Pose(..)+ , Orientation(..)+ , Accelerometer(..)+ , Gyroscope(..)+ , Arm(..)+ , Direction(..)+ , Frame(..)+ , Event(..)+ , Command+ , CommandData(..)+ , Vibration(..)+ , StreamEMGStatus(..)+ , UnlockMode(..)+ , UserAction(..)+ , LockingPolicy(..) + -- * Lenses+ , mye_type+ , mye_timestamp+ , mye_myo+ , mye_arm+ , mye_x_direction+ , mye_version+ , mye_warmup_result+ , mye_rssi+ , mye_pose+ , mye_emg+ , mye_orientation+ , mye_accelerometer+ , mye_gyroscope+ , myv_major+ , myv_minor+ , myv_patch+ , myv_hardware++ -- * Smart constructors+ , newCommand+ ) where+ import Data.Aeson.TH import Data.Int+import Data.Monoid import Data.Scientific-import Data.Aeson.Types+import Data.Aeson.Types hiding (Result) 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+import qualified Data.HashMap.Strict as HM --------------------------------------------------------------------------------data MyoEventType =+data EventType = EVT_Paired | EVT_Battery_Level | EVT_Locked@@ -34,10 +85,10 @@ deriving (Show, Eq) --------------------------------------------------------------------------------type MyoID = Integer+newtype MyoID = MyoID Integer deriving (Show, Eq) --------------------------------------------------------------------------------data MyoVersion = MyoVersion {+data Version = Version { _myv_major :: !Integer , _myv_minor :: !Integer , _myv_patch :: !Integer@@ -49,7 +100,7 @@ data EMG = EMG Int8 deriving (Show, Eq) --------------------------------------------------------------------------------data MyoPose =+data Pose = Rest | Fist | Wave_In@@ -79,77 +130,155 @@ } deriving (Show, Eq) --------------------------------------------------------------------------------data MyoArm = Arm_Left | Arm_Right deriving (Show, Eq)+data Arm = Arm_Left | Arm_Right deriving (Show, Eq) --------------------------------------------------------------------------------data MyoDirection = Toward_wrist | Toward_elbow deriving (Show, Eq)+data Direction = Toward_wrist | Toward_elbow deriving (Show, Eq) --------------------------------------------------------------------------------data MyoFrame = Event MyoEvent- | Command MyoCommand- deriving (Show, Eq)+data Frame = Evt Event+ | Cmd Command+ | Ack Acknowledgement+ 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+instance FromJSON Frame where+ parseJSON a@(Array v) = case V.toList v of+ [String "event", o@(Object _)] -> Evt <$> parseJSON o+ [String "acknowledgement", o@(Object _)] -> Ack <$> parseJSON o+ [String "command", o@(Object b)] -> case HM.lookup "result" b of+ Nothing -> Cmd <$> parseJSON o+ Just _ -> Ack <$> parseJSON o+ _ -> typeMismatch "Frame: Unexpected payload in Array." a+ parseJSON v = typeMismatch "Frame: Expecting an Array of frames." v + --------------------------------------------------------------------------------data MyoEvent = MyoEvent {- _mye_type :: !MyoEventType+-- TODO: Break down this `Event` type into a mandatory section (type, timestamp, myo)+-- and a payload specific field, so that we do not have all this proliferation of+-- Maybe. The `FromJSON` instance will need to be written manually, but it's not+-- too bad.+data Event = Event {+ _mye_type :: !EventType , _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_arm :: !(Maybe Arm)+ , _mye_x_direction :: !(Maybe Direction)+ , _mye_version :: !(Maybe Version)+ , _mye_warmup_result :: !(Maybe Result) , _mye_rssi :: !(Maybe Int)- , _mye_pose :: !(Maybe MyoPose)+ , _mye_pose :: !(Maybe Pose) , _mye_emg :: !(Maybe EMG) , _mye_orientation :: !(Maybe Orientation) , _mye_accelerometer :: !(Maybe Accelerometer) , _mye_gyroscope :: !(Maybe Gyroscope) } deriving (Show, Eq) +data Acknowledgement = Acknowledgement {+ _ack_command :: AcknowledgedCommand+ , _ack_result :: Result+ } deriving (Show, Eq) -data MyoResult = Success | Fail deriving (Show, Eq)+data AcknowledgedCommand =+ ACC_set_locking_policy+ | ACC_set_stream_emg+ 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+-------------------------------------------------------------------------------+data Result = Success | Fail deriving (Show, Eq)++-------------------------------------------------------------------------------+data CommandData =+ Vibrate Vibration+ | Set_Stream_EMG StreamEMGStatus+ | Unlock UnlockMode+ | Notify_User_Action UserAction+ | Set_Locking_Policy LockingPolicy+ | Request_RSSI+ | Lock deriving (Show, Eq) +instance ToJSON CommandData where+ toJSON cd = case cd of+ Vibrate v -> object ["command" .= String "vibrate", "type" .= toJSON v]+ Set_Stream_EMG v -> object ["command" .= String "set_stream_emg", "type" .= toJSON v]+ Unlock v -> object ["command" .= String "unlock", "type" .= toJSON v]+ Notify_User_Action v -> object ["command" .= String "notify_user_action", "type" .= toJSON v]+ Set_Locking_Policy v -> object ["command" .= String "set_locking_policy", "type" .= toJSON v]+ Lock -> object ["command" .= String "lock"]+ Request_RSSI -> object ["command" .= String "request_rssi"]++instance FromJSON CommandData where+ parseJSON (Object o) = do+ (cmd :: T.Text) <- o .: "command"+ typ <- o .: "type"+ case cmd of+ "vibrate" -> Vibrate <$> parseJSON typ+ "request_rssi" -> pure Request_RSSI+ "set_stream_emg" -> Set_Stream_EMG <$> parseJSON typ+ "set_locking_policy" -> Set_Locking_Policy <$> parseJSON typ+ "unlock" -> Unlock <$> parseJSON typ+ "lock" -> pure Lock+ "notify_user_action" -> Notify_User_Action <$> parseJSON typ+ t -> fail $ "FromJSON CommandData: invalid 'command' found: " <> show t+ parseJSON t = typeMismatch ("CommandData, expected Object, found " <> show t) t+ --------------------------------------------------------------------------------data MyoCommand = MyoCommand {- _myc_command :: !MyoCommandType- , _myc_timestamp :: !T.Text- , _myc_myo :: !MyoID- , _myc_type :: !T.Text -- Use an ADT+data Vibration = VIB_short+ | VIB_medium+ | VIB_long deriving (Show, Eq)++-------------------------------------------------------------------------------+data UserAction = UAC_single deriving (Show, Eq)++-------------------------------------------------------------------------------+data LockingPolicy = LKP_standard+ | LKP_none deriving (Show, Eq)++-------------------------------------------------------------------------------+data UnlockMode = UMD_timed+ | UMD_hold deriving (Show, Eq)++-------------------------------------------------------------------------------+data StreamEMGStatus = SES_enabled+ | SES_disabled deriving (Show, Eq)++-------------------------------------------------------------------------------+data Command = Command {+ _myc_myo :: !MyoID+ , _myc_info :: CommandData } deriving (Show, Eq) +instance FromJSON Command where+ parseJSON v@(Object o) = Command <$> o .: "myo" <*> parseJSON v+ parseJSON v = fail $ "FromJSON Command, expected Object, found " <> show v++instance ToJSON Command where+ toJSON (Command mid cd) = case toJSON cd of+ Object b -> object $ ["myo" .= mid] <> HM.toList b+ v -> error $ "Command: toJSON of CommandData failed, found " <> show v++--------------------------------------------------------------------------------+-- | Creates a new `Command`, to be sent to the Myo armband.+newCommand :: MyoID -> CommandData -> Command+newCommand mid cd = Command mid cd+ --------------------------------------------------------------------------------instance FromJSON MyoVersion where+instance FromJSON Version 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+ Right [ma, mi, pa, ha] -> return $ Version ma mi pa ha _ -> mzero _ -> mzero- parseJSON v = typeMismatch "MyoVersion: Expecting an Array like [major, minor, patch, hardware]" v-+ parseJSON v = typeMismatch "Version: 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@@ -174,19 +303,30 @@ 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+--+-- JSON instances+--++deriveJSON defaultOptions ''MyoID+deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''Event+deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''Result+deriveJSON defaultOptions { constructorTagModifier = drop 4 . map toLower } ''Vibration+deriveJSON defaultOptions { constructorTagModifier = drop 4 . map toLower } ''StreamEMGStatus+deriveJSON defaultOptions { constructorTagModifier = drop 4 . map toLower } ''LockingPolicy+deriveJSON defaultOptions { constructorTagModifier = map toLower } ''UserAction+deriveJSON defaultOptions { constructorTagModifier = map toLower } ''UnlockMode 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+deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''EventType+deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''Pose+deriveFromJSON defaultOptions { constructorTagModifier = map toLower } ''Direction+deriveFromJSON defaultOptions { constructorTagModifier = map toLower . drop 4 } ''Arm+deriveFromJSON defaultOptions { fieldLabelModifier = drop 5 } ''Acknowledgement+deriveFromJSON defaultOptions { constructorTagModifier = drop 4 } ''AcknowledgedCommand -------------------------------------------------------------------------------+-- -- Lenses-makeLenses ''MyoEvent-makeLenses ''MyoCommand-makeLenses ''MyoVersion+--++makeLenses ''Event+makeLenses ''Version