{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}

{- |
Module      : Buttplug.Core.Device
Description : Types for representing sex toys
Copyright   : (c) James Sully, 2020-2021
License     : BSD 3-Clause
Maintainer  : sullyj3@gmail.com
Stability   : experimental
Portability : untested

Types for representing sex toys, as well as ways of actuating them.
-}

module Buttplug.Core.Device where

import           GHC.Generics
import           Control.Monad       (foldM)
import           Data.Map.Strict     (Map)
import           Data.Maybe          (catMaybes)
import           Data.Text           (Text)
import           Data.Aeson.Types    ( Parser )
import           Data.Aeson          ( ToJSON(..)
                                     , FromJSON(..)
                                     , ToJSONKey(..)
                                     , FromJSONKey(..)
                                     , (.=)
                                     , (.:?)
                                     , Value(..)
                                     , object
                                     , genericToJSON
                                     , genericToJSONKey
                                     , genericFromJSONKey
                                     , genericParseJSON
                                     , withObject )
import qualified Data.HashMap.Strict as HMap

import Buttplug.Core.Internal.JSONUtils

-- | For a particular actuation feature (Vibration, Rotation, or Linear), 
-- represents how many of that feature the device has, and the available 
-- resolution of control of that feature. See
-- (<https://buttplug-spec.docs.buttplug.io/enumeration.html#message-attributes-for-devicelist-and-deviceadded>)
-- for details.
data MessageAttributes = MessageAttributes
       { MessageAttributes -> Maybe Word
attrFeatureCount :: Maybe Word
       , MessageAttributes -> Maybe [Word]
attrStepCount :: Maybe [Word] }
  deriving ((forall x. MessageAttributes -> Rep MessageAttributes x)
-> (forall x. Rep MessageAttributes x -> MessageAttributes)
-> Generic MessageAttributes
forall x. Rep MessageAttributes x -> MessageAttributes
forall x. MessageAttributes -> Rep MessageAttributes x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MessageAttributes x -> MessageAttributes
$cfrom :: forall x. MessageAttributes -> Rep MessageAttributes x
Generic, Int -> MessageAttributes -> ShowS
[MessageAttributes] -> ShowS
MessageAttributes -> String
(Int -> MessageAttributes -> ShowS)
-> (MessageAttributes -> String)
-> ([MessageAttributes] -> ShowS)
-> Show MessageAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageAttributes] -> ShowS
$cshowList :: [MessageAttributes] -> ShowS
show :: MessageAttributes -> String
$cshow :: MessageAttributes -> String
showsPrec :: Int -> MessageAttributes -> ShowS
$cshowsPrec :: Int -> MessageAttributes -> ShowS
Show, MessageAttributes -> MessageAttributes -> Bool
(MessageAttributes -> MessageAttributes -> Bool)
-> (MessageAttributes -> MessageAttributes -> Bool)
-> Eq MessageAttributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageAttributes -> MessageAttributes -> Bool
$c/= :: MessageAttributes -> MessageAttributes -> Bool
== :: MessageAttributes -> MessageAttributes -> Bool
$c== :: MessageAttributes -> MessageAttributes -> Bool
Eq)


instance ToJSON MessageAttributes where
  toJSON :: MessageAttributes -> Value
toJSON = Options -> MessageAttributes -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
msgAttributeOptions

instance FromJSON MessageAttributes where
  parseJSON :: Value -> Parser MessageAttributes
parseJSON = String
-> (Object -> Parser MessageAttributes)
-> Value
-> Parser MessageAttributes
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"MessageAttributes" \Object
v -> Maybe Word -> Maybe [Word] -> MessageAttributes
MessageAttributes
    (Maybe Word -> Maybe [Word] -> MessageAttributes)
-> Parser (Maybe Word)
-> Parser (Maybe [Word] -> MessageAttributes)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser (Maybe Word)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"FeatureCount"
    Parser (Maybe [Word] -> MessageAttributes)
-> Parser (Maybe [Word]) -> Parser MessageAttributes
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe [Word])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"StepCount"

-- | An intimate device, containing info about the functionality it supports.
data Device =
       Device { Device -> Text
deviceName :: Text
              , Device -> Word
deviceIndex :: Word
              , Device -> Map DeviceMessageType MessageAttributes
deviceMessages :: Map DeviceMessageType MessageAttributes
              }
  deriving ((forall x. Device -> Rep Device x)
-> (forall x. Rep Device x -> Device) -> Generic Device
forall x. Rep Device x -> Device
forall x. Device -> Rep Device x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Device x -> Device
$cfrom :: forall x. Device -> Rep Device x
Generic, Int -> Device -> ShowS
[Device] -> ShowS
Device -> String
(Int -> Device -> ShowS)
-> (Device -> String) -> ([Device] -> ShowS) -> Show Device
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Device] -> ShowS
$cshowList :: [Device] -> ShowS
show :: Device -> String
$cshow :: Device -> String
showsPrec :: Int -> Device -> ShowS
$cshowsPrec :: Int -> Device -> ShowS
Show, Device -> Device -> Bool
(Device -> Device -> Bool)
-> (Device -> Device -> Bool) -> Eq Device
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Device -> Device -> Bool
$c/= :: Device -> Device -> Bool
== :: Device -> Device -> Bool
$c== :: Device -> Device -> Bool
Eq)

instance ToJSON Device where
  toJSON :: Device -> Value
toJSON = Options -> Device -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
pascalCaseOptions

instance FromJSON Device where
  parseJSON :: Value -> Parser Device
parseJSON = Options -> Value -> Parser Device
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
pascalCaseOptions
---------------------------------------------------------------

-- | Represents which message types the device supports
-- See
-- (<https://buttplug-spec.docs.buttplug.io/enumeration.html#message-attributes-for-devicelist-and-deviceadded>)
-- for details.
data DeviceMessageType =
  -- Raw Device commands
    DevRawWriteCmd
  | DevRawReadCmd
  | DevRawSubscribeCmd
  | DevRawUnsubscribeCmd
  -- Generic Device commands
  | DevStopDeviceCmd
  | DevVibrateCmd
  | DevLinearCmd
  | DevRotateCmd
  deriving ((forall x. DeviceMessageType -> Rep DeviceMessageType x)
-> (forall x. Rep DeviceMessageType x -> DeviceMessageType)
-> Generic DeviceMessageType
forall x. Rep DeviceMessageType x -> DeviceMessageType
forall x. DeviceMessageType -> Rep DeviceMessageType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DeviceMessageType x -> DeviceMessageType
$cfrom :: forall x. DeviceMessageType -> Rep DeviceMessageType x
Generic, Int -> DeviceMessageType -> ShowS
[DeviceMessageType] -> ShowS
DeviceMessageType -> String
(Int -> DeviceMessageType -> ShowS)
-> (DeviceMessageType -> String)
-> ([DeviceMessageType] -> ShowS)
-> Show DeviceMessageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeviceMessageType] -> ShowS
$cshowList :: [DeviceMessageType] -> ShowS
show :: DeviceMessageType -> String
$cshow :: DeviceMessageType -> String
showsPrec :: Int -> DeviceMessageType -> ShowS
$cshowsPrec :: Int -> DeviceMessageType -> ShowS
Show, DeviceMessageType -> DeviceMessageType -> Bool
(DeviceMessageType -> DeviceMessageType -> Bool)
-> (DeviceMessageType -> DeviceMessageType -> Bool)
-> Eq DeviceMessageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeviceMessageType -> DeviceMessageType -> Bool
$c/= :: DeviceMessageType -> DeviceMessageType -> Bool
== :: DeviceMessageType -> DeviceMessageType -> Bool
$c== :: DeviceMessageType -> DeviceMessageType -> Bool
Eq, Eq DeviceMessageType
Eq DeviceMessageType
-> (DeviceMessageType -> DeviceMessageType -> Ordering)
-> (DeviceMessageType -> DeviceMessageType -> Bool)
-> (DeviceMessageType -> DeviceMessageType -> Bool)
-> (DeviceMessageType -> DeviceMessageType -> Bool)
-> (DeviceMessageType -> DeviceMessageType -> Bool)
-> (DeviceMessageType -> DeviceMessageType -> DeviceMessageType)
-> (DeviceMessageType -> DeviceMessageType -> DeviceMessageType)
-> Ord DeviceMessageType
DeviceMessageType -> DeviceMessageType -> Bool
DeviceMessageType -> DeviceMessageType -> Ordering
DeviceMessageType -> DeviceMessageType -> DeviceMessageType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DeviceMessageType -> DeviceMessageType -> DeviceMessageType
$cmin :: DeviceMessageType -> DeviceMessageType -> DeviceMessageType
max :: DeviceMessageType -> DeviceMessageType -> DeviceMessageType
$cmax :: DeviceMessageType -> DeviceMessageType -> DeviceMessageType
>= :: DeviceMessageType -> DeviceMessageType -> Bool
$c>= :: DeviceMessageType -> DeviceMessageType -> Bool
> :: DeviceMessageType -> DeviceMessageType -> Bool
$c> :: DeviceMessageType -> DeviceMessageType -> Bool
<= :: DeviceMessageType -> DeviceMessageType -> Bool
$c<= :: DeviceMessageType -> DeviceMessageType -> Bool
< :: DeviceMessageType -> DeviceMessageType -> Bool
$c< :: DeviceMessageType -> DeviceMessageType -> Bool
compare :: DeviceMessageType -> DeviceMessageType -> Ordering
$ccompare :: DeviceMessageType -> DeviceMessageType -> Ordering
$cp1Ord :: Eq DeviceMessageType
Ord)

instance ToJSON DeviceMessageType where
  toJSON :: DeviceMessageType -> Value
toJSON = Options -> DeviceMessageType -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
deviceMessageOptions

instance FromJSON DeviceMessageType where
  parseJSON :: Value -> Parser DeviceMessageType
parseJSON = Options -> Value -> Parser DeviceMessageType
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
deviceMessageOptions

instance ToJSONKey DeviceMessageType where
  toJSONKey :: ToJSONKeyFunction DeviceMessageType
toJSONKey = JSONKeyOptions -> ToJSONKeyFunction DeviceMessageType
forall a.
(Generic a, GToJSONKey (Rep a)) =>
JSONKeyOptions -> ToJSONKeyFunction a
genericToJSONKey (String -> JSONKeyOptions
stripPrefixKeyOptions String
"Dev")

instance FromJSONKey DeviceMessageType where
  fromJSONKey :: FromJSONKeyFunction DeviceMessageType
fromJSONKey = JSONKeyOptions -> FromJSONKeyFunction DeviceMessageType
forall a.
(Generic a, GFromJSONKey (Rep a)) =>
JSONKeyOptions -> FromJSONKeyFunction a
genericFromJSONKey (String -> JSONKeyOptions
stripPrefixKeyOptions String
"Dev")