{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
module Device.Nintendo.Switch.Input where
import Data.Attoparsec.ByteString (IResult(Done), Parser, anyWord8, parse, take, word8)
import Control.Applicative ((<|>))
import Control.Exception (Exception, throwIO)
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
import Data.IORef (IORef)
import Data.Int (Int16)
import Data.List (intercalate)
import Data.Word (Word8, Word16, Word32)
import Numeric (showHex)
import Prelude hiding (Left, Right, read, take)
import qualified Data.ByteString as BS
import System.HIDAPI (Device, read, readTimeout)
import Device.Nintendo.Switch.Controller
import Device.Nintendo.Switch.Output (requestRawSPI)
import Device.Nintendo.Switch.Utils (checkMask, clamp, tripleMap, tripleParser, tripleZipWith)
class HasInput t where
convert :: Controller t -> RawInput -> Input
instance HasInput 'LeftJoyCon where
convert :: Controller 'LeftJoyCon -> RawInput -> Input
convert Controller 'LeftJoyCon
controller RawInput
raw =
ControllerInput Float Any
forall s e. ControllerInput s e
noInput
{ btnL :: Bool
btnL = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnL RawInput
raw
, btnZL :: Bool
btnZL = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnZL RawInput
raw
, btnMinus :: Bool
btnMinus = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnMinus RawInput
raw
, btnLeftStick :: Bool
btnLeftStick = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnLeftStick RawInput
raw
, btnUp :: Bool
btnUp = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnUp RawInput
raw
, btnLeft :: Bool
btnLeft = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnLeft RawInput
raw
, btnRight :: Bool
btnRight = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnRight RawInput
raw
, btnDown :: Bool
btnDown = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnDown RawInput
raw
, btnCapture :: Bool
btnCapture = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnCapture RawInput
raw
, btnLeftSL :: Bool
btnLeftSL = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnLeftSL RawInput
raw
, btnLeftSR :: Bool
btnLeftSR = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnLeftSR RawInput
raw
, stickLeft :: StickDirection Float
stickLeft = StickDirection Word16 -> StickCalibration -> StickDirection Float
adjustStick (RawInput -> StickDirection Word16
forall s e. ControllerInput s e -> StickDirection s
stickLeft RawInput
raw) (Calibration -> StickCalibration
leftStickCal Calibration
cal)
, extras :: ExtraInput Float
extras = ExtraInput Int16
-> (Float, Float, Float)
-> (Float, Float, Float)
-> ExtraInput Float
adjustSensor (RawInput -> ExtraInput Int16
forall s e. ControllerInput s e -> ExtraInput e
extras RawInput
raw) (Calibration -> (Float, Float, Float)
accCoeffs Calibration
cal) (Calibration -> (Float, Float, Float)
gyroCoeffs Calibration
cal)
, battery :: Maybe BatteryInfo
battery = RawInput -> Maybe BatteryInfo
forall s e. ControllerInput s e -> Maybe BatteryInfo
battery RawInput
raw
}
where
cal :: Calibration
cal = Controller 'LeftJoyCon -> Calibration
forall (t :: ControllerType). Controller t -> Calibration
calibration Controller 'LeftJoyCon
controller
instance HasInput 'RightJoyCon where
convert :: Controller 'RightJoyCon -> RawInput -> Input
convert Controller 'RightJoyCon
controller RawInput
raw =
ControllerInput Float Any
forall s e. ControllerInput s e
noInput
{ btnR :: Bool
btnR = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnR RawInput
raw
, btnZR :: Bool
btnZR = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnZR RawInput
raw
, btnPlus :: Bool
btnPlus = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnPlus RawInput
raw
, btnX :: Bool
btnX = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnX RawInput
raw
, btnY :: Bool
btnY = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnY RawInput
raw
, btnA :: Bool
btnA = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnA RawInput
raw
, btnB :: Bool
btnB = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnB RawInput
raw
, btnRightStick :: Bool
btnRightStick = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnRightStick RawInput
raw
, btnHome :: Bool
btnHome = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnHome RawInput
raw
, btnRightSL :: Bool
btnRightSL = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnRightSL RawInput
raw
, btnRightSR :: Bool
btnRightSR = RawInput -> Bool
forall s e. ControllerInput s e -> Bool
btnRightSR RawInput
raw
, stickRight :: StickDirection Float
stickRight = StickDirection Word16 -> StickCalibration -> StickDirection Float
adjustStick (RawInput -> StickDirection Word16
forall s e. ControllerInput s e -> StickDirection s
stickRight RawInput
raw) (Calibration -> StickCalibration
rightStickCal Calibration
cal)
, extras :: ExtraInput Float
extras = ((Float, Float, Float) -> (Float, Float, Float))
-> ExtraInput Float -> ExtraInput Float
forall a. ((a, a, a) -> (a, a, a)) -> ExtraInput a -> ExtraInput a
extraMap
( \(Float
x,Float
y,Float
z) -> (Float
x, -Float
y, -Float
z) )
( ExtraInput Int16
-> (Float, Float, Float)
-> (Float, Float, Float)
-> ExtraInput Float
adjustSensor (RawInput -> ExtraInput Int16
forall s e. ControllerInput s e -> ExtraInput e
extras RawInput
raw) (Calibration -> (Float, Float, Float)
accCoeffs Calibration
cal) (Calibration -> (Float, Float, Float)
gyroCoeffs Calibration
cal) )
, battery :: Maybe BatteryInfo
battery = RawInput -> Maybe BatteryInfo
forall s e. ControllerInput s e -> Maybe BatteryInfo
battery RawInput
raw
}
where
cal :: Calibration
cal = Controller 'RightJoyCon -> Calibration
forall (t :: ControllerType). Controller t -> Calibration
calibration Controller 'RightJoyCon
controller
extraMap :: ((a, a, a) -> (a, a, a)) -> ExtraInput a -> ExtraInput a
extraMap (a, a, a) -> (a, a, a)
f = \case
Inertial Accelerometer a
a Accelerometer a
g -> Accelerometer a -> Accelerometer a -> ExtraInput a
forall a. Accelerometer a -> Accelerometer a -> ExtraInput a
Inertial (((a, a, a) -> (a, a, a)) -> Accelerometer a -> Accelerometer a
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap (a, a, a) -> (a, a, a)
f Accelerometer a
a) (((a, a, a) -> (a, a, a)) -> Accelerometer a -> Accelerometer a
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap (a, a, a) -> (a, a, a)
f Accelerometer a
g)
ExtraInput a
other -> ExtraInput a
other
instance HasInput 'ProController where
convert :: Controller 'ProController -> RawInput -> Input
convert Controller 'ProController
controller RawInput
raw =
RawInput
raw
{ stickLeft :: StickDirection Float
stickLeft = StickDirection Word16 -> StickCalibration -> StickDirection Float
adjustStick (RawInput -> StickDirection Word16
forall s e. ControllerInput s e -> StickDirection s
stickLeft RawInput
raw) (Calibration -> StickCalibration
leftStickCal Calibration
cal)
, stickRight :: StickDirection Float
stickRight = StickDirection Word16 -> StickCalibration -> StickDirection Float
adjustStick (RawInput -> StickDirection Word16
forall s e. ControllerInput s e -> StickDirection s
stickRight RawInput
raw) (Calibration -> StickCalibration
rightStickCal Calibration
cal)
, extras :: ExtraInput Float
extras = ExtraInput Int16
-> (Float, Float, Float)
-> (Float, Float, Float)
-> ExtraInput Float
adjustSensor (RawInput -> ExtraInput Int16
forall s e. ControllerInput s e -> ExtraInput e
extras RawInput
raw) (Calibration -> (Float, Float, Float)
accCoeffs Calibration
cal) (Calibration -> (Float, Float, Float)
gyroCoeffs Calibration
cal)
}
where
cal :: Calibration
cal = Controller 'ProController -> Calibration
forall (t :: ControllerType). Controller t -> Calibration
calibration Controller 'ProController
controller
data InputException
= NoReplyException
| UnknownFormatException BS.ByteString
deriving InputException -> InputException -> Bool
(InputException -> InputException -> Bool)
-> (InputException -> InputException -> Bool) -> Eq InputException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InputException -> InputException -> Bool
$c/= :: InputException -> InputException -> Bool
== :: InputException -> InputException -> Bool
$c== :: InputException -> InputException -> Bool
Eq
instance Exception InputException
instance Show InputException where
show :: InputException -> String
show = \case
InputException
NoReplyException ->
String
"Did not receive a reply in a given time interval."
UnknownFormatException ByteString
bs ->
String
"Encountered an unknown input format: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Word8 -> String) -> [Word8] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word8 -> ShowS) -> String -> Word8 -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex String
"") (ByteString -> [Word8]
BS.unpack ByteString
bs))
type Input = ControllerInput Float Float
type RawInput = ControllerInput Word16 Int16
data ControllerInput s e =
Input
{
ControllerInput s e -> Bool
btnL :: Bool
, ControllerInput s e -> Bool
btnZL :: Bool
, ControllerInput s e -> Bool
btnMinus :: Bool
, ControllerInput s e -> Bool
btnLeftStick :: Bool
, ControllerInput s e -> Bool
btnUp :: Bool
, ControllerInput s e -> Bool
btnLeft :: Bool
, ControllerInput s e -> Bool
btnRight :: Bool
, ControllerInput s e -> Bool
btnDown :: Bool
, ControllerInput s e -> Bool
btnCapture :: Bool
, ControllerInput s e -> Bool
btnLeftSL :: Bool
, ControllerInput s e -> Bool
btnLeftSR :: Bool
, ControllerInput s e -> Bool
btnR :: Bool
, ControllerInput s e -> Bool
btnZR :: Bool
, ControllerInput s e -> Bool
btnPlus :: Bool
, ControllerInput s e -> Bool
btnX :: Bool
, ControllerInput s e -> Bool
btnY :: Bool
, ControllerInput s e -> Bool
btnA :: Bool
, ControllerInput s e -> Bool
btnB :: Bool
, ControllerInput s e -> Bool
btnRightStick :: Bool
, ControllerInput s e -> Bool
btnHome :: Bool
, ControllerInput s e -> Bool
btnRightSL :: Bool
, ControllerInput s e -> Bool
btnRightSR :: Bool
, ControllerInput s e -> StickDirection s
stickLeft :: StickDirection s
, ControllerInput s e -> StickDirection s
stickRight :: StickDirection s
, :: ExtraInput e
, ControllerInput s e -> Maybe BatteryInfo
battery :: Maybe BatteryInfo
}
deriving (ControllerInput s e -> ControllerInput s e -> Bool
(ControllerInput s e -> ControllerInput s e -> Bool)
-> (ControllerInput s e -> ControllerInput s e -> Bool)
-> Eq (ControllerInput s e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s e.
(Eq s, Eq e) =>
ControllerInput s e -> ControllerInput s e -> Bool
/= :: ControllerInput s e -> ControllerInput s e -> Bool
$c/= :: forall s e.
(Eq s, Eq e) =>
ControllerInput s e -> ControllerInput s e -> Bool
== :: ControllerInput s e -> ControllerInput s e -> Bool
$c== :: forall s e.
(Eq s, Eq e) =>
ControllerInput s e -> ControllerInput s e -> Bool
Eq, ReadPrec [ControllerInput s e]
ReadPrec (ControllerInput s e)
Int -> ReadS (ControllerInput s e)
ReadS [ControllerInput s e]
(Int -> ReadS (ControllerInput s e))
-> ReadS [ControllerInput s e]
-> ReadPrec (ControllerInput s e)
-> ReadPrec [ControllerInput s e]
-> Read (ControllerInput s e)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall s e. (Read s, Read e) => ReadPrec [ControllerInput s e]
forall s e. (Read s, Read e) => ReadPrec (ControllerInput s e)
forall s e. (Read s, Read e) => Int -> ReadS (ControllerInput s e)
forall s e. (Read s, Read e) => ReadS [ControllerInput s e]
readListPrec :: ReadPrec [ControllerInput s e]
$creadListPrec :: forall s e. (Read s, Read e) => ReadPrec [ControllerInput s e]
readPrec :: ReadPrec (ControllerInput s e)
$creadPrec :: forall s e. (Read s, Read e) => ReadPrec (ControllerInput s e)
readList :: ReadS [ControllerInput s e]
$creadList :: forall s e. (Read s, Read e) => ReadS [ControllerInput s e]
readsPrec :: Int -> ReadS (ControllerInput s e)
$creadsPrec :: forall s e. (Read s, Read e) => Int -> ReadS (ControllerInput s e)
Read, Int -> ControllerInput s e -> ShowS
[ControllerInput s e] -> ShowS
ControllerInput s e -> String
(Int -> ControllerInput s e -> ShowS)
-> (ControllerInput s e -> String)
-> ([ControllerInput s e] -> ShowS)
-> Show (ControllerInput s e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s e. (Show s, Show e) => Int -> ControllerInput s e -> ShowS
forall s e. (Show s, Show e) => [ControllerInput s e] -> ShowS
forall s e. (Show s, Show e) => ControllerInput s e -> String
showList :: [ControllerInput s e] -> ShowS
$cshowList :: forall s e. (Show s, Show e) => [ControllerInput s e] -> ShowS
show :: ControllerInput s e -> String
$cshow :: forall s e. (Show s, Show e) => ControllerInput s e -> String
showsPrec :: Int -> ControllerInput s e -> ShowS
$cshowsPrec :: forall s e. (Show s, Show e) => Int -> ControllerInput s e -> ShowS
Show)
noInput :: ControllerInput s e
noInput :: ControllerInput s e
noInput =
Input :: forall s e.
Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> StickDirection s
-> StickDirection s
-> ExtraInput e
-> Maybe BatteryInfo
-> ControllerInput s e
Input
{ btnL :: Bool
btnL = Bool
False
, btnZL :: Bool
btnZL = Bool
False
, btnMinus :: Bool
btnMinus = Bool
False
, btnLeftStick :: Bool
btnLeftStick = Bool
False
, btnUp :: Bool
btnUp = Bool
False
, btnLeft :: Bool
btnLeft = Bool
False
, btnRight :: Bool
btnRight = Bool
False
, btnDown :: Bool
btnDown = Bool
False
, btnCapture :: Bool
btnCapture = Bool
False
, btnLeftSL :: Bool
btnLeftSL = Bool
False
, btnLeftSR :: Bool
btnLeftSR = Bool
False
, btnR :: Bool
btnR = Bool
False
, btnZR :: Bool
btnZR = Bool
False
, btnPlus :: Bool
btnPlus = Bool
False
, btnX :: Bool
btnX = Bool
False
, btnY :: Bool
btnY = Bool
False
, btnA :: Bool
btnA = Bool
False
, btnB :: Bool
btnB = Bool
False
, btnRightStick :: Bool
btnRightStick = Bool
False
, btnHome :: Bool
btnHome = Bool
False
, btnRightSL :: Bool
btnRightSL = Bool
False
, btnRightSR :: Bool
btnRightSR = Bool
False
, stickLeft :: StickDirection s
stickLeft = Direction -> StickDirection s
forall a. Direction -> StickDirection a
Discrete Direction
None
, stickRight :: StickDirection s
stickRight = Direction -> StickDirection s
forall a. Direction -> StickDirection a
Discrete Direction
None
, extras :: ExtraInput e
extras = ExtraInput e
forall a. ExtraInput a
Unavailable
, battery :: Maybe BatteryInfo
battery = Maybe BatteryInfo
forall a. Maybe a
Nothing
}
type Accelerometer a = ((a, a, a), (a, a, a), (a, a, a))
type Gyroscope a = ((a, a, a), (a, a, a), (a, a, a))
data a
= CommandReply ReplyData
| Inertial (Accelerometer a) (Gyroscope a)
| Unavailable
deriving (ExtraInput a -> ExtraInput a -> Bool
(ExtraInput a -> ExtraInput a -> Bool)
-> (ExtraInput a -> ExtraInput a -> Bool) -> Eq (ExtraInput a)
forall a. Eq a => ExtraInput a -> ExtraInput a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtraInput a -> ExtraInput a -> Bool
$c/= :: forall a. Eq a => ExtraInput a -> ExtraInput a -> Bool
== :: ExtraInput a -> ExtraInput a -> Bool
$c== :: forall a. Eq a => ExtraInput a -> ExtraInput a -> Bool
Eq, a -> ExtraInput b -> ExtraInput a
(a -> b) -> ExtraInput a -> ExtraInput b
(forall a b. (a -> b) -> ExtraInput a -> ExtraInput b)
-> (forall a b. a -> ExtraInput b -> ExtraInput a)
-> Functor ExtraInput
forall a b. a -> ExtraInput b -> ExtraInput a
forall a b. (a -> b) -> ExtraInput a -> ExtraInput b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ExtraInput b -> ExtraInput a
$c<$ :: forall a b. a -> ExtraInput b -> ExtraInput a
fmap :: (a -> b) -> ExtraInput a -> ExtraInput b
$cfmap :: forall a b. (a -> b) -> ExtraInput a -> ExtraInput b
Functor, ReadPrec [ExtraInput a]
ReadPrec (ExtraInput a)
Int -> ReadS (ExtraInput a)
ReadS [ExtraInput a]
(Int -> ReadS (ExtraInput a))
-> ReadS [ExtraInput a]
-> ReadPrec (ExtraInput a)
-> ReadPrec [ExtraInput a]
-> Read (ExtraInput a)
forall a. Read a => ReadPrec [ExtraInput a]
forall a. Read a => ReadPrec (ExtraInput a)
forall a. Read a => Int -> ReadS (ExtraInput a)
forall a. Read a => ReadS [ExtraInput a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ExtraInput a]
$creadListPrec :: forall a. Read a => ReadPrec [ExtraInput a]
readPrec :: ReadPrec (ExtraInput a)
$creadPrec :: forall a. Read a => ReadPrec (ExtraInput a)
readList :: ReadS [ExtraInput a]
$creadList :: forall a. Read a => ReadS [ExtraInput a]
readsPrec :: Int -> ReadS (ExtraInput a)
$creadsPrec :: forall a. Read a => Int -> ReadS (ExtraInput a)
Read, Int -> ExtraInput a -> ShowS
[ExtraInput a] -> ShowS
ExtraInput a -> String
(Int -> ExtraInput a -> ShowS)
-> (ExtraInput a -> String)
-> ([ExtraInput a] -> ShowS)
-> Show (ExtraInput a)
forall a. Show a => Int -> ExtraInput a -> ShowS
forall a. Show a => [ExtraInput a] -> ShowS
forall a. Show a => ExtraInput a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtraInput a] -> ShowS
$cshowList :: forall a. Show a => [ExtraInput a] -> ShowS
show :: ExtraInput a -> String
$cshow :: forall a. Show a => ExtraInput a -> String
showsPrec :: Int -> ExtraInput a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ExtraInput a -> ShowS
Show)
data Acknowledgement a
= ACK a
| NACK
deriving (Acknowledgement a -> Acknowledgement a -> Bool
(Acknowledgement a -> Acknowledgement a -> Bool)
-> (Acknowledgement a -> Acknowledgement a -> Bool)
-> Eq (Acknowledgement a)
forall a. Eq a => Acknowledgement a -> Acknowledgement a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Acknowledgement a -> Acknowledgement a -> Bool
$c/= :: forall a. Eq a => Acknowledgement a -> Acknowledgement a -> Bool
== :: Acknowledgement a -> Acknowledgement a -> Bool
$c== :: forall a. Eq a => Acknowledgement a -> Acknowledgement a -> Bool
Eq, a -> Acknowledgement b -> Acknowledgement a
(a -> b) -> Acknowledgement a -> Acknowledgement b
(forall a b. (a -> b) -> Acknowledgement a -> Acknowledgement b)
-> (forall a b. a -> Acknowledgement b -> Acknowledgement a)
-> Functor Acknowledgement
forall a b. a -> Acknowledgement b -> Acknowledgement a
forall a b. (a -> b) -> Acknowledgement a -> Acknowledgement b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Acknowledgement b -> Acknowledgement a
$c<$ :: forall a b. a -> Acknowledgement b -> Acknowledgement a
fmap :: (a -> b) -> Acknowledgement a -> Acknowledgement b
$cfmap :: forall a b. (a -> b) -> Acknowledgement a -> Acknowledgement b
Functor, ReadPrec [Acknowledgement a]
ReadPrec (Acknowledgement a)
Int -> ReadS (Acknowledgement a)
ReadS [Acknowledgement a]
(Int -> ReadS (Acknowledgement a))
-> ReadS [Acknowledgement a]
-> ReadPrec (Acknowledgement a)
-> ReadPrec [Acknowledgement a]
-> Read (Acknowledgement a)
forall a. Read a => ReadPrec [Acknowledgement a]
forall a. Read a => ReadPrec (Acknowledgement a)
forall a. Read a => Int -> ReadS (Acknowledgement a)
forall a. Read a => ReadS [Acknowledgement a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Acknowledgement a]
$creadListPrec :: forall a. Read a => ReadPrec [Acknowledgement a]
readPrec :: ReadPrec (Acknowledgement a)
$creadPrec :: forall a. Read a => ReadPrec (Acknowledgement a)
readList :: ReadS [Acknowledgement a]
$creadList :: forall a. Read a => ReadS [Acknowledgement a]
readsPrec :: Int -> ReadS (Acknowledgement a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Acknowledgement a)
Read, Int -> Acknowledgement a -> ShowS
[Acknowledgement a] -> ShowS
Acknowledgement a -> String
(Int -> Acknowledgement a -> ShowS)
-> (Acknowledgement a -> String)
-> ([Acknowledgement a] -> ShowS)
-> Show (Acknowledgement a)
forall a. Show a => Int -> Acknowledgement a -> ShowS
forall a. Show a => [Acknowledgement a] -> ShowS
forall a. Show a => Acknowledgement a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Acknowledgement a] -> ShowS
$cshowList :: forall a. Show a => [Acknowledgement a] -> ShowS
show :: Acknowledgement a -> String
$cshow :: forall a. Show a => Acknowledgement a -> String
showsPrec :: Int -> Acknowledgement a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Acknowledgement a -> ShowS
Show)
data ReplyData
= RequestSPI (Acknowledgement (Word32, Word8, BS.ByteString))
| SetHomeLight (Acknowledgement ())
| SetInertialMeasurement (Acknowledgement ())
| SetInputMode (Acknowledgement ())
| SetPlayerLights (Acknowledgement ())
| SetVibration (Acknowledgement ())
| UnknownCommand Word8 Word8
deriving (ReplyData -> ReplyData -> Bool
(ReplyData -> ReplyData -> Bool)
-> (ReplyData -> ReplyData -> Bool) -> Eq ReplyData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReplyData -> ReplyData -> Bool
$c/= :: ReplyData -> ReplyData -> Bool
== :: ReplyData -> ReplyData -> Bool
$c== :: ReplyData -> ReplyData -> Bool
Eq, ReadPrec [ReplyData]
ReadPrec ReplyData
Int -> ReadS ReplyData
ReadS [ReplyData]
(Int -> ReadS ReplyData)
-> ReadS [ReplyData]
-> ReadPrec ReplyData
-> ReadPrec [ReplyData]
-> Read ReplyData
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReplyData]
$creadListPrec :: ReadPrec [ReplyData]
readPrec :: ReadPrec ReplyData
$creadPrec :: ReadPrec ReplyData
readList :: ReadS [ReplyData]
$creadList :: ReadS [ReplyData]
readsPrec :: Int -> ReadS ReplyData
$creadsPrec :: Int -> ReadS ReplyData
Read, Int -> ReplyData -> ShowS
[ReplyData] -> ShowS
ReplyData -> String
(Int -> ReplyData -> ShowS)
-> (ReplyData -> String)
-> ([ReplyData] -> ShowS)
-> Show ReplyData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReplyData] -> ShowS
$cshowList :: [ReplyData] -> ShowS
show :: ReplyData -> String
$cshow :: ReplyData -> String
showsPrec :: Int -> ReplyData -> ShowS
$cshowsPrec :: Int -> ReplyData -> ShowS
Show)
data StickDirection a
= Discrete Direction
| Analog a a
deriving (StickDirection a -> StickDirection a -> Bool
(StickDirection a -> StickDirection a -> Bool)
-> (StickDirection a -> StickDirection a -> Bool)
-> Eq (StickDirection a)
forall a. Eq a => StickDirection a -> StickDirection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StickDirection a -> StickDirection a -> Bool
$c/= :: forall a. Eq a => StickDirection a -> StickDirection a -> Bool
== :: StickDirection a -> StickDirection a -> Bool
$c== :: forall a. Eq a => StickDirection a -> StickDirection a -> Bool
Eq, a -> StickDirection b -> StickDirection a
(a -> b) -> StickDirection a -> StickDirection b
(forall a b. (a -> b) -> StickDirection a -> StickDirection b)
-> (forall a b. a -> StickDirection b -> StickDirection a)
-> Functor StickDirection
forall a b. a -> StickDirection b -> StickDirection a
forall a b. (a -> b) -> StickDirection a -> StickDirection b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> StickDirection b -> StickDirection a
$c<$ :: forall a b. a -> StickDirection b -> StickDirection a
fmap :: (a -> b) -> StickDirection a -> StickDirection b
$cfmap :: forall a b. (a -> b) -> StickDirection a -> StickDirection b
Functor, ReadPrec [StickDirection a]
ReadPrec (StickDirection a)
Int -> ReadS (StickDirection a)
ReadS [StickDirection a]
(Int -> ReadS (StickDirection a))
-> ReadS [StickDirection a]
-> ReadPrec (StickDirection a)
-> ReadPrec [StickDirection a]
-> Read (StickDirection a)
forall a. Read a => ReadPrec [StickDirection a]
forall a. Read a => ReadPrec (StickDirection a)
forall a. Read a => Int -> ReadS (StickDirection a)
forall a. Read a => ReadS [StickDirection a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StickDirection a]
$creadListPrec :: forall a. Read a => ReadPrec [StickDirection a]
readPrec :: ReadPrec (StickDirection a)
$creadPrec :: forall a. Read a => ReadPrec (StickDirection a)
readList :: ReadS [StickDirection a]
$creadList :: forall a. Read a => ReadS [StickDirection a]
readsPrec :: Int -> ReadS (StickDirection a)
$creadsPrec :: forall a. Read a => Int -> ReadS (StickDirection a)
Read, Int -> StickDirection a -> ShowS
[StickDirection a] -> ShowS
StickDirection a -> String
(Int -> StickDirection a -> ShowS)
-> (StickDirection a -> String)
-> ([StickDirection a] -> ShowS)
-> Show (StickDirection a)
forall a. Show a => Int -> StickDirection a -> ShowS
forall a. Show a => [StickDirection a] -> ShowS
forall a. Show a => StickDirection a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StickDirection a] -> ShowS
$cshowList :: forall a. Show a => [StickDirection a] -> ShowS
show :: StickDirection a -> String
$cshow :: forall a. Show a => StickDirection a -> String
showsPrec :: Int -> StickDirection a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> StickDirection a -> ShowS
Show)
data Direction
= None
| Left
| Up
| Right
| Down
| LeftUp
| LeftDown
| RightUp
| RightDown
deriving (Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, ReadPrec [Direction]
ReadPrec Direction
Int -> ReadS Direction
ReadS [Direction]
(Int -> ReadS Direction)
-> ReadS [Direction]
-> ReadPrec Direction
-> ReadPrec [Direction]
-> Read Direction
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Direction]
$creadListPrec :: ReadPrec [Direction]
readPrec :: ReadPrec Direction
$creadPrec :: ReadPrec Direction
readList :: ReadS [Direction]
$creadList :: ReadS [Direction]
readsPrec :: Int -> ReadS Direction
$creadsPrec :: Int -> ReadS Direction
Read, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show)
coordinates :: StickDirection Float -> (Float, Float)
coordinates :: StickDirection Float -> (Float, Float)
coordinates (Analog Float
x Float
y) = (Float
x, Float
y)
coordinates (Discrete Direction
dir) =
case Direction
dir of
Direction
None -> ( Float
0, Float
0)
Direction
Left -> ( Float
left, Float
0)
Direction
Up -> ( Float
0, Float
up)
Direction
Right -> (Float
right, Float
0)
Direction
Down -> ( Float
0, Float
down)
Direction
LeftUp -> ( Float
left, Float
up)
Direction
LeftDown -> ( Float
left, Float
down)
Direction
RightUp -> (Float
right, Float
up)
Direction
RightDown -> (Float
right, Float
down)
where
right :: Float
right = Float -> Float
forall a. Floating a => a -> a
cos (Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
4)
left :: Float
left = -Float
right
up :: Float
up = Float -> Float
forall a. Floating a => a -> a
sin (Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
4)
down :: Float
down = -Float
up
mergeInputs
:: Input
-> Input
-> Input
mergeInputs :: Input -> Input -> Input
mergeInputs Input
leftInput Input
rightInput =
Input
leftInput
{ btnR :: Bool
btnR = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnR Input
rightInput
, btnZR :: Bool
btnZR = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnZR Input
rightInput
, btnPlus :: Bool
btnPlus = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnPlus Input
rightInput
, btnX :: Bool
btnX = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnX Input
rightInput
, btnY :: Bool
btnY = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnY Input
rightInput
, btnA :: Bool
btnA = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnA Input
rightInput
, btnB :: Bool
btnB = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnB Input
rightInput
, btnRightStick :: Bool
btnRightStick = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnRightStick Input
rightInput
, btnHome :: Bool
btnHome = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnHome Input
rightInput
, btnRightSL :: Bool
btnRightSL = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnRightSL Input
rightInput
, btnRightSR :: Bool
btnRightSR = Input -> Bool
forall s e. ControllerInput s e -> Bool
btnRightSR Input
rightInput
, stickRight :: StickDirection Float
stickRight = Input -> StickDirection Float
forall s e. ControllerInput s e -> StickDirection s
stickRight Input
rightInput
, extras :: ExtraInput Float
extras = ExtraInput Float
forall a. ExtraInput a
Unavailable
, battery :: Maybe BatteryInfo
battery = Maybe BatteryInfo
forall a. Maybe a
Nothing
}
data BatteryStatus
= Empty
| Low
| Medium
| Good
| Full
deriving (BatteryStatus -> BatteryStatus -> Bool
(BatteryStatus -> BatteryStatus -> Bool)
-> (BatteryStatus -> BatteryStatus -> Bool) -> Eq BatteryStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BatteryStatus -> BatteryStatus -> Bool
$c/= :: BatteryStatus -> BatteryStatus -> Bool
== :: BatteryStatus -> BatteryStatus -> Bool
$c== :: BatteryStatus -> BatteryStatus -> Bool
Eq, Eq BatteryStatus
Eq BatteryStatus
-> (BatteryStatus -> BatteryStatus -> Ordering)
-> (BatteryStatus -> BatteryStatus -> Bool)
-> (BatteryStatus -> BatteryStatus -> Bool)
-> (BatteryStatus -> BatteryStatus -> Bool)
-> (BatteryStatus -> BatteryStatus -> Bool)
-> (BatteryStatus -> BatteryStatus -> BatteryStatus)
-> (BatteryStatus -> BatteryStatus -> BatteryStatus)
-> Ord BatteryStatus
BatteryStatus -> BatteryStatus -> Bool
BatteryStatus -> BatteryStatus -> Ordering
BatteryStatus -> BatteryStatus -> BatteryStatus
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 :: BatteryStatus -> BatteryStatus -> BatteryStatus
$cmin :: BatteryStatus -> BatteryStatus -> BatteryStatus
max :: BatteryStatus -> BatteryStatus -> BatteryStatus
$cmax :: BatteryStatus -> BatteryStatus -> BatteryStatus
>= :: BatteryStatus -> BatteryStatus -> Bool
$c>= :: BatteryStatus -> BatteryStatus -> Bool
> :: BatteryStatus -> BatteryStatus -> Bool
$c> :: BatteryStatus -> BatteryStatus -> Bool
<= :: BatteryStatus -> BatteryStatus -> Bool
$c<= :: BatteryStatus -> BatteryStatus -> Bool
< :: BatteryStatus -> BatteryStatus -> Bool
$c< :: BatteryStatus -> BatteryStatus -> Bool
compare :: BatteryStatus -> BatteryStatus -> Ordering
$ccompare :: BatteryStatus -> BatteryStatus -> Ordering
$cp1Ord :: Eq BatteryStatus
Ord, ReadPrec [BatteryStatus]
ReadPrec BatteryStatus
Int -> ReadS BatteryStatus
ReadS [BatteryStatus]
(Int -> ReadS BatteryStatus)
-> ReadS [BatteryStatus]
-> ReadPrec BatteryStatus
-> ReadPrec [BatteryStatus]
-> Read BatteryStatus
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BatteryStatus]
$creadListPrec :: ReadPrec [BatteryStatus]
readPrec :: ReadPrec BatteryStatus
$creadPrec :: ReadPrec BatteryStatus
readList :: ReadS [BatteryStatus]
$creadList :: ReadS [BatteryStatus]
readsPrec :: Int -> ReadS BatteryStatus
$creadsPrec :: Int -> ReadS BatteryStatus
Read, Int -> BatteryStatus -> ShowS
[BatteryStatus] -> ShowS
BatteryStatus -> String
(Int -> BatteryStatus -> ShowS)
-> (BatteryStatus -> String)
-> ([BatteryStatus] -> ShowS)
-> Show BatteryStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatteryStatus] -> ShowS
$cshowList :: [BatteryStatus] -> ShowS
show :: BatteryStatus -> String
$cshow :: BatteryStatus -> String
showsPrec :: Int -> BatteryStatus -> ShowS
$cshowsPrec :: Int -> BatteryStatus -> ShowS
Show)
data BatteryInfo =
BatteryInfo
{ BatteryInfo -> BatteryStatus
batteryStatus :: BatteryStatus
, BatteryInfo -> Bool
charging :: Bool
}
deriving (BatteryInfo -> BatteryInfo -> Bool
(BatteryInfo -> BatteryInfo -> Bool)
-> (BatteryInfo -> BatteryInfo -> Bool) -> Eq BatteryInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BatteryInfo -> BatteryInfo -> Bool
$c/= :: BatteryInfo -> BatteryInfo -> Bool
== :: BatteryInfo -> BatteryInfo -> Bool
$c== :: BatteryInfo -> BatteryInfo -> Bool
Eq, ReadPrec [BatteryInfo]
ReadPrec BatteryInfo
Int -> ReadS BatteryInfo
ReadS [BatteryInfo]
(Int -> ReadS BatteryInfo)
-> ReadS [BatteryInfo]
-> ReadPrec BatteryInfo
-> ReadPrec [BatteryInfo]
-> Read BatteryInfo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BatteryInfo]
$creadListPrec :: ReadPrec [BatteryInfo]
readPrec :: ReadPrec BatteryInfo
$creadPrec :: ReadPrec BatteryInfo
readList :: ReadS [BatteryInfo]
$creadList :: ReadS [BatteryInfo]
readsPrec :: Int -> ReadS BatteryInfo
$creadsPrec :: Int -> ReadS BatteryInfo
Read, Int -> BatteryInfo -> ShowS
[BatteryInfo] -> ShowS
BatteryInfo -> String
(Int -> BatteryInfo -> ShowS)
-> (BatteryInfo -> String)
-> ([BatteryInfo] -> ShowS)
-> Show BatteryInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatteryInfo] -> ShowS
$cshowList :: [BatteryInfo] -> ShowS
show :: BatteryInfo -> String
$cshow :: BatteryInfo -> String
showsPrec :: Int -> BatteryInfo -> ShowS
$cshowsPrec :: Int -> BatteryInfo -> ShowS
Show)
adjustSensor
:: ExtraInput Int16
-> (Float, Float, Float)
-> (Float, Float, Float)
-> ExtraInput Float
adjustSensor :: ExtraInput Int16
-> (Float, Float, Float)
-> (Float, Float, Float)
-> ExtraInput Float
adjustSensor ExtraInput Int16
Unavailable (Float, Float, Float)
_ (Float, Float, Float)
_ = ExtraInput Float
forall a. ExtraInput a
Unavailable
adjustSensor (CommandReply ReplyData
r) (Float, Float, Float)
_ (Float, Float, Float)
_ = ReplyData -> ExtraInput Float
forall a. ReplyData -> ExtraInput a
CommandReply ReplyData
r
adjustSensor (Inertial Accelerometer Int16
acc Accelerometer Int16
gyro) (Float, Float, Float)
accs (Float, Float, Float)
gyros =
Accelerometer Float -> Accelerometer Float -> ExtraInput Float
forall a. Accelerometer a -> Accelerometer a -> ExtraInput a
Inertial Accelerometer Float
newAcc Accelerometer Float
newGyro
where facc :: Accelerometer Float
facc = ((Int16, Int16, Int16) -> (Float, Float, Float))
-> Accelerometer Int16 -> Accelerometer Float
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap ((Int16 -> Float) -> (Int16, Int16, Int16) -> (Float, Float, Float)
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap Int16 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Accelerometer Int16
acc
fgyro :: Accelerometer Float
fgyro = ((Int16, Int16, Int16) -> (Float, Float, Float))
-> Accelerometer Int16 -> Accelerometer Float
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap ((Int16 -> Float) -> (Int16, Int16, Int16) -> (Float, Float, Float)
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap Int16 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Accelerometer Int16
gyro
newAcc :: Accelerometer Float
newAcc = ((Float, Float, Float) -> (Float, Float, Float))
-> Accelerometer Float -> Accelerometer Float
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap ((Float -> Float -> Float)
-> (Float, Float, Float)
-> (Float, Float, Float)
-> (Float, Float, Float)
forall a b c. (a -> b -> c) -> (a, a, a) -> (b, b, b) -> (c, c, c)
tripleZipWith Float -> Float -> Float
forall a. Num a => a -> a -> a
(*) (Float, Float, Float)
accs) Accelerometer Float
facc
newGyro :: Accelerometer Float
newGyro = ((Float, Float, Float) -> (Float, Float, Float))
-> Accelerometer Float -> Accelerometer Float
forall a b. (a -> b) -> (a, a, a) -> (b, b, b)
tripleMap ((Float -> Float -> Float)
-> (Float, Float, Float)
-> (Float, Float, Float)
-> (Float, Float, Float)
forall a b c. (a -> b -> c) -> (a, a, a) -> (b, b, b) -> (c, c, c)
tripleZipWith Float -> Float -> Float
forall a. Num a => a -> a -> a
(*) (Float, Float, Float)
gyros) Accelerometer Float
fgyro
readRawInput :: Device -> IO RawInput
readRawInput :: Device -> IO RawInput
readRawInput Device
dev = do
ByteString
response <- Device -> Int -> IO ByteString
read Device
dev Int
362
case Parser RawInput -> ByteString -> Result RawInput
forall a. Parser a -> ByteString -> Result a
parse Parser RawInput
inputParser ByteString
response of
Done ByteString
_ RawInput
raw -> RawInput -> IO RawInput
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawInput
raw
Result RawInput
_ -> InputException -> IO RawInput
forall e a. Exception e => e -> IO a
throwIO (InputException -> IO RawInput) -> InputException -> IO RawInput
forall a b. (a -> b) -> a -> b
$ ByteString -> InputException
UnknownFormatException ByteString
response
getInput :: HasInput t => Controller t -> IO Input
getInput :: Controller t -> IO Input
getInput Controller t
controller =
Controller t -> RawInput -> Input
forall (t :: ControllerType).
HasInput t =>
Controller t -> RawInput -> Input
convert Controller t
controller (RawInput -> Input) -> IO RawInput -> IO Input
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Device -> IO RawInput
readRawInput (Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller)
readRawTimeoutInput :: Int -> Device -> IO (Maybe RawInput)
readRawTimeoutInput :: Int -> Device -> IO (Maybe RawInput)
readRawTimeoutInput Int
timeout Device
dev = do
ByteString
response <- Device -> Int -> Int -> IO ByteString
readTimeout Device
dev Int
362 Int
timeout
if ByteString -> Int
BS.length ByteString
response Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
then Maybe RawInput -> IO (Maybe RawInput)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RawInput
forall a. Maybe a
Nothing
else case Parser RawInput -> ByteString -> Result RawInput
forall a. Parser a -> ByteString -> Result a
parse Parser RawInput
inputParser ByteString
response of
Done ByteString
_ RawInput
raw -> Maybe RawInput -> IO (Maybe RawInput)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RawInput -> IO (Maybe RawInput))
-> Maybe RawInput -> IO (Maybe RawInput)
forall a b. (a -> b) -> a -> b
$ RawInput -> Maybe RawInput
forall a. a -> Maybe a
Just RawInput
raw
Result RawInput
_ -> InputException -> IO (Maybe RawInput)
forall e a. Exception e => e -> IO a
throwIO (InputException -> IO (Maybe RawInput))
-> InputException -> IO (Maybe RawInput)
forall a b. (a -> b) -> a -> b
$ ByteString -> InputException
UnknownFormatException ByteString
response
getTimeoutInput
:: HasInput t
=> Int
-> Controller t
-> IO (Maybe Input)
getTimeoutInput :: Int -> Controller t -> IO (Maybe Input)
getTimeoutInput Int
timeout Controller t
controller =
(RawInput -> Input) -> Maybe RawInput -> Maybe Input
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Controller t -> RawInput -> Input
forall (t :: ControllerType).
HasInput t =>
Controller t -> RawInput -> Input
convert Controller t
controller) (Maybe RawInput -> Maybe Input)
-> IO (Maybe RawInput) -> IO (Maybe Input)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Int -> Device -> IO (Maybe RawInput)
readRawTimeoutInput Int
timeout (Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller)
inputParser :: Parser RawInput
inputParser :: Parser RawInput
inputParser
= Parser RawInput
standardParser
Parser RawInput -> Parser RawInput -> Parser RawInput
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser RawInput
buttonPushParser
Parser RawInput -> Parser RawInput -> Parser RawInput
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser RawInput
commandParser
commandDetailParser :: Parser ReplyData
commandDetailParser :: Parser ReplyData
commandDetailParser
= Parser ReplyData
requestSPIReplyParser
Parser ReplyData -> Parser ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ReplyData
homeLightReplyParser
Parser ReplyData -> Parser ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ReplyData
vibrationReplyParser
Parser ReplyData -> Parser ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ReplyData
inertialReplyParser
Parser ReplyData -> Parser ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ReplyData
inputModeReplyParser
Parser ReplyData -> Parser ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ReplyData
playerLightsReplyParser
Parser ReplyData -> Parser ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ReplyData
unknownCommandParser
ackParser :: Parser Bool
ackParser :: Parser Bool
ackParser = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x80 (Word8 -> Bool) -> Parser ByteString Word8 -> Parser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
toAck :: Bool -> Acknowledgement ()
toAck :: Bool -> Acknowledgement ()
toAck Bool
True = () -> Acknowledgement ()
forall a. a -> Acknowledgement a
ACK ()
toAck Bool
False = Acknowledgement ()
forall a. Acknowledgement a
NACK
requestSPIReplyParser :: Parser ReplyData
requestSPIReplyParser :: Parser ReplyData
requestSPIReplyParser = do
Bool
ack <- Parser Bool
ackParser
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x10
case Bool
ack of
Bool
False -> ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Acknowledgement (Word32, Word8, ByteString) -> ReplyData
RequestSPI Acknowledgement (Word32, Word8, ByteString)
forall a. Acknowledgement a
NACK
Bool
True -> do
Word32
byte0 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32)
-> Parser ByteString Word8 -> Parser ByteString Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word32
byte1 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32)
-> Parser ByteString Word8 -> Parser ByteString Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word32
byte2 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32)
-> Parser ByteString Word8 -> Parser ByteString Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word32
byte3 <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32)
-> Parser ByteString Word8 -> Parser ByteString Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word8
len <- Parser ByteString Word8
anyWord8
ByteString
value <- Int -> Parser ByteString
take (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len)
let addrByte0 :: Word32
addrByte0 = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
byte3 Int
24
addrByte1 :: Word32
addrByte1 = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
byte2 Int
16
addrByte2 :: Word32
addrByte2 = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
byte1 Int
8
addrByte3 :: Word32
addrByte3 = Word32
byte0
address :: Word32
address = Word32
addrByte0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
addrByte1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
addrByte2 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
addrByte3
ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Acknowledgement (Word32, Word8, ByteString) -> ReplyData
RequestSPI ((Word32, Word8, ByteString)
-> Acknowledgement (Word32, Word8, ByteString)
forall a. a -> Acknowledgement a
ACK (Word32
address, Word8
len, ByteString
value))
homeLightReplyParser :: Parser ReplyData
homeLightReplyParser :: Parser ReplyData
homeLightReplyParser = do
Bool
ack <- Parser Bool
ackParser
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x38
ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Acknowledgement () -> ReplyData
SetHomeLight (Bool -> Acknowledgement ()
toAck Bool
ack)
vibrationReplyParser :: Parser ReplyData
vibrationReplyParser :: Parser ReplyData
vibrationReplyParser = do
Bool
ack <- Parser Bool
ackParser
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x48
ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Acknowledgement () -> ReplyData
SetVibration (Bool -> Acknowledgement ()
toAck Bool
ack)
inertialReplyParser :: Parser ReplyData
inertialReplyParser :: Parser ReplyData
inertialReplyParser = do
Bool
ack <- Parser Bool
ackParser
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x40
ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Acknowledgement () -> ReplyData
SetInertialMeasurement (Bool -> Acknowledgement ()
toAck Bool
ack)
inputModeReplyParser :: Parser ReplyData
inputModeReplyParser :: Parser ReplyData
inputModeReplyParser = do
Bool
ack <- Parser Bool
ackParser
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x03
ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Acknowledgement () -> ReplyData
SetInputMode (Bool -> Acknowledgement ()
toAck Bool
ack)
playerLightsReplyParser :: Parser ReplyData
playerLightsReplyParser :: Parser ReplyData
playerLightsReplyParser = do
Bool
ack <- Parser Bool
ackParser
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x30
ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Acknowledgement () -> ReplyData
SetPlayerLights (Bool -> Acknowledgement ()
toAck Bool
ack)
unknownCommandParser :: Parser ReplyData
unknownCommandParser :: Parser ReplyData
unknownCommandParser = do
Word8
byte0 <- Parser ByteString Word8
anyWord8
Word8
byte1 <- Parser ByteString Word8
anyWord8
ReplyData -> Parser ReplyData
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplyData -> Parser ReplyData) -> ReplyData -> Parser ReplyData
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> ReplyData
UnknownCommand Word8
byte0 Word8
byte1
standardParser :: Parser RawInput
standardParser :: Parser RawInput
standardParser = do
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x30
Word8
_ <- Parser ByteString Word8
anyWord8
BatteryInfo
batInfo <- Parser BatteryInfo
batteryParser
RawInput
btnInput <- RawInput -> Parser RawInput
buttonStandardParser RawInput
forall s e. ControllerInput s e
noInput
StickDirection Word16
leftStick <- Parser (StickDirection Word16)
rawStickParser
StickDirection Word16
rightStick <- Parser (StickDirection Word16)
rawStickParser
Word8
_ <- Parser ByteString Word8
anyWord8
(Int16, Int16, Int16)
acc1 <- Parser (Int16, Int16, Int16)
forall a. (Bits a, Num a) => Parser (a, a, a)
tripleParser
(Int16, Int16, Int16)
gyro1 <- Parser (Int16, Int16, Int16)
forall a. (Bits a, Num a) => Parser (a, a, a)
tripleParser
(Int16, Int16, Int16)
acc2 <- Parser (Int16, Int16, Int16)
forall a. (Bits a, Num a) => Parser (a, a, a)
tripleParser
(Int16, Int16, Int16)
gyro2 <- Parser (Int16, Int16, Int16)
forall a. (Bits a, Num a) => Parser (a, a, a)
tripleParser
(Int16, Int16, Int16)
acc3 <- Parser (Int16, Int16, Int16)
forall a. (Bits a, Num a) => Parser (a, a, a)
tripleParser
(Int16, Int16, Int16)
gyro3 <- Parser (Int16, Int16, Int16)
forall a. (Bits a, Num a) => Parser (a, a, a)
tripleParser
RawInput -> Parser RawInput
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawInput -> Parser RawInput) -> RawInput -> Parser RawInput
forall a b. (a -> b) -> a -> b
$
RawInput
btnInput
{ stickLeft :: StickDirection Word16
stickLeft = StickDirection Word16
leftStick
, stickRight :: StickDirection Word16
stickRight = StickDirection Word16
rightStick
, extras :: ExtraInput Int16
extras = Accelerometer Int16 -> Accelerometer Int16 -> ExtraInput Int16
forall a. Accelerometer a -> Accelerometer a -> ExtraInput a
Inertial ((Int16, Int16, Int16)
acc1,(Int16, Int16, Int16)
acc2,(Int16, Int16, Int16)
acc3) ((Int16, Int16, Int16)
gyro1,(Int16, Int16, Int16)
gyro2,(Int16, Int16, Int16)
gyro3)
, battery :: Maybe BatteryInfo
battery = BatteryInfo -> Maybe BatteryInfo
forall a. a -> Maybe a
Just BatteryInfo
batInfo
}
commandParser :: Parser RawInput
commandParser :: Parser RawInput
commandParser = do
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x21
Word8
_ <- Parser ByteString Word8
anyWord8
BatteryInfo
batInfo <- Parser BatteryInfo
batteryParser
RawInput
btnInput <- RawInput -> Parser RawInput
buttonStandardParser RawInput
forall s e. ControllerInput s e
noInput
StickDirection Word16
leftStick <- Parser (StickDirection Word16)
rawStickParser
StickDirection Word16
rightStick <- Parser (StickDirection Word16)
rawStickParser
Word8
_ <- Parser ByteString Word8
anyWord8
ReplyData
cmd <- Parser ReplyData
commandDetailParser
RawInput -> Parser RawInput
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawInput -> Parser RawInput) -> RawInput -> Parser RawInput
forall a b. (a -> b) -> a -> b
$
RawInput
btnInput
{ stickLeft :: StickDirection Word16
stickLeft = StickDirection Word16
leftStick
, stickRight :: StickDirection Word16
stickRight = StickDirection Word16
rightStick
, extras :: ExtraInput Int16
extras = ReplyData -> ExtraInput Int16
forall a. ReplyData -> ExtraInput a
CommandReply ReplyData
cmd
, battery :: Maybe BatteryInfo
battery = BatteryInfo -> Maybe BatteryInfo
forall a. a -> Maybe a
Just BatteryInfo
batInfo
}
buttonPushParser :: Parser RawInput
buttonPushParser :: Parser RawInput
buttonPushParser = do
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x3F
Word8
btnByte1 <- Parser ByteString Word8
anyWord8
Word8
btnByte2 <- Parser ByteString Word8
anyWord8
Word8
stickByte <- Parser ByteString Word8
anyWord8
Maybe (StickDirection Word16, StickDirection Word16)
analogStick <- Parser (Maybe (StickDirection Word16, StickDirection Word16))
analogParser
let down :: Bool
down = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x01 Word8
btnByte1
right :: Bool
right = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x02 Word8
btnByte1
left :: Bool
left = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x04 Word8
btnByte1
up :: Bool
up = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x08 Word8
btnByte1
sl :: Bool
sl = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x10 Word8
btnByte1
sr :: Bool
sr = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x20 Word8
btnByte1
lr :: Bool
lr = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x40 Word8
btnByte2
zlzr :: Bool
zlzr = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x80 Word8
btnByte2
(StickDirection Word16
leftStick, StickDirection Word16
rightStick) =
case Maybe (StickDirection Word16, StickDirection Word16)
analogStick of
Just (StickDirection Word16
l,StickDirection Word16
r) -> (StickDirection Word16
l,StickDirection Word16
r)
Maybe (StickDirection Word16, StickDirection Word16)
Nothing ->
( case Word8
stickByte of
Word8
0x00 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Right
Word8
0x01 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
RightDown
Word8
0x02 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Down
Word8
0x03 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
LeftDown
Word8
0x04 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Left
Word8
0x05 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
LeftUp
Word8
0x06 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Up
Word8
0x07 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
RightUp
Word8
_ -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
None
, case Word8
stickByte of
Word8
0x00 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Left
Word8
0x01 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
LeftUp
Word8
0x02 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Up
Word8
0x03 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
RightUp
Word8
0x04 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Right
Word8
0x05 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
RightDown
Word8
0x06 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
Down
Word8
0x07 -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
LeftDown
Word8
_ -> Direction -> StickDirection Word16
forall a. Direction -> StickDirection a
Discrete Direction
None
)
RawInput -> Parser RawInput
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawInput -> Parser RawInput) -> RawInput -> Parser RawInput
forall a b. (a -> b) -> a -> b
$
Input :: forall s e.
Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> StickDirection s
-> StickDirection s
-> ExtraInput e
-> Maybe BatteryInfo
-> ControllerInput s e
Input
{ btnL :: Bool
btnL = Bool
lr
, btnZL :: Bool
btnZL = Bool
zlzr
, btnMinus :: Bool
btnMinus = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x01 Word8
btnByte2
, btnLeftStick :: Bool
btnLeftStick = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x04 Word8
btnByte2
, btnUp :: Bool
btnUp = Bool
left
, btnLeft :: Bool
btnLeft = Bool
down
, btnRight :: Bool
btnRight = Bool
up
, btnDown :: Bool
btnDown = Bool
right
, btnCapture :: Bool
btnCapture = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x20 Word8
btnByte2
, btnLeftSL :: Bool
btnLeftSL = Bool
sl
, btnLeftSR :: Bool
btnLeftSR = Bool
sr
, btnR :: Bool
btnR = Bool
lr
, btnZR :: Bool
btnZR = Bool
zlzr
, btnPlus :: Bool
btnPlus = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x02 Word8
btnByte2
, btnX :: Bool
btnX = Bool
right
, btnY :: Bool
btnY = Bool
up
, btnA :: Bool
btnA = Bool
down
, btnB :: Bool
btnB = Bool
left
, btnRightStick :: Bool
btnRightStick = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x08 Word8
btnByte2
, btnHome :: Bool
btnHome = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x10 Word8
btnByte2
, btnRightSL :: Bool
btnRightSL = Bool
sl
, btnRightSR :: Bool
btnRightSR = Bool
sr
, stickLeft :: StickDirection Word16
stickLeft = StickDirection Word16
leftStick
, stickRight :: StickDirection Word16
stickRight = StickDirection Word16
rightStick
, extras :: ExtraInput Int16
extras = ExtraInput Int16
forall a. ExtraInput a
Unavailable
, battery :: Maybe BatteryInfo
battery = Maybe BatteryInfo
forall a. Maybe a
Nothing
}
where
analogParser :: Parser (Maybe (StickDirection Word16, StickDirection Word16))
analogParser :: Parser (Maybe (StickDirection Word16, StickDirection Word16))
analogParser = Parser (Maybe (StickDirection Word16, StickDirection Word16))
forall a. Parser ByteString (Maybe a)
fillerParser Parser (Maybe (StickDirection Word16, StickDirection Word16))
-> Parser (Maybe (StickDirection Word16, StickDirection Word16))
-> Parser (Maybe (StickDirection Word16, StickDirection Word16))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Maybe (StickDirection Word16, StickDirection Word16))
proParser
fillerParser :: Parser ByteString (Maybe a)
fillerParser = do
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x00
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x80
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x00
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x80
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x00
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x80
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x00
Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
0x80
Maybe a -> Parser ByteString (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
proParser :: Parser (Maybe (StickDirection Word16, StickDirection Word16))
proParser = do
StickDirection Word16
left <- Parser (StickDirection Word16)
stickBytesParser
StickDirection Word16
right <- Parser (StickDirection Word16)
stickBytesParser
Maybe (StickDirection Word16, StickDirection Word16)
-> Parser (Maybe (StickDirection Word16, StickDirection Word16))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (StickDirection Word16, StickDirection Word16)
-> Parser (Maybe (StickDirection Word16, StickDirection Word16)))
-> Maybe (StickDirection Word16, StickDirection Word16)
-> Parser (Maybe (StickDirection Word16, StickDirection Word16))
forall a b. (a -> b) -> a -> b
$ (StickDirection Word16, StickDirection Word16)
-> Maybe (StickDirection Word16, StickDirection Word16)
forall a. a -> Maybe a
Just (StickDirection Word16
left, StickDirection Word16
right)
stickBytesParser :: Parser (StickDirection Word16)
stickBytesParser = do
Word16
stickByte0 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word16
stickByte1 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word16
stickByte2 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word16
stickByte3 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
StickDirection Word16 -> Parser (StickDirection Word16)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StickDirection Word16 -> Parser (StickDirection Word16))
-> StickDirection Word16 -> Parser (StickDirection Word16)
forall a b. (a -> b) -> a -> b
$
Word16 -> Word16 -> StickDirection Word16
forall a. a -> a -> StickDirection a
Analog
( Word16
stickByte0 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftL Word16
stickByte1 Int
8 )
( Word16
stickByte2 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftL Word16
stickByte3 Int
8 )
batteryParser :: Parser BatteryInfo
batteryParser :: Parser BatteryInfo
batteryParser = do
Word8
batteryByte <- Parser ByteString Word8
anyWord8
BatteryInfo -> Parser BatteryInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BatteryInfo -> Parser BatteryInfo)
-> BatteryInfo -> Parser BatteryInfo
forall a b. (a -> b) -> a -> b
$
BatteryInfo :: BatteryStatus -> Bool -> BatteryInfo
BatteryInfo {
batteryStatus :: BatteryStatus
batteryStatus = Word8 -> BatteryStatus
forall a. (Ord a, Num a) => a -> BatteryStatus
toStatus Word8
batteryByte,
charging :: Bool
charging = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x01 Word8
batteryByte
}
where toStatus :: a -> BatteryStatus
toStatus a
b | a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1 = BatteryStatus
Empty
| a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
3 = BatteryStatus
Low
| a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
5 = BatteryStatus
Medium
| a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
7 = BatteryStatus
Good
| Bool
otherwise = BatteryStatus
Full
buttonStandardParser :: RawInput -> Parser RawInput
buttonStandardParser :: RawInput -> Parser RawInput
buttonStandardParser RawInput
raw = do
Word8
rightByte <- Parser ByteString Word8
anyWord8
Word8
sharedByte <- Parser ByteString Word8
anyWord8
Word8
leftByte <- Parser ByteString Word8
anyWord8
RawInput -> Parser RawInput
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawInput -> Parser RawInput) -> RawInput -> Parser RawInput
forall a b. (a -> b) -> a -> b
$
RawInput
raw
{ btnLeftStick :: Bool
btnLeftStick = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x08 Word8
sharedByte
, btnZL :: Bool
btnZL = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x80 Word8
leftByte
, btnL :: Bool
btnL = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x40 Word8
leftByte
, btnMinus :: Bool
btnMinus = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x01 Word8
sharedByte
, btnUp :: Bool
btnUp = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x02 Word8
leftByte
, btnLeft :: Bool
btnLeft = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x08 Word8
leftByte
, btnRight :: Bool
btnRight = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x04 Word8
leftByte
, btnDown :: Bool
btnDown = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x01 Word8
leftByte
, btnCapture :: Bool
btnCapture = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x20 Word8
sharedByte
, btnLeftSL :: Bool
btnLeftSL = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x20 Word8
leftByte
, btnLeftSR :: Bool
btnLeftSR = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x10 Word8
leftByte
, btnRightStick :: Bool
btnRightStick = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x04 Word8
sharedByte
, btnZR :: Bool
btnZR = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x80 Word8
rightByte
, btnR :: Bool
btnR = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x40 Word8
rightByte
, btnPlus :: Bool
btnPlus = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x02 Word8
sharedByte
, btnX :: Bool
btnX = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x02 Word8
rightByte
, btnY :: Bool
btnY = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x01 Word8
rightByte
, btnA :: Bool
btnA = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x08 Word8
rightByte
, btnB :: Bool
btnB = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x04 Word8
rightByte
, btnHome :: Bool
btnHome = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x10 Word8
sharedByte
, btnRightSL :: Bool
btnRightSL = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x20 Word8
rightByte
, btnRightSR :: Bool
btnRightSR = Word8 -> Word8 -> Bool
forall a. (Bits a, Eq a) => a -> a -> Bool
checkMask Word8
0x10 Word8
rightByte
}
rawStickParser :: Parser (StickDirection Word16)
rawStickParser :: Parser (StickDirection Word16)
rawStickParser = do
Word16
byte0 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word16
byte1 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
Word16
byte2 <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16)
-> Parser ByteString Word8 -> Parser ByteString Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
let x :: Word16
x = Word16
byte0 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftL (Word16
byte1 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x0F) Int
8
y :: Word16
y = Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
byte1 Int
4 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftL Word16
byte2 Int
4
StickDirection Word16 -> Parser (StickDirection Word16)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StickDirection Word16 -> Parser (StickDirection Word16))
-> StickDirection Word16 -> Parser (StickDirection Word16)
forall a b. (a -> b) -> a -> b
$ Word16 -> Word16 -> StickDirection Word16
forall a. a -> a -> StickDirection a
Analog Word16
x Word16
y
adjustStick :: StickDirection Word16 -> StickCalibration -> StickDirection Float
adjustStick :: StickDirection Word16 -> StickCalibration -> StickDirection Float
adjustStick (Discrete Direction
dir) StickCalibration
_ = Direction -> StickDirection Float
forall a. Direction -> StickDirection a
Discrete Direction
dir
adjustStick (Analog Word16
x Word16
y) (StickCalibration Float
dc Float
dout Float
mx Float
cx Float
px Float
my Float
cy Float
py) = let
clampX :: Float
clampX = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
mx Float
px (Word16 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x)
clampY :: Float
clampY = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
my Float
py (Word16 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
y)
xf :: Float
xf = if Float
clampX Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
cx
then (Float
clampX Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx)
else (Float
clampX Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cx) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
cx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
mx)
yf :: Float
yf = if Float
clampY Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
cy
then (Float
clampY Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy)
else (Float
clampY Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
cy) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
cy Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
my)
mag :: Float
mag = Float -> Float
forall a. Floating a => a -> a
sqrt (Float
xf Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
xf Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
yf Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
yf)
legalRange :: Float
legalRange = Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dout Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dc
normMag :: Float
normMag = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
1 ((Float
mag Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dc) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
legalRange)
scale :: Float
scale = Float
normMag Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
mag
in if Float
mag Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
dc
then Float -> Float -> StickDirection Float
forall a. a -> a -> StickDirection a
Analog (Float
xf Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale) (Float
yf Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scale)
else Float -> Float -> StickDirection Float
forall a. a -> a -> StickDirection a
Analog Float
0 Float
0
withRawSPIData :: Device -> IORef Word8 -> Word32 -> Word8 -> (BS.ByteString -> a) -> IO a
withRawSPIData :: Device
-> IORef Word8 -> Word32 -> Word8 -> (ByteString -> a) -> IO a
withRawSPIData Device
dev IORef Word8
ref Word32
start Word8
len ByteString -> a
f = do
Device -> IORef Word8 -> Word32 -> Word8 -> IO ()
requestRawSPI Device
dev IORef Word8
ref Word32
start Word8
len
Int -> Int -> Device -> (ReplyData -> Maybe a) -> IO a
forall a. Int -> Int -> Device -> (ReplyData -> Maybe a) -> IO a
withRawCommandReply Int
10 Int
50 Device
dev ((ReplyData -> Maybe a) -> IO a) -> (ReplyData -> Maybe a) -> IO a
forall a b. (a -> b) -> a -> b
$ \case
RequestSPI (ACK (Word32
addr, Word8
rLen, ByteString
value)) | Word32
addr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
start Bool -> Bool -> Bool
&& Word8
rLen Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
len ->
a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
f ByteString
value
ReplyData
_ ->
Maybe a
forall a. Maybe a
Nothing
withRawCommandReply :: Int -> Int -> Device -> (ReplyData -> Maybe a) -> IO a
withRawCommandReply :: Int -> Int -> Device -> (ReplyData -> Maybe a) -> IO a
withRawCommandReply Int
count Int
timeout Device
dev ReplyData -> Maybe a
f = Int -> IO a
loop Int
0
where
cCount :: Int
cCount = Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
0 Int
forall a. Bounded a => a
maxBound Int
count
cTimeout :: Int
cTimeout = Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
clamp Int
0 Int
forall a. Bounded a => a
maxBound Int
timeout
loop :: Int -> IO a
loop Int
times
| Int
times Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
cCount = InputException -> IO a
forall e a. Exception e => e -> IO a
throwIO InputException
NoReplyException
| Bool
otherwise = do
Maybe RawInput
input <- Int -> Device -> IO (Maybe RawInput)
readRawTimeoutInput Int
cTimeout Device
dev
case Maybe RawInput
input of
Just (Input { extras :: forall s e. ControllerInput s e -> ExtraInput e
extras = CommandReply ReplyData
obj }) ->
case ReplyData -> Maybe a
f ReplyData
obj of
Just a
r -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
Maybe a
Nothing -> Int -> IO a
loop (Int -> Int
forall a. Enum a => a -> a
succ Int
times)
Maybe RawInput
_ -> Int -> IO a
loop (Int -> Int
forall a. Enum a => a -> a
succ Int
times)
withCommandReply
:: Int
-> Int
-> Controller t
-> (ReplyData -> Maybe a)
-> IO a
withCommandReply :: Int -> Int -> Controller t -> (ReplyData -> Maybe a) -> IO a
withCommandReply Int
count Int
timeout Controller t
controller ReplyData -> Maybe a
f =
Int -> Int -> Device -> (ReplyData -> Maybe a) -> IO a
forall a. Int -> Int -> Device -> (ReplyData -> Maybe a) -> IO a
withRawCommandReply Int
count Int
timeout (Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller) ReplyData -> Maybe a
f