{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
module Device.Nintendo.Switch.Connection where

-- attoparsec

import Data.Attoparsec.ByteString (Parser, maybeResult, parse)

-- base

import Control.Exception (Exception, bracket, throwIO)
import Data.IORef        (newIORef)
import Prelude    hiding (init)

-- bytestring

import Data.ByteString (ByteString)

-- switch

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

-- | A handle which represents a virtual Nintendo Switch console. The handle

-- is used to detect controllers and manage their connections.

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)

-- | Initializes a Nintendo Switch console handle. In other words, it lets us

-- pretend to be Nintendo Switch console in order to detect controllers and manage

-- their connections. You must call this first before doing anything else.

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

-- | Destroys a virtual Nintendo Switch handle. You must call this when you are

-- finished talking to the controllers.

exit :: Console -> IO ()
exit :: Console -> IO ()
exit Console
Console = IO ()
HID.exit

-- | A convenient wrapper around 'init' and '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

-- | A handle which represents an unconnected Nintendo Switch controller.

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

-- | A constraint which indicates that a controller is a valid Nintendo Switch

-- controller that can be detected and connected to.

class IsController (t :: ControllerType) where
  productID :: HID.ProductID
  vendorID  :: HID.VendorID
  vendorID = VendorID
0x057E -- standard: Nintendo


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

-- | A 'ConnectionException' is thrown if something goes wrong when reading the

-- internal data of a Nintendo Switch controller when connecting to it. This

-- should not occur if you have an unmodified controller (i.e., you have not

-- tampered with its internal SPI flash memory).

data ConnectionException
  = NoFactoryStickException -- ^ Indicates that a controller has no factory stick calibration.

  | NoFactoryAxisException  -- ^ Indicates that a controller has no factory sensor calibration.

  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."

-- | Connects to a detected Nintendo Switch controller.

--

-- Can throw a 'ConnectionException' if something is very wrong with your

-- internal controller memory (i.e., if you have tampered with it).

connect
  :: forall t . HasCalibration t
  => ControllerInfo t  -- ^ The detected Nintendo Switch controller.

  -> IO (Controller t) -- ^ The connected Nintendo Switch controller.

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

-- | Disconnects a Nintendo Switch controller. You must not use the controller

-- handle after disconnecting.

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

-- | A convenient wrapper around 'connect' and 'disconnect'.

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 )

-- | Detects all Nintendo Switch controllers of a specific 'ControllerType',

-- usually connected via Bluetooth.

--

-- You may want to use this function with @TypeApplications@ if the controller

-- type cannot be inferred, like:

--

-- @

--     'getControllerInfos' \@''LeftJoyCon' console

-- @

-- 

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