{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Device.Nintendo.Switch.Connection where
import Data.Attoparsec.ByteString (Parser, maybeResult, parse)
import Control.Exception (Exception, bracket, throwIO)
import Data.IORef (newIORef)
import Prelude hiding (init)
import Data.ByteString (ByteString)
import Device.Nintendo.Switch.Controller (Controller(..), ControllerType(..),
HasCalibration(..), RawCalibration(..),
axisCalibrationParser, stickFactoryParser,
parseStickUserCalibration, axisUserParser)
import Device.Nintendo.Switch.Input (Acknowledgement(ACK), ReplyData(SetInputMode),
withCommandReply, withRawSPIData)
import Device.Nintendo.Switch.Output (InputMode(Standard), setInputModeInternal)
import qualified System.HIDAPI as HID
data Console = Console
deriving (Console -> Console -> Bool
(Console -> Console -> Bool)
-> (Console -> Console -> Bool) -> Eq Console
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Console -> Console -> Bool
$c/= :: Console -> Console -> Bool
== :: Console -> Console -> Bool
$c== :: Console -> Console -> Bool
Eq, Eq Console
Eq Console
-> (Console -> Console -> Ordering)
-> (Console -> Console -> Bool)
-> (Console -> Console -> Bool)
-> (Console -> Console -> Bool)
-> (Console -> Console -> Bool)
-> (Console -> Console -> Console)
-> (Console -> Console -> Console)
-> Ord Console
Console -> Console -> Bool
Console -> Console -> Ordering
Console -> Console -> Console
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 :: Console -> Console -> Console
$cmin :: Console -> Console -> Console
max :: Console -> Console -> Console
$cmax :: Console -> Console -> Console
>= :: Console -> Console -> Bool
$c>= :: Console -> Console -> Bool
> :: Console -> Console -> Bool
$c> :: Console -> Console -> Bool
<= :: Console -> Console -> Bool
$c<= :: Console -> Console -> Bool
< :: Console -> Console -> Bool
$c< :: Console -> Console -> Bool
compare :: Console -> Console -> Ordering
$ccompare :: Console -> Console -> Ordering
$cp1Ord :: Eq Console
Ord, ReadPrec [Console]
ReadPrec Console
Int -> ReadS Console
ReadS [Console]
(Int -> ReadS Console)
-> ReadS [Console]
-> ReadPrec Console
-> ReadPrec [Console]
-> Read Console
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Console]
$creadListPrec :: ReadPrec [Console]
readPrec :: ReadPrec Console
$creadPrec :: ReadPrec Console
readList :: ReadS [Console]
$creadList :: ReadS [Console]
readsPrec :: Int -> ReadS Console
$creadsPrec :: Int -> ReadS Console
Read, Int -> Console -> ShowS
[Console] -> ShowS
Console -> String
(Int -> Console -> ShowS)
-> (Console -> String) -> ([Console] -> ShowS) -> Show Console
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Console] -> ShowS
$cshowList :: [Console] -> ShowS
show :: Console -> String
$cshow :: Console -> String
showsPrec :: Int -> Console -> ShowS
$cshowsPrec :: Int -> Console -> ShowS
Show)
init :: IO Console
init :: IO Console
init = IO ()
HID.init IO () -> IO Console -> IO Console
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Console -> IO Console
forall (f :: * -> *) a. Applicative f => a -> f a
pure Console
Console
exit :: Console -> IO ()
exit :: Console -> IO ()
exit Console
Console = IO ()
HID.exit
withConsole :: (Console -> IO a) -> IO a
withConsole :: (Console -> IO a) -> IO a
withConsole = IO Console -> (Console -> IO ()) -> (Console -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Console
init Console -> IO ()
exit
newtype ControllerInfo (t :: ControllerType) =
ControllerInfo HID.DeviceInfo
deriving Int -> ControllerInfo t -> ShowS
[ControllerInfo t] -> ShowS
ControllerInfo t -> String
(Int -> ControllerInfo t -> ShowS)
-> (ControllerInfo t -> String)
-> ([ControllerInfo t] -> ShowS)
-> Show (ControllerInfo t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (t :: ControllerType). Int -> ControllerInfo t -> ShowS
forall (t :: ControllerType). [ControllerInfo t] -> ShowS
forall (t :: ControllerType). ControllerInfo t -> String
showList :: [ControllerInfo t] -> ShowS
$cshowList :: forall (t :: ControllerType). [ControllerInfo t] -> ShowS
show :: ControllerInfo t -> String
$cshow :: forall (t :: ControllerType). ControllerInfo t -> String
showsPrec :: Int -> ControllerInfo t -> ShowS
$cshowsPrec :: forall (t :: ControllerType). Int -> ControllerInfo t -> ShowS
Show
class IsController (t :: ControllerType) where
productID :: HID.ProductID
vendorID :: HID.VendorID
vendorID = VendorID
0x057E
instance IsController 'LeftJoyCon where
productID :: VendorID
productID = VendorID
0x2006
instance IsController 'RightJoyCon where
productID :: VendorID
productID = VendorID
0x2007
instance IsController 'ProController where
productID :: VendorID
productID = VendorID
0x2009
data ConnectionException
= NoFactoryStickException
| NoFactoryAxisException
deriving ConnectionException -> ConnectionException -> Bool
(ConnectionException -> ConnectionException -> Bool)
-> (ConnectionException -> ConnectionException -> Bool)
-> Eq ConnectionException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionException -> ConnectionException -> Bool
$c/= :: ConnectionException -> ConnectionException -> Bool
== :: ConnectionException -> ConnectionException -> Bool
$c== :: ConnectionException -> ConnectionException -> Bool
Eq
instance Exception ConnectionException
instance Show ConnectionException where
show :: ConnectionException -> String
show ConnectionException
NoFactoryStickException = String
"Could not determine the factory stick calibration."
show ConnectionException
NoFactoryAxisException = String
"Could not determine the factory sensor calibration."
connect
:: forall t . HasCalibration t
=> ControllerInfo t
-> IO (Controller t)
connect :: ControllerInfo t -> IO (Controller t)
connect (ControllerInfo DeviceInfo
devInfo) = do
Device
dev <- DeviceInfo -> IO Device
HID.openDeviceInfo DeviceInfo
devInfo
IORef Word8
ref <- Word8 -> IO (IORef Word8)
forall a. a -> IO (IORef a)
newIORef Word8
0
Maybe (RawStickCalibration, RawStickCalibration)
facStick <- Device
-> IORef Word8
-> Word32
-> Word8
-> (ByteString -> Maybe (RawStickCalibration, RawStickCalibration))
-> IO (Maybe (RawStickCalibration, RawStickCalibration))
forall a.
Device
-> IORef Word8 -> Word32 -> Word8 -> (ByteString -> a) -> IO a
withRawSPIData Device
dev IORef Word8
ref Word32
0x603D Word8
18 (Parser (RawStickCalibration, RawStickCalibration)
-> ByteString -> Maybe (RawStickCalibration, RawStickCalibration)
forall a. Parser a -> ByteString -> Maybe a
tryParse Parser (RawStickCalibration, RawStickCalibration)
stickFactoryParser)
Maybe RawSensorCalibration
facAxis <- Device
-> IORef Word8
-> Word32
-> Word8
-> (ByteString -> Maybe RawSensorCalibration)
-> IO (Maybe RawSensorCalibration)
forall a.
Device
-> IORef Word8 -> Word32 -> Word8 -> (ByteString -> a) -> IO a
withRawSPIData Device
dev IORef Word8
ref Word32
0x6020 Word8
24 (Parser RawSensorCalibration
-> ByteString -> Maybe RawSensorCalibration
forall a. Parser a -> ByteString -> Maybe a
tryParse Parser RawSensorCalibration
axisCalibrationParser)
(Maybe RawStickCalibration
usl,Maybe RawStickCalibration
usr) <- Device
-> IORef Word8
-> Word32
-> Word8
-> (ByteString
-> (Maybe RawStickCalibration, Maybe RawStickCalibration))
-> IO (Maybe RawStickCalibration, Maybe RawStickCalibration)
forall a.
Device
-> IORef Word8 -> Word32 -> Word8 -> (ByteString -> a) -> IO a
withRawSPIData Device
dev IORef Word8
ref Word32
0x8010 Word8
22 ByteString
-> (Maybe RawStickCalibration, Maybe RawStickCalibration)
parseStickUserCalibration
Maybe RawSensorCalibration
usrAxis <- Device
-> IORef Word8
-> Word32
-> Word8
-> (ByteString -> Maybe RawSensorCalibration)
-> IO (Maybe RawSensorCalibration)
forall a.
Device
-> IORef Word8 -> Word32 -> Word8 -> (ByteString -> a) -> IO a
withRawSPIData Device
dev IORef Word8
ref Word32
0x8026 Word8
26 (Parser RawSensorCalibration
-> ByteString -> Maybe RawSensorCalibration
forall a. Parser a -> ByteString -> Maybe a
tryParse Parser RawSensorCalibration
axisUserParser)
Controller t
controller <-
case (Maybe (RawStickCalibration, RawStickCalibration)
facStick, Maybe RawSensorCalibration
facAxis) of
(Maybe (RawStickCalibration, RawStickCalibration)
Nothing, Maybe RawSensorCalibration
_) -> ConnectionException -> IO (Controller t)
forall e a. Exception e => e -> IO a
throwIO ConnectionException
NoFactoryStickException
(Maybe (RawStickCalibration, RawStickCalibration)
_, Maybe RawSensorCalibration
Nothing) -> ConnectionException -> IO (Controller t)
forall e a. Exception e => e -> IO a
throwIO ConnectionException
NoFactoryAxisException
(Just (RawStickCalibration
fsl,RawStickCalibration
fsr), Just RawSensorCalibration
sensor) ->
let ls :: RawStickCalibration
ls = RawStickCalibration
-> (RawStickCalibration -> RawStickCalibration)
-> Maybe RawStickCalibration
-> RawStickCalibration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawStickCalibration
fsl RawStickCalibration -> RawStickCalibration
forall a. a -> a
id Maybe RawStickCalibration
usl
rs :: RawStickCalibration
rs = RawStickCalibration
-> (RawStickCalibration -> RawStickCalibration)
-> Maybe RawStickCalibration
-> RawStickCalibration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawStickCalibration
fsr RawStickCalibration -> RawStickCalibration
forall a. a -> a
id Maybe RawStickCalibration
usr
ax :: RawSensorCalibration
ax = RawSensorCalibration
-> (RawSensorCalibration -> RawSensorCalibration)
-> Maybe RawSensorCalibration
-> RawSensorCalibration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawSensorCalibration
sensor RawSensorCalibration -> RawSensorCalibration
forall a. a -> a
id Maybe RawSensorCalibration
usrAxis
cal :: Calibration
cal = RawCalibration -> Calibration
forall (t :: ControllerType).
HasCalibration t =>
RawCalibration -> Calibration
calibrate @t (RawStickCalibration
-> RawStickCalibration -> RawSensorCalibration -> RawCalibration
RawCalibration RawStickCalibration
ls RawStickCalibration
rs RawSensorCalibration
ax) in
Controller t -> IO (Controller t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Controller t -> IO (Controller t))
-> Controller t -> IO (Controller t)
forall a b. (a -> b) -> a -> b
$ Device -> IORef Word8 -> Calibration -> Controller t
forall (t :: ControllerType).
Device -> IORef Word8 -> Calibration -> Controller t
Controller Device
dev IORef Word8
ref Calibration
cal
InputMode -> Controller t -> IO ()
forall (t :: ControllerType). InputMode -> Controller t -> IO ()
setInputModeInternal InputMode
Standard Controller t
controller
Int -> Int -> Controller t -> (ReplyData -> Maybe ()) -> IO ()
forall (t :: ControllerType) a.
Int -> Int -> Controller t -> (ReplyData -> Maybe a) -> IO a
withCommandReply Int
10 Int
50 Controller t
controller ((ReplyData -> Maybe ()) -> IO ())
-> (ReplyData -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
SetInputMode (ACK ()) -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
ReplyData
_ -> Maybe ()
forall a. Maybe a
Nothing
Controller t -> IO (Controller t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Controller t
controller
where
tryParse :: Parser a -> ByteString -> Maybe a
tryParse :: Parser a -> ByteString -> Maybe a
tryParse Parser a
parser = Result a -> Maybe a
forall r. Result r -> Maybe r
maybeResult (Result a -> Maybe a)
-> (ByteString -> Result a) -> ByteString -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
parse Parser a
parser
disconnect :: Controller t -> IO ()
disconnect :: Controller t -> IO ()
disconnect = Device -> IO ()
HID.close (Device -> IO ())
-> (Controller t -> Device) -> Controller t -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle
withController :: HasCalibration t => ControllerInfo t -> (Controller t -> IO a) -> IO a
withController :: ControllerInfo t -> (Controller t -> IO a) -> IO a
withController ControllerInfo t
info =
IO (Controller t)
-> (Controller t -> IO ()) -> (Controller t -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
( ControllerInfo t -> IO (Controller t)
forall (t :: ControllerType).
HasCalibration t =>
ControllerInfo t -> IO (Controller t)
connect ControllerInfo t
info )
( Controller t -> IO ()
forall (t :: ControllerType). Controller t -> IO ()
disconnect )
getControllerInfos :: forall t . IsController t => Console -> IO [ControllerInfo t]
getControllerInfos :: Console -> IO [ControllerInfo t]
getControllerInfos Console
Console =
let
vendID :: VendorID
vendID = IsController t => VendorID
forall (t :: ControllerType). IsController t => VendorID
vendorID @t
prodID :: VendorID
prodID = IsController t => VendorID
forall (t :: ControllerType). IsController t => VendorID
productID @t
in do
[DeviceInfo]
devInfos <- Maybe VendorID -> Maybe VendorID -> IO [DeviceInfo]
HID.enumerate (VendorID -> Maybe VendorID
forall a. a -> Maybe a
Just VendorID
vendID) (VendorID -> Maybe VendorID
forall a. a -> Maybe a
Just VendorID
prodID)
[ControllerInfo t] -> IO [ControllerInfo t]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ControllerInfo t] -> IO [ControllerInfo t])
-> [ControllerInfo t] -> IO [ControllerInfo t]
forall a b. (a -> b) -> a -> b
$ DeviceInfo -> ControllerInfo t
forall (t :: ControllerType). DeviceInfo -> ControllerInfo t
ControllerInfo (DeviceInfo -> ControllerInfo t)
-> [DeviceInfo] -> [ControllerInfo t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DeviceInfo]
devInfos