Types.hs

{-# 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 (
    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 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 EventType =
    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)

-------------------------------------------------------------------------------
newtype MyoID = MyoID Integer deriving (Show, Eq)

-------------------------------------------------------------------------------
data Version = Version {
    _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 Pose =
     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 Arm = Arm_Left | Arm_Right deriving (Show, Eq)

-------------------------------------------------------------------------------
data Direction = Toward_wrist | Toward_elbow deriving (Show, Eq)

-------------------------------------------------------------------------------
data Frame = Evt Event
           | Cmd Command
           | Ack Acknowledgement
           deriving (Show, Eq)

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


-------------------------------------------------------------------------------
-- 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 Arm)
  , _mye_x_direction :: !(Maybe Direction)
  , _mye_version :: !(Maybe Version)
  , _mye_warmup_result :: !(Maybe Result)
  , _mye_rssi :: !(Maybe Int)
  , _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 AcknowledgedCommand =
    ACC_set_locking_policy
  | ACC_set_stream_emg
  deriving (Show, Eq)

-------------------------------------------------------------------------------
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 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 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 $ Version ma mi pa ha
      _ -> mzero
   _ -> mzero
 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
  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 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 } ''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 ''Event
makeLenses ''Version