{-# LANGUAGE DataKinds  #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds  #-}
module Device.Nintendo.Switch.Output where

-- base

import Control.Exception (Exception, throwIO)
import Control.Monad     (join, when)
import Data.Bits         ((.|.), (.&.), shiftL, shiftR)
import Data.IORef        (IORef, readIORef, writeIORef)
import Data.Word         (Word8, Word32)

-- bytestring

import qualified Data.ByteString as BS

-- hidapi

import System.HIDAPI (Device, write)

-- switch

import Device.Nintendo.Switch.Controller (Controller(..), ControllerType(..))
import Device.Nintendo.Switch.Utils      (clamp, combine, discretize, pairs)

-- | A constraint which indicates that a Nintendo Switch controller has a home

-- light (see 'setHomeLight').

class HasHomeLight t

instance HasHomeLight 'RightJoyCon
instance HasHomeLight 'ProController

-- | A constraint which indicates that a Nintendo Switch controller has a left-side

-- rumble unit (see 'setLeftRumble').

class HasLeftRumble t

instance HasLeftRumble 'LeftJoyCon
instance HasLeftRumble 'ProController

-- | A constraint which indicates that a Nintendo Switch controller has a right-side

-- rumble unit (see 'setRightRumble').

class HasRightRumble t

instance HasRightRumble 'RightJoyCon
instance HasRightRumble 'ProController

-- | A constraint which indicates that a Nintendo Switch controller has player lights

-- (i.e., the four LEDs which represent the player number; see 'setPlayerLights').

class HasPlayerLights t

instance HasPlayerLights 'LeftJoyCon
instance HasPlayerLights 'RightJoyCon
instance HasPlayerLights 'ProController

-- | A constraint which indicates that a Nintendo Switch controller supports multiple

-- input modes (see 'setInputMode').

class HasInputMode t

instance HasInputMode 'LeftJoyCon
instance HasInputMode 'RightJoyCon

-- | An 'OutputException' is thrown if something goes wrong when sending commands to

-- a Nintendo Switch controller.

data OutputException = WriteException

instance Exception OutputException
instance Show OutputException where
  show :: OutputException -> String
show OutputException
WriteException = String
"Could not send all data to the controller device."

-- | The base duration of a home light configuration in milliseconds. It will

-- always be limited to an interval between 8ms and 175ms. It is called base

-- duration because it will be multiplied with other factors in order to obtain

-- the overall durations of fadings within home light configurations.

type BaseDuration = Word8

-- | The LED intensity of the home light. It will always be limited to an interval

-- between 0 and 100.

type Intensity = Word8

-- | The fade duration factor of the home light. It will always be limited to an

-- interval between 0 and 15 and is multiplied with the 'BaseDuration' to obtain

-- the overall fade duration in milliseconds.

type FadeFactor = Word8

-- | The light duration factor of the home light. It will always be limited to an

-- interval between 0 and 15 and is multiplied with the 'BaseDuration' to obtain

-- the overall light duration in milliseconds.

type LightFactor = Word8

-- | A home light cycle consists of a target LED intensity, a fade factor which

-- controls the time needed to reach that LED intensity, and a light factor which

-- controls how long to keep the target LED intensity up.

type CycleConfig = (Intensity, FadeFactor, LightFactor)

-- | Defines the repeat behaviour after all the home light configuration cycles

-- have ended.

data RepeatBehaviour
  = Forever
    -- ^ Repeat the configured home light configuration cycles forever.

  | Times Word8
    -- ^ Repeat the configured home light configuration cycles a specific amount

    -- of times. It will always be limited to an interval between 1 and 15.

  deriving (RepeatBehaviour -> RepeatBehaviour -> Bool
(RepeatBehaviour -> RepeatBehaviour -> Bool)
-> (RepeatBehaviour -> RepeatBehaviour -> Bool)
-> Eq RepeatBehaviour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RepeatBehaviour -> RepeatBehaviour -> Bool
$c/= :: RepeatBehaviour -> RepeatBehaviour -> Bool
== :: RepeatBehaviour -> RepeatBehaviour -> Bool
$c== :: RepeatBehaviour -> RepeatBehaviour -> Bool
Eq, ReadPrec [RepeatBehaviour]
ReadPrec RepeatBehaviour
Int -> ReadS RepeatBehaviour
ReadS [RepeatBehaviour]
(Int -> ReadS RepeatBehaviour)
-> ReadS [RepeatBehaviour]
-> ReadPrec RepeatBehaviour
-> ReadPrec [RepeatBehaviour]
-> Read RepeatBehaviour
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RepeatBehaviour]
$creadListPrec :: ReadPrec [RepeatBehaviour]
readPrec :: ReadPrec RepeatBehaviour
$creadPrec :: ReadPrec RepeatBehaviour
readList :: ReadS [RepeatBehaviour]
$creadList :: ReadS [RepeatBehaviour]
readsPrec :: Int -> ReadS RepeatBehaviour
$creadsPrec :: Int -> ReadS RepeatBehaviour
Read, Int -> RepeatBehaviour -> ShowS
[RepeatBehaviour] -> ShowS
RepeatBehaviour -> String
(Int -> RepeatBehaviour -> ShowS)
-> (RepeatBehaviour -> String)
-> ([RepeatBehaviour] -> ShowS)
-> Show RepeatBehaviour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RepeatBehaviour] -> ShowS
$cshowList :: [RepeatBehaviour] -> ShowS
show :: RepeatBehaviour -> String
$cshow :: RepeatBehaviour -> String
showsPrec :: Int -> RepeatBehaviour -> ShowS
$cshowsPrec :: Int -> RepeatBehaviour -> ShowS
Show)

-- | The home light of a Nintendo Switch Controller can be controlled using repeatable

-- configuration cycles. See 'endlessPulse' for an example configuration.

data HomeLightConfig
  = Off
    -- ^ Turn off the home light.

  | Once BaseDuration Intensity CycleConfig
    -- ^ Given a start intensity of the home light LED, fade to a target LED

    -- intensity in a given time, and then keep this LED intensity up for a given

    -- amount of time.

    --

    -- The fade duration in milliseconds is calculated by multiplying the 'BaseDuration'

    -- with the 'FadeFactor' of the 'CycleConfig'. The light upkeep duration in

    -- milliseconds is calculated by multiplying the 'BaseDuration' with the 'LightFactor'

    -- of the 'CycleConfig'.

    --

    -- Example - fade from a switched off LED (@0@) to a fully bright LED (@100@) in 500ms

    -- (@50@ms * @10@), stay there for one second (@50@ms * @20@), then turn it off:

    --

    -- @

    --     'Once' 50 0 (100, 10, 20)

    -- @

  | Cyclic BaseDuration Intensity [CycleConfig] RepeatBehaviour
    -- ^ Given a start intensity of the home light LED, repeatedly fade to a

    -- target LED intensity in a given time, and then keep this LED intensity up

    -- for a given amount of time. The fade durations and light upkeep durations

    -- are calculated per cycle configuration as described for 'Once'. See

    -- 'endlessPulse' for a cyclic configuration example.

  deriving (HomeLightConfig -> HomeLightConfig -> Bool
(HomeLightConfig -> HomeLightConfig -> Bool)
-> (HomeLightConfig -> HomeLightConfig -> Bool)
-> Eq HomeLightConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HomeLightConfig -> HomeLightConfig -> Bool
$c/= :: HomeLightConfig -> HomeLightConfig -> Bool
== :: HomeLightConfig -> HomeLightConfig -> Bool
$c== :: HomeLightConfig -> HomeLightConfig -> Bool
Eq, ReadPrec [HomeLightConfig]
ReadPrec HomeLightConfig
Int -> ReadS HomeLightConfig
ReadS [HomeLightConfig]
(Int -> ReadS HomeLightConfig)
-> ReadS [HomeLightConfig]
-> ReadPrec HomeLightConfig
-> ReadPrec [HomeLightConfig]
-> Read HomeLightConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HomeLightConfig]
$creadListPrec :: ReadPrec [HomeLightConfig]
readPrec :: ReadPrec HomeLightConfig
$creadPrec :: ReadPrec HomeLightConfig
readList :: ReadS [HomeLightConfig]
$creadList :: ReadS [HomeLightConfig]
readsPrec :: Int -> ReadS HomeLightConfig
$creadsPrec :: Int -> ReadS HomeLightConfig
Read, Int -> HomeLightConfig -> ShowS
[HomeLightConfig] -> ShowS
HomeLightConfig -> String
(Int -> HomeLightConfig -> ShowS)
-> (HomeLightConfig -> String)
-> ([HomeLightConfig] -> ShowS)
-> Show HomeLightConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HomeLightConfig] -> ShowS
$cshowList :: [HomeLightConfig] -> ShowS
show :: HomeLightConfig -> String
$cshow :: HomeLightConfig -> String
showsPrec :: Int -> HomeLightConfig -> ShowS
$cshowsPrec :: Int -> HomeLightConfig -> ShowS
Show)

lightConfigCommand :: HomeLightConfig -> [Word8]
lightConfigCommand :: HomeLightConfig -> [Word8]
lightConfigCommand = \case
  HomeLightConfig
Off ->
    Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
25 Word8
0x00
  Once Word8
dur Word8
int (Word8
cycInt, Word8
fade, Word8
cycDur) ->
    let
      byte0 :: Word8
byte0  = Word8 -> Word8
scaleDuration Word8
dur
      byte1 :: Word8
byte1  = Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Word8
scaleIntensity Word8
int) Int
4
      byte2 :: Word8
byte2  = Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Word8
scaleIntensity Word8
cycInt) Int
4
      byte3H :: Word8
byte3H = Word8 -> Word8
clampMultiplier Word8
fade
      byte3L :: Word8
byte3L = Word8 -> Word8
clampMultiplier Word8
cycDur
    in
      Word8
byte0 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
byte1 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
byte2 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8 -> Word8 -> Word8
combine Word8
byte3H Word8
byte3L Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
45 Word8
0x00
  Cyclic Word8
dur Word8
int [(Word8, Word8, Word8)]
cfgs RepeatBehaviour
rep ->
    let
      cycles :: [(Word8, Word8, Word8)]
cycles = Int -> [(Word8, Word8, Word8)] -> [(Word8, Word8, Word8)]
forall a. Int -> [a] -> [a]
take Int
15 [(Word8, Word8, Word8)]
cfgs
      byte0H :: Int
byte0H = [(Word8, Word8, Word8)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Word8, Word8, Word8)]
cycles
      byte0L :: Word8
byte0L = Word8 -> Word8
scaleDuration Word8
dur
      byte1H :: Word8
byte1H = Word8 -> Word8
scaleIntensity Word8
int
      byte1L :: Word8
byte1L = case RepeatBehaviour
rep of
        RepeatBehaviour
Forever -> Word8
0x0
        Times Word8
n -> Word8 -> Word8 -> Word8 -> Word8
forall a. Ord a => a -> a -> a -> a
clamp Word8
1 Word8
15 Word8
n
      padded :: [(Word8, Word8, Word8)]
padded = [(Word8, Word8, Word8)]
cycles [(Word8, Word8, Word8)]
-> [(Word8, Word8, Word8)] -> [(Word8, Word8, Word8)]
forall a. [a] -> [a] -> [a]
++ Int -> (Word8, Word8, Word8) -> [(Word8, Word8, Word8)]
forall a. Int -> a -> [a]
replicate (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
byte0H) (Word8
0,Word8
0,Word8
0)
      pairBytes :: [[Word8]]
pairBytes = (((Word8, Word8, Word8), (Word8, Word8, Word8)) -> [Word8])
-> [((Word8, Word8, Word8), (Word8, Word8, Word8))] -> [[Word8]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Word8, Word8, Word8) -> (Word8, Word8, Word8) -> [Word8])
-> ((Word8, Word8, Word8), (Word8, Word8, Word8)) -> [Word8]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Word8, Word8, Word8) -> (Word8, Word8, Word8) -> [Word8]
pairCommand) ([((Word8, Word8, Word8), (Word8, Word8, Word8))] -> [[Word8]])
-> [((Word8, Word8, Word8), (Word8, Word8, Word8))] -> [[Word8]]
forall a b. (a -> b) -> a -> b
$ [(Word8, Word8, Word8)]
-> [((Word8, Word8, Word8), (Word8, Word8, Word8))]
forall a. [a] -> [(a, a)]
pairs [(Word8, Word8, Word8)]
padded
    in
      Word8 -> Word8 -> Word8
combine (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
byte0H) Word8
byte0L
        Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8 -> Word8 -> Word8
combine Word8
byte1H Word8
byte1L
        Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [[Word8]] -> [Word8]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Word8]]
pairBytes
       [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
23 Word8
0x00
  where
    scaleIntensity :: Word8 -> Word8
scaleIntensity   = Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8
forall a b. (Real a, Integral b) => a -> a -> b -> b -> a -> b
discretize Word8
0 Word8
100 Word8
0 Word8
15
    scaleDuration :: Word8 -> Word8
scaleDuration    = Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8
forall a b. (Real a, Integral b) => a -> a -> b -> b -> a -> b
discretize Word8
8 Word8
175 Word8
0 Word8
15
    clampMultiplier :: Word8 -> Word8
clampMultiplier  = Word8 -> Word8 -> Word8 -> Word8
forall a. Ord a => a -> a -> a -> a
clamp Word8
0 Word8
15
    
    pairCommand :: CycleConfig -> CycleConfig -> [Word8]
    pairCommand :: (Word8, Word8, Word8) -> (Word8, Word8, Word8) -> [Word8]
pairCommand (Word8
int1, Word8
fade1, Word8
dur1) (Word8
int2, Word8
fade2, Word8
dur2) =
      let
        byte0H :: Word8
byte0H = Word8 -> Word8
scaleIntensity Word8
int1
        byte0L :: Word8
byte0L = Word8 -> Word8
scaleIntensity Word8
int2
        byte1H :: Word8
byte1H = Word8 -> Word8
clampMultiplier Word8
fade1
        byte1L :: Word8
byte1L = Word8 -> Word8
clampMultiplier Word8
dur1
        byte2H :: Word8
byte2H = Word8 -> Word8
clampMultiplier Word8
fade2
        byte2L :: Word8
byte2L = Word8 -> Word8
clampMultiplier Word8
dur2
      in
        [Word8 -> Word8 -> Word8
combine Word8
byte0H Word8
byte0L, Word8 -> Word8 -> Word8
combine Word8
byte1H Word8
byte1L, Word8 -> Word8 -> Word8
combine Word8
byte2H Word8
byte2L]

-- | A convenient home light configuration which pulsates the home light LED:

--

-- @

--     'Cyclic'

--       ( 100 )         -- Base duration factor is 100ms.

--       (   0 )         -- LED is turned off at the beginning (intensity 0).

--       [ (100, 5, 1)   -- Fade to LED intensity 100 in 500ms (100ms * 5) and stay there for 100ms (100ms * 1).

--       , (  0, 5, 1) ] -- Fade to LED intensity   0 in 500ms (100ms * 5) and stay there for 100ms (100ms * 1).

--       ( Forever )     -- Repeat these two cycles forever, thus generating a pulse-like LED.

-- @

endlessPulse :: HomeLightConfig
endlessPulse :: HomeLightConfig
endlessPulse =
  Word8
-> Word8
-> [(Word8, Word8, Word8)]
-> RepeatBehaviour
-> HomeLightConfig
Cyclic
    ( Word8
100 )
    ( Word8
0   )
    [ (Word8
100, Word8
5, Word8
1), (Word8
0, Word8
5, Word8
1) ]
    ( RepeatBehaviour
Forever )

-- | Sets the home light (i.e., the LED ring around the home button) of a Nintendo

-- Switch controller.

--

-- Note: After sending a command like this to a controller, it is highly advised

-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'

-- ('Device.Nintendo.Switch.SetHomeLight', to be exact) or at least call

-- 'Device.Nintendo.Switch.getInput' once before sending another command to

-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a

-- convenient way to wait for a specific command reply from the controller.

setHomeLight :: HasHomeLight t => HomeLightConfig -> Controller t -> IO ()
setHomeLight :: HomeLightConfig -> Controller t -> IO ()
setHomeLight HomeLightConfig
cfg Controller t
controller =
  Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x38 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    HomeLightConfig -> [Word8]
lightConfigCommand HomeLightConfig
cfg

-- | Enables ('True') or disables ('False') the inertial measurement unit (i.e., 

-- accelerometer, gyroscope) of a Nintendo Switch controller. Inertial measurement

-- is disabled by default.

--

-- Note: After sending a command like this to a controller, it is highly advised

-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'

-- ('Device.Nintendo.Switch.SetInertialMeasurement', to be exact) or at least call

-- 'Device.Nintendo.Switch.getInput' once before sending another command to

-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a

-- convenient way to wait for a specific command reply from the controller.

setInertialMeasurement :: Bool -> Controller t -> IO ()
setInertialMeasurement :: Bool -> Controller t -> IO ()
setInertialMeasurement Bool
on Controller t
controller =
  Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x40 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    (if Bool
on then Word8
0x01 else Word8
0x00) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
48 Word8
0x00

-- | The input mode of a Nintendo Switch controller determines the frequency and

-- amount of information received by 'Device.Nintendo.Switch.getInput'.

data InputMode
  = Standard
    -- ^ The default input mode. In this mode, controllers push 'Device.Nintendo.Switch.Input'

    -- packages in a 60Hz (Joy-Con) or 120Hz (Pro Controller) frequency, including

    -- 'Device.Nintendo.Switch.battery' information, 'Device.Nintendo.Switch.Analog' stick

    -- directions ('Device.Nintendo.Switch.stickLeft', 'Device.Nintendo.Switch.stickRight')

    -- and 'Device.Nintendo.Switch.Inertial' sensor data ('Device.Nintendo.Switch.extras')

    -- if activated via 'setInertialMeasurement'.

  | Simple
    -- ^ A simple input mode where a controller only pushes its 'Device.Nintendo.Switch.Input'

    -- whenever a button is pressed or a 'Device.Nintendo.Switch.CommandReply' ('Device.Nintendo.Switch.extras')

    -- is sent. In this mode, controllers only send 'Device.Nintendo.Switch.Discrete' stick

    -- directions ('Device.Nintendo.Switch.stickLeft', 'Device.Nintendo.Switch.stickRight')

    -- and no inertial sensor data. Furthermore, 'Device.Nintendo.Switch.battery' information

    -- is only sent in combination with command replies.

  deriving (InputMode -> InputMode -> Bool
(InputMode -> InputMode -> Bool)
-> (InputMode -> InputMode -> Bool) -> Eq InputMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InputMode -> InputMode -> Bool
$c/= :: InputMode -> InputMode -> Bool
== :: InputMode -> InputMode -> Bool
$c== :: InputMode -> InputMode -> Bool
Eq, ReadPrec [InputMode]
ReadPrec InputMode
Int -> ReadS InputMode
ReadS [InputMode]
(Int -> ReadS InputMode)
-> ReadS [InputMode]
-> ReadPrec InputMode
-> ReadPrec [InputMode]
-> Read InputMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [InputMode]
$creadListPrec :: ReadPrec [InputMode]
readPrec :: ReadPrec InputMode
$creadPrec :: ReadPrec InputMode
readList :: ReadS [InputMode]
$creadList :: ReadS [InputMode]
readsPrec :: Int -> ReadS InputMode
$creadsPrec :: Int -> ReadS InputMode
Read, Int -> InputMode -> ShowS
[InputMode] -> ShowS
InputMode -> String
(Int -> InputMode -> ShowS)
-> (InputMode -> String)
-> ([InputMode] -> ShowS)
-> Show InputMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputMode] -> ShowS
$cshowList :: [InputMode] -> ShowS
show :: InputMode -> String
$cshow :: InputMode -> String
showsPrec :: Int -> InputMode -> ShowS
$cshowsPrec :: Int -> InputMode -> ShowS
Show)

-- | Sets the input mode of a Nintendo Switch controller.

--

-- Note: After sending a command like this to a controller, it is highly advised

-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'

-- ('Device.Nintendo.Switch.SetInputMode', to be exact) or at least call

-- 'Device.Nintendo.Switch.getInput' once before sending another command to

-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a

-- convenient way to wait for a specific command reply from the controller.

setInputMode :: HasInputMode t => InputMode -> Controller t -> IO ()
setInputMode :: InputMode -> Controller t -> IO ()
setInputMode = InputMode -> Controller t -> IO ()
forall (t :: ControllerType). InputMode -> Controller t -> IO ()
setInputModeInternal

setInputModeInternal :: InputMode -> Controller t -> IO ()
setInputModeInternal :: InputMode -> Controller t -> IO ()
setInputModeInternal InputMode
mode Controller t
controller =
  Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x03 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    InputMode -> Word8
toByte InputMode
mode Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
48 Word8
0x00
  where
    toByte :: InputMode -> Word8
toByte = \case
      InputMode
Standard -> Word8
0x30
      InputMode
Simple   -> Word8
0x3F

neutralPartRumble :: [Word8]
neutralPartRumble :: [Word8]
neutralPartRumble = [Word8
0x00, Word8
0x01, Word8
0x40, Word8
0x40]

neutralRumble :: [Word8]
neutralRumble :: [Word8]
neutralRumble = [Word8]
neutralPartRumble [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8]
neutralPartRumble

sendCommand :: Device -> Word8 -> [Word8] -> IO ()
sendCommand :: Device -> Word8 -> [Word8] -> IO ()
sendCommand Device
dev Word8
cmdID [Word8]
cmdData = do
  Int
size <- Device -> ByteString -> IO Int
write Device
dev (ByteString -> IO Int) -> ByteString -> IO Int
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack (Word8
cmdID Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
cmdData)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ OutputException -> IO ()
forall e a. Exception e => e -> IO a
throwIO OutputException
WriteException -- should check the size more precisely here


sendRawSubcommand :: Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand :: Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand Device
dev IORef Word8
ref Word8
cmdID Word8
subID [Word8]
subData = do
  Word8
count <- IORef Word8 -> IO Word8
forall a. IORef a -> IO a
readIORef IORef Word8
ref
  Device -> Word8 -> [Word8] -> IO ()
sendCommand Device
dev Word8
cmdID ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8
count Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
neutralRumble [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Word8
subID Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
subData
  IORef Word8 -> Word8 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Word8
ref (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8
0x0F Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8 -> Word8
forall a. Enum a => a -> a
succ Word8
count

sendSubcommand :: Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand :: Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller =
  Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand
    ( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
    ( Controller t -> IORef Word8
forall (t :: ControllerType). Controller t -> IORef Word8
counter Controller t
controller )

encodeHF :: (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeHF :: a -> (Word8, Word8)
encodeHF a
freq = (Word8
hfH, Word8
hfL)
  where clamped :: a
clamped = a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
clamp a
81.75177 a
1252.572266 a
freq
        base :: Int
base = a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
2 (a
clamped a -> a -> a
forall a. Num a => a -> a -> a
* a
0.1) a -> a -> a
forall a. Num a => a -> a -> a
* a
32
        hf :: Int
hf = (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x60) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 :: Int
        hfH :: Word8
hfH = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
hf Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFF
        hfL :: Word8
hfL = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
hf Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFF

encodeLF :: (Floating a, RealFrac a) => a -> Word8
encodeLF :: a -> Word8
encodeLF a
freq = Word8
base Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x40
  where clamped :: a
clamped = a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
clamp a
40.875885 a
626.286133 a
freq
        base :: Word8
base = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
2 (a
clamped a -> a -> a
forall a. Num a => a -> a -> a
* a
0.1) a -> a -> a
forall a. Num a => a -> a -> a
* a
32

encodeHA :: (Floating a, RealFrac a) => a -> Word8
encodeHA :: a -> Word8
encodeHA a
amp | a
clamped a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0.117 = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ (a
base a -> a -> a
forall a. Num a => a -> a -> a
- a
0x60) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
5 a -> a -> a
forall a. Num a => a -> a -> a
- (a
2 a -> a -> a
forall a. Floating a => a -> a -> a
** a
clamped)) a -> a -> a
forall a. Num a => a -> a -> a
- a
1
             | a
clamped a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0.23 = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ (a
base a -> a -> a
forall a. Num a => a -> a -> a
- a
0x60) a -> a -> a
forall a. Num a => a -> a -> a
* a
2 a -> a -> a
forall a. Num a => a -> a -> a
- a
0xF6
             | Bool
otherwise = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a
base a -> a -> a
forall a. Num a => a -> a -> a
- a
0xBC
  where clamped :: a
clamped = a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
clamp a
0.0 a
1.0 a
amp
        base :: a
base = a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
2 (a
clamped a -> a -> a
forall a. Num a => a -> a -> a
* a
1000) a -> a -> a
forall a. Num a => a -> a -> a
* a
32

encodeLA :: (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeLA :: a -> (Word8, Word8)
encodeLA a
amp = (Word8
laH, Word8
laL)
  where encoded :: Word8
encoded = a -> Word8
forall a. (Floating a, RealFrac a) => a -> Word8
encodeHA a
amp Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
2
        isOdd :: Bool
isOdd = Word8 -> Bool
forall a. Integral a => a -> Bool
odd Word8
encoded
        laH :: Word8
laH = if Bool
isOdd then Word8
0x80 else Word8
0x00
        laL :: Word8
laL = Word8
0x40 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (if Bool
isOdd then Word8
encoded Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
1 else Word8
encoded) Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
2

rumblePartCommand :: RumbleConfig -> [Word8]
rumblePartCommand :: RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
cfg = let
    (Word8
hfH, Word8
hfL) = Double -> (Word8, Word8)
forall a. (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeHF (Double -> (Word8, Word8)) -> Double -> (Word8, Word8)
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
highFrequency RumbleConfig
cfg
    ha :: Word8
ha         = Double -> Word8
forall a. (Floating a, RealFrac a) => a -> Word8
encodeHA (Double -> Word8) -> Double -> Word8
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
highAmplitude RumbleConfig
cfg
    lf :: Word8
lf         = Double -> Word8
forall a. (Floating a, RealFrac a) => a -> Word8
encodeLF (Double -> Word8) -> Double -> Word8
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
lowFrequency RumbleConfig
cfg
    (Word8
laH, Word8
laL) = Double -> (Word8, Word8)
forall a. (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeLA (Double -> (Word8, Word8)) -> Double -> (Word8, Word8)
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
lowAmplitude RumbleConfig
cfg
  in [Word8
hfH, Word8
ha Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
hfL, Word8
lf Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
laH, Word8
laL]

-- | Nintendo Switch controllers have a HD rumble feature which allows

-- fine-grained control of rumble strengths and directions. As a consequence,

-- a rumble is not configured by a mere numeric value, but by two (high and low)

-- pairs of frequencies and amplitudes. This library constrains the value ranges

-- of frequencies and amplitudes in order to always obtain sane configurations.

-- However, sending extreme values for these pairs over an extended period of time

-- may still damage a controller, so experiment wisely with rather short rumbles.

--

-- For technical discussions and the meaning of these values, one can read

-- <https://github.com/dekuNukem/Nintendo_Switch_Reverse_Engineering/issues/11 this>,

-- for example. A sample rumble configuration is provided by 'normalRumble'.

data RumbleConfig =
  RumbleConfig
    { RumbleConfig -> Double
highFrequency :: Double
      -- ^ The high frequency. It will always be limited to an interval between

      -- 81.75177 Hz and 1252.572266 Hz.

    , RumbleConfig -> Double
highAmplitude :: Double
      -- ^ The high amplitude. It will always be limited to an interval between

      -- 0.0 and 1.0.

    , RumbleConfig -> Double
lowFrequency  :: Double
      -- ^ The low frequency. It will always be limited to an interval between

      -- 40.875885 Hz and 626.286133 Hz.

    , RumbleConfig -> Double
lowAmplitude  :: Double
      -- ^ The low amplitude. It will always be limited to an interval between

      -- 0.0 and 1.0.

    }
  deriving (RumbleConfig -> RumbleConfig -> Bool
(RumbleConfig -> RumbleConfig -> Bool)
-> (RumbleConfig -> RumbleConfig -> Bool) -> Eq RumbleConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RumbleConfig -> RumbleConfig -> Bool
$c/= :: RumbleConfig -> RumbleConfig -> Bool
== :: RumbleConfig -> RumbleConfig -> Bool
$c== :: RumbleConfig -> RumbleConfig -> Bool
Eq, ReadPrec [RumbleConfig]
ReadPrec RumbleConfig
Int -> ReadS RumbleConfig
ReadS [RumbleConfig]
(Int -> ReadS RumbleConfig)
-> ReadS [RumbleConfig]
-> ReadPrec RumbleConfig
-> ReadPrec [RumbleConfig]
-> Read RumbleConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RumbleConfig]
$creadListPrec :: ReadPrec [RumbleConfig]
readPrec :: ReadPrec RumbleConfig
$creadPrec :: ReadPrec RumbleConfig
readList :: ReadS [RumbleConfig]
$creadList :: ReadS [RumbleConfig]
readsPrec :: Int -> ReadS RumbleConfig
$creadsPrec :: Int -> ReadS RumbleConfig
Read, Int -> RumbleConfig -> ShowS
[RumbleConfig] -> ShowS
RumbleConfig -> String
(Int -> RumbleConfig -> ShowS)
-> (RumbleConfig -> String)
-> ([RumbleConfig] -> ShowS)
-> Show RumbleConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RumbleConfig] -> ShowS
$cshowList :: [RumbleConfig] -> ShowS
show :: RumbleConfig -> String
$cshow :: RumbleConfig -> String
showsPrec :: Int -> RumbleConfig -> ShowS
$cshowsPrec :: Int -> RumbleConfig -> ShowS
Show)

-- | A convenient rumble configuration indicating a medium rumble strength.

--

-- @

--     'RumbleConfig'

--       { 'highFrequency' = 800

--       , 'highAmplitude' = 0.5

--       , 'lowFrequency'  = 330

--       , 'lowAmplitude'  = 0.75

--       }

-- @

normalRumble :: RumbleConfig
normalRumble :: RumbleConfig
normalRumble =
  RumbleConfig :: Double -> Double -> Double -> Double -> RumbleConfig
RumbleConfig
    { highFrequency :: Double
highFrequency = Double
800
    , highAmplitude :: Double
highAmplitude = Double
0.5
    , lowFrequency :: Double
lowFrequency  = Double
330
    , lowAmplitude :: Double
lowAmplitude  = Double
0.75
    }

-- | A convenient rumble configuration indicating no rumble.

noRumble :: RumbleConfig
noRumble :: RumbleConfig
noRumble =
  RumbleConfig :: Double -> Double -> Double -> Double -> RumbleConfig
RumbleConfig
    { highFrequency :: Double
highFrequency = Double
320
    , highAmplitude :: Double
highAmplitude = Double
0
    , lowFrequency :: Double
lowFrequency  = Double
160
    , lowAmplitude :: Double
lowAmplitude  = Double
0
    }

-- | Enables ('True') or disables ('False') the rumble feature of a Nintendo

-- Switch controller. The rumble feature is disabled by default.

--

-- Note: After sending a command like this to a controller, it is highly advised

-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'

-- ('Device.Nintendo.Switch.SetVibration', to be exact) or at least call

-- 'Device.Nintendo.Switch.getInput' once before sending another command to

-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a

-- convenient way to wait for a specific command reply from the controller.

setVibration :: Bool -> Controller t -> IO ()
setVibration :: Bool -> Controller t -> IO ()
setVibration Bool
on Controller t
controller =
  Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x48 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    (if Bool
on then Word8
0x01 else Word8
0x00) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
48 Word8
0x00

-- | Sets the left rumble of a Nintendo Switch controller.

setLeftRumble :: HasLeftRumble t => RumbleConfig -> Controller t -> IO ()
setLeftRumble :: RumbleConfig -> Controller t -> IO ()
setLeftRumble RumbleConfig
cfg Controller t
controller =
  Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand
    ( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
    ( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
cfg )
    ( [Word8]
neutralPartRumble )

-- | Sets the right rumble of a Nintendo Switch controller.

setRightRumble :: HasRightRumble t => RumbleConfig -> Controller t -> IO ()
setRightRumble :: RumbleConfig -> Controller t -> IO ()
setRightRumble RumbleConfig
cfg Controller t
controller =
  Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand
    ( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
    ( [Word8]
neutralPartRumble )
    ( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
cfg )

-- | Sets both the left rumble and right rumble of a Nintendo Switch controller.

-- Note that this is more efficient than setting the left rumble and right rumble

-- separately via 'setLeftRumble' and 'setRightRumble'.

setRumble
  :: (HasLeftRumble t, HasRightRumble t)
  => RumbleConfig -- ^ The left-side rumble configuration.

  -> RumbleConfig -- ^ The right-side rumble configuration.

  -> Controller t -- ^ The controller which should rumble.

  -> IO ()
setRumble :: RumbleConfig -> RumbleConfig -> Controller t -> IO ()
setRumble RumbleConfig
leftCfg RumbleConfig
rightCfg Controller t
controller =
  Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand
    ( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
    ( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
leftCfg )
    ( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
rightCfg )

sendRawRumbleCommand :: Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand :: Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand Device
dev [Word8]
left [Word8]
right =
  Device -> Word8 -> [Word8] -> IO ()
sendCommand Device
dev Word8
0x10 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8
0x00 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
left [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8]
right [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
40 Word8
0x00

requestRawSPI :: Device -> IORef Word8 -> Word32 -> Word8 -> IO ()
requestRawSPI :: Device -> IORef Word8 -> Word32 -> Word8 -> IO ()
requestRawSPI Device
dev IORef Word8
ref Word32
start Word8
len =
  let
    byte0 :: Word8
byte0 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$         Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x000000FF
    byte1 :: Word8
byte1 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x0000FF00) Int
8
    byte2 :: Word8
byte2 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x00FF0000) Int
16
    byte3 :: Word8
byte3 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF000000) Int
24
  in
  Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand Device
dev IORef Word8
ref Word8
0x01 Word8
0x10 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Word8
byte0, Word8
byte1, Word8
byte2, Word8
byte3, Word8 -> Word8 -> Word8 -> Word8
forall a. Ord a => a -> a -> a -> a
clamp Word8
0x00 Word8
0x1D Word8
len] [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
44 Word8
0x00

-- | Nintendo Switch controllers have four LEDs that can be used to indicate

-- various things, for example the player number or the Bluetooth pairing status.

-- The LEDs are numbered from left to right (i.e., 'led0' is the leftmost LED,

-- 'led3' is the rightmost LED).

data PlayerLightsConfig =
  PlayerLightsConfig
    { PlayerLightsConfig -> LightMode
led0 :: LightMode
    , PlayerLightsConfig -> LightMode
led1 :: LightMode
    , PlayerLightsConfig -> LightMode
led2 :: LightMode
    , PlayerLightsConfig -> LightMode
led3 :: LightMode
    }
  deriving (PlayerLightsConfig -> PlayerLightsConfig -> Bool
(PlayerLightsConfig -> PlayerLightsConfig -> Bool)
-> (PlayerLightsConfig -> PlayerLightsConfig -> Bool)
-> Eq PlayerLightsConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
$c/= :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
== :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
$c== :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
Eq, ReadPrec [PlayerLightsConfig]
ReadPrec PlayerLightsConfig
Int -> ReadS PlayerLightsConfig
ReadS [PlayerLightsConfig]
(Int -> ReadS PlayerLightsConfig)
-> ReadS [PlayerLightsConfig]
-> ReadPrec PlayerLightsConfig
-> ReadPrec [PlayerLightsConfig]
-> Read PlayerLightsConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PlayerLightsConfig]
$creadListPrec :: ReadPrec [PlayerLightsConfig]
readPrec :: ReadPrec PlayerLightsConfig
$creadPrec :: ReadPrec PlayerLightsConfig
readList :: ReadS [PlayerLightsConfig]
$creadList :: ReadS [PlayerLightsConfig]
readsPrec :: Int -> ReadS PlayerLightsConfig
$creadsPrec :: Int -> ReadS PlayerLightsConfig
Read, Int -> PlayerLightsConfig -> ShowS
[PlayerLightsConfig] -> ShowS
PlayerLightsConfig -> String
(Int -> PlayerLightsConfig -> ShowS)
-> (PlayerLightsConfig -> String)
-> ([PlayerLightsConfig] -> ShowS)
-> Show PlayerLightsConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlayerLightsConfig] -> ShowS
$cshowList :: [PlayerLightsConfig] -> ShowS
show :: PlayerLightsConfig -> String
$cshow :: PlayerLightsConfig -> String
showsPrec :: Int -> PlayerLightsConfig -> ShowS
$cshowsPrec :: Int -> PlayerLightsConfig -> ShowS
Show)

-- | Each player light LED can be individually turned on, turned off or used in

-- a pulsating manner (i.e., flashing).

data LightMode
  = LightOn
  | LightOff
  | Flashing
  deriving (LightMode -> LightMode -> Bool
(LightMode -> LightMode -> Bool)
-> (LightMode -> LightMode -> Bool) -> Eq LightMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LightMode -> LightMode -> Bool
$c/= :: LightMode -> LightMode -> Bool
== :: LightMode -> LightMode -> Bool
$c== :: LightMode -> LightMode -> Bool
Eq, ReadPrec [LightMode]
ReadPrec LightMode
Int -> ReadS LightMode
ReadS [LightMode]
(Int -> ReadS LightMode)
-> ReadS [LightMode]
-> ReadPrec LightMode
-> ReadPrec [LightMode]
-> Read LightMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LightMode]
$creadListPrec :: ReadPrec [LightMode]
readPrec :: ReadPrec LightMode
$creadPrec :: ReadPrec LightMode
readList :: ReadS [LightMode]
$creadList :: ReadS [LightMode]
readsPrec :: Int -> ReadS LightMode
$creadsPrec :: Int -> ReadS LightMode
Read, Int -> LightMode -> ShowS
[LightMode] -> ShowS
LightMode -> String
(Int -> LightMode -> ShowS)
-> (LightMode -> String)
-> ([LightMode] -> ShowS)
-> Show LightMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LightMode] -> ShowS
$cshowList :: [LightMode] -> ShowS
show :: LightMode -> String
$cshow :: LightMode -> String
showsPrec :: Int -> LightMode -> ShowS
$cshowsPrec :: Int -> LightMode -> ShowS
Show)

-- | A convenient player lights configuration where all LEDs are turned off.

noPlayerLights :: PlayerLightsConfig
noPlayerLights :: PlayerLightsConfig
noPlayerLights =
  PlayerLightsConfig :: LightMode
-> LightMode -> LightMode -> LightMode -> PlayerLightsConfig
PlayerLightsConfig
    { led0 :: LightMode
led0 = LightMode
LightOff
    , led1 :: LightMode
led1 = LightMode
LightOff
    , led2 :: LightMode
led2 = LightMode
LightOff
    , led3 :: LightMode
led3 = LightMode
LightOff
    }

-- | A convenient player lights configuration indicating player one (i.e., 'led0' is set).

playerOne :: PlayerLightsConfig
playerOne :: PlayerLightsConfig
playerOne = PlayerLightsConfig
noPlayerLights { led0 :: LightMode
led0 = LightMode
LightOn }

-- | A convenient player lights configuration indicating player two (i.e., 'led1' is set).

playerTwo :: PlayerLightsConfig
playerTwo :: PlayerLightsConfig
playerTwo = PlayerLightsConfig
noPlayerLights { led1 :: LightMode
led1 = LightMode
LightOn }

-- | A convenient player lights configuration indicating player three (i.e., 'led2' is set).

playerThree :: PlayerLightsConfig
playerThree :: PlayerLightsConfig
playerThree = PlayerLightsConfig
noPlayerLights { led2 :: LightMode
led2 = LightMode
LightOn }

-- | A convenient player lights configuration indicating player four (i.e., 'led3' is set).

playerFour :: PlayerLightsConfig
playerFour :: PlayerLightsConfig
playerFour = PlayerLightsConfig
noPlayerLights { led3 :: LightMode
led3 = LightMode
LightOn }

-- | A convenient player lights configuration where all LEDs are flashing.

flashAll :: PlayerLightsConfig
flashAll :: PlayerLightsConfig
flashAll =
  PlayerLightsConfig :: LightMode
-> LightMode -> LightMode -> LightMode -> PlayerLightsConfig
PlayerLightsConfig
    { led0 :: LightMode
led0 = LightMode
Flashing
    , led1 :: LightMode
led1 = LightMode
Flashing
    , led2 :: LightMode
led2 = LightMode
Flashing
    , led3 :: LightMode
led3 = LightMode
Flashing
    }

-- | Sets the player lights of a Nintendo Switch controller.

--

-- Note: After sending a command like this to a controller, it is highly advised

-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'

-- ('Device.Nintendo.Switch.SetPlayerLights', to be exact) or at least call

-- 'Device.Nintendo.Switch.getInput' once before sending another command to

-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a

-- convenient way to wait for a specific command reply from the controller.

setPlayerLights :: HasPlayerLights t => PlayerLightsConfig -> Controller t -> IO ()
setPlayerLights :: PlayerLightsConfig -> Controller t -> IO ()
setPlayerLights PlayerLightsConfig
config Controller t
controller =
  Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x30 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [ (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led0 Word8
0x01
    (Word8 -> Word8) -> (Word8 -> Word8) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led1 Word8
0x02
    (Word8 -> Word8) -> (Word8 -> Word8) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led2 Word8
0x04
    (Word8 -> Word8) -> (Word8 -> Word8) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led3 Word8
0x08
    (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ Word8
0x00
    ]
  where
    setBit :: (PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
f a
position =
      case PlayerLightsConfig -> LightMode
f PlayerLightsConfig
config of
        LightMode
LightOn  -> (a
position a -> a -> a
forall a. Bits a => a -> a -> a
.|.)
        LightMode
LightOff -> a -> a
forall a. a -> a
id
        LightMode
Flashing -> (a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftL a
position Int
4 a -> a -> a
forall a. Bits a => a -> a -> a
.|.)