{-# LANGUAGE RecordWildCards, LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}
module RetroClash.PS2
    ( PS2(..)
    , samplePS2

    , decodePS2

    , KeyEvent(..)
    , ScanCode(..)
    , KeyCode(..)
    , parseScanCode

    , keyPress
    , keyState
    ) where

import Clash.Prelude
import Clash.Class.HasDomain
import RetroClash.Utils
import RetroClash.Clock
import Control.Monad (guard, when)
import Control.Monad.State
import Control.Monad.Trans.Writer
import Data.Monoid (Last(..))
import Data.Foldable (traverse_)

data PS2 dom = PS2
    { forall (dom :: Domain). PS2 dom -> "CLK" ::: Signal dom Bit
ps2Clk :: "CLK"   ::: Signal dom Bit
    , forall (dom :: Domain). PS2 dom -> "CLK" ::: Signal dom Bit
ps2Data :: "DATA" ::: Signal dom Bit
    }

type instance HasDomain dom1 (PS2 dom2) = DomEq dom1 dom2
type instance TryDomain t (PS2 dom) = Found dom

samplePS2
    :: forall dom. (HiddenClockResetEnable dom, KnownNat (ClockDivider dom (Microseconds 1)))
    => PS2 dom -> Signal dom (Maybe Bit)
samplePS2 :: forall (dom :: Domain).
(HiddenClockResetEnable dom,
 KnownNat (ClockDivider dom (Microseconds 1))) =>
PS2 dom -> Signal dom (Maybe Bit)
samplePS2 PS2{"DATA" ::: Signal dom Bit
ps2Clk :: forall (dom :: Domain). PS2 dom -> "CLK" ::: Signal dom Bit
ps2Data :: forall (dom :: Domain). PS2 dom -> "CLK" ::: Signal dom Bit
ps2Clk :: "DATA" ::: Signal dom Bit
ps2Data :: "DATA" ::: Signal dom Bit
..} =
    Signal dom Bool
-> ("DATA" ::: Signal dom Bit) -> Signal dom (Maybe Bit)
forall (f :: Type -> Type) a.
Applicative f =>
f Bool -> f a -> f (Maybe a)
enable (Bit -> ("DATA" ::: Signal dom Bit) -> Signal dom Bool
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a, Bounded a, Eq a) =>
a -> Signal dom a -> Signal dom Bool
isFalling Bit
low (("DATA" ::: Signal dom Bit) -> Signal dom Bool)
-> (("DATA" ::: Signal dom Bit) -> "DATA" ::: Signal dom Bit)
-> ("DATA" ::: Signal dom Bit)
-> Signal dom Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("DATA" ::: Signal dom Bit) -> "DATA" ::: Signal dom Bit
lowpass (("DATA" ::: Signal dom Bit) -> Signal dom Bool)
-> ("DATA" ::: Signal dom Bit) -> Signal dom Bool
forall a b. (a -> b) -> a -> b
$ "DATA" ::: Signal dom Bit
ps2Clk) (("DATA" ::: Signal dom Bit) -> "DATA" ::: Signal dom Bit
lowpass "DATA" ::: Signal dom Bit
ps2Data)
  where
    lowpass :: Signal dom Bit -> Signal dom Bit
    lowpass :: ("DATA" ::: Signal dom Bit) -> "DATA" ::: Signal dom Bit
lowpass = SNat (Picoseconds 1000000)
-> Bit -> ("DATA" ::: Signal dom Bit) -> "DATA" ::: Signal dom Bit
forall (ps :: Nat) a (dom :: Domain).
(Eq a, NFDataX a, HiddenClockResetEnable dom,
 KnownNat (ClockDivider dom ps)) =>
SNat ps -> a -> Signal dom a -> Signal dom a
debounce (forall (n :: Nat). KnownNat n => SNat n
SNat @(Microseconds 1)) Bit
low

data PS2State
    = Idle
    | Bit (BitVector 8) (Index 8)
    | Parity (BitVector 8)
    | Stop (Maybe (Unsigned 8))
    deriving (Int -> PS2State -> ShowS
[PS2State] -> ShowS
PS2State -> String
(Int -> PS2State -> ShowS)
-> (PS2State -> String) -> ([PS2State] -> ShowS) -> Show PS2State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PS2State -> ShowS
showsPrec :: Int -> PS2State -> ShowS
$cshow :: PS2State -> String
show :: PS2State -> String
$cshowList :: [PS2State] -> ShowS
showList :: [PS2State] -> ShowS
Show, PS2State -> PS2State -> Bool
(PS2State -> PS2State -> Bool)
-> (PS2State -> PS2State -> Bool) -> Eq PS2State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PS2State -> PS2State -> Bool
== :: PS2State -> PS2State -> Bool
$c/= :: PS2State -> PS2State -> Bool
/= :: PS2State -> PS2State -> Bool
Eq, (forall x. PS2State -> Rep PS2State x)
-> (forall x. Rep PS2State x -> PS2State) -> Generic PS2State
forall x. Rep PS2State x -> PS2State
forall x. PS2State -> Rep PS2State x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PS2State -> Rep PS2State x
from :: forall x. PS2State -> Rep PS2State x
$cto :: forall x. Rep PS2State x -> PS2State
to :: forall x. Rep PS2State x -> PS2State
Generic, HasCallStack => String -> PS2State
PS2State -> Bool
PS2State -> ()
PS2State -> PS2State
(HasCallStack => String -> PS2State)
-> (PS2State -> Bool)
-> (PS2State -> PS2State)
-> (PS2State -> ())
-> NFDataX PS2State
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
$cdeepErrorX :: HasCallStack => String -> PS2State
deepErrorX :: HasCallStack => String -> PS2State
$chasUndefined :: PS2State -> Bool
hasUndefined :: PS2State -> Bool
$censureSpine :: PS2State -> PS2State
ensureSpine :: PS2State -> PS2State
$crnfX :: PS2State -> ()
rnfX :: PS2State -> ()
NFDataX)

decoder :: Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ()
decoder :: Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ()
decoder Bit
x = WriterT (Last (Unsigned 8)) (State PS2State) PS2State
forall s (m :: Type -> Type). MonadState s m => m s
get WriterT (Last (Unsigned 8)) (State PS2State) PS2State
-> (PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall a b.
WriterT (Last (Unsigned 8)) (State PS2State) a
-> (a -> WriterT (Last (Unsigned 8)) (State PS2State) b)
-> WriterT (Last (Unsigned 8)) (State PS2State) b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PS2State
Idle -> do
        Bool
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bit
x Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
low) (WriterT (Last (Unsigned 8)) (State PS2State) ()
 -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall a b. (a -> b) -> a -> b
$ PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall a b. (a -> b) -> a -> b
$ BitVector 8 -> Index 8 -> PS2State
Bit BitVector 8
0 Index 8
0
    Bit BitVector 8
xs Index 8
i -> do
        let (BitVector 8
xs', Bit
_) = Bit -> BitVector 8 -> (BitVector 8, Bit)
forall (n :: Nat).
KnownNat n =>
Bit -> BitVector n -> (BitVector n, Bit)
bvShiftR Bit
x BitVector 8
xs
        PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall a b. (a -> b) -> a -> b
$ PS2State -> (Index 8 -> PS2State) -> Maybe (Index 8) -> PS2State
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BitVector 8 -> PS2State
Parity BitVector 8
xs') (BitVector 8 -> Index 8 -> PS2State
Bit BitVector 8
xs') (Maybe (Index 8) -> PS2State) -> Maybe (Index 8) -> PS2State
forall a b. (a -> b) -> a -> b
$ Index 8 -> Maybe (Index 8)
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
succIdx Index 8
i
    Parity BitVector 8
xs -> do
        PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall a b. (a -> b) -> a -> b
$ Maybe (Unsigned 8) -> PS2State
Stop (Maybe (Unsigned 8) -> PS2State) -> Maybe (Unsigned 8) -> PS2State
forall a b. (a -> b) -> a -> b
$ BitVector (BitSize (Unsigned 8)) -> Unsigned 8
forall a. BitPack a => BitVector (BitSize a) -> a
unpack BitVector 8
BitVector (BitSize (Unsigned 8))
xs Unsigned 8 -> Maybe () -> Maybe (Unsigned 8)
forall a b. a -> Maybe b -> Maybe a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (BitVector 8 -> Bit
forall a (n :: Nat). (BitPack a, BitSize a ~ (n + 1)) => a -> Bit
parity BitVector 8
xs Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
/= Bit
x)
    Stop Maybe (Unsigned 8)
b -> do
        Bool
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bit
x Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
high) (WriterT (Last (Unsigned 8)) (State PS2State) ()
 -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall a b. (a -> b) -> a -> b
$ Last (Unsigned 8)
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell (Last (Unsigned 8)
 -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> (Maybe (Unsigned 8) -> Last (Unsigned 8))
-> Maybe (Unsigned 8)
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Unsigned 8) -> Last (Unsigned 8)
forall a. Maybe a -> Last a
Last (Maybe (Unsigned 8)
 -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> Maybe (Unsigned 8)
-> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall a b. (a -> b) -> a -> b
$ Maybe (Unsigned 8)
b
        PS2State -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put PS2State
Idle

decodePS2
    :: (HiddenClockResetEnable dom)
    => Signal dom (Maybe Bit) -> Signal dom (Maybe (Unsigned 8))
decodePS2 :: forall (dom :: Domain).
HiddenClockResetEnable dom =>
Signal dom (Maybe Bit) -> Signal dom (Maybe (Unsigned 8))
decodePS2 = (Maybe Bit -> State PS2State (Maybe (Unsigned 8)))
-> PS2State
-> Signal dom (Maybe Bit)
-> Signal dom (Maybe (Unsigned 8))
forall (dom :: Domain) s i o.
(HiddenClockResetEnable dom, NFDataX s) =>
(i -> State s o) -> s -> Signal dom i -> Signal dom o
mealyState Maybe Bit -> State PS2State (Maybe (Unsigned 8))
forall {t :: Type -> Type}.
Foldable t =>
t Bit -> State PS2State (Maybe (Unsigned 8))
sampleDecoder PS2State
Idle
  where
    sampleDecoder :: t Bit -> State PS2State (Maybe (Unsigned 8))
sampleDecoder = (Last (Unsigned 8) -> Maybe (Unsigned 8))
-> State PS2State (Last (Unsigned 8))
-> State PS2State (Maybe (Unsigned 8))
forall a b. (a -> b) -> State PS2State a -> State PS2State b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Last (Unsigned 8) -> Maybe (Unsigned 8)
forall a. Last a -> Maybe a
getLast (State PS2State (Last (Unsigned 8))
 -> State PS2State (Maybe (Unsigned 8)))
-> (t Bit -> State PS2State (Last (Unsigned 8)))
-> t Bit
-> State PS2State (Maybe (Unsigned 8))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Last (Unsigned 8)) (State PS2State) ()
-> State PS2State (Last (Unsigned 8))
forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (Last (Unsigned 8)) (State PS2State) ()
 -> State PS2State (Last (Unsigned 8)))
-> (t Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> t Bit
-> State PS2State (Last (Unsigned 8))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ())
-> t Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Bit -> WriterT (Last (Unsigned 8)) (State PS2State) ()
decoder

data KeyEvent = KeyPress | KeyRelease
    deriving ((forall x. KeyEvent -> Rep KeyEvent x)
-> (forall x. Rep KeyEvent x -> KeyEvent) -> Generic KeyEvent
forall x. Rep KeyEvent x -> KeyEvent
forall x. KeyEvent -> Rep KeyEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. KeyEvent -> Rep KeyEvent x
from :: forall x. KeyEvent -> Rep KeyEvent x
$cto :: forall x. Rep KeyEvent x -> KeyEvent
to :: forall x. Rep KeyEvent x -> KeyEvent
Generic, KeyEvent -> KeyEvent -> Bool
(KeyEvent -> KeyEvent -> Bool)
-> (KeyEvent -> KeyEvent -> Bool) -> Eq KeyEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyEvent -> KeyEvent -> Bool
== :: KeyEvent -> KeyEvent -> Bool
$c/= :: KeyEvent -> KeyEvent -> Bool
/= :: KeyEvent -> KeyEvent -> Bool
Eq, Int -> KeyEvent -> ShowS
[KeyEvent] -> ShowS
KeyEvent -> String
(Int -> KeyEvent -> ShowS)
-> (KeyEvent -> String) -> ([KeyEvent] -> ShowS) -> Show KeyEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyEvent -> ShowS
showsPrec :: Int -> KeyEvent -> ShowS
$cshow :: KeyEvent -> String
show :: KeyEvent -> String
$cshowList :: [KeyEvent] -> ShowS
showList :: [KeyEvent] -> ShowS
Show, HasCallStack => String -> KeyEvent
KeyEvent -> Bool
KeyEvent -> ()
KeyEvent -> KeyEvent
(HasCallStack => String -> KeyEvent)
-> (KeyEvent -> Bool)
-> (KeyEvent -> KeyEvent)
-> (KeyEvent -> ())
-> NFDataX KeyEvent
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
$cdeepErrorX :: HasCallStack => String -> KeyEvent
deepErrorX :: HasCallStack => String -> KeyEvent
$chasUndefined :: KeyEvent -> Bool
hasUndefined :: KeyEvent -> Bool
$censureSpine :: KeyEvent -> KeyEvent
ensureSpine :: KeyEvent -> KeyEvent
$crnfX :: KeyEvent -> ()
rnfX :: KeyEvent -> ()
NFDataX)

type KeyCode = Unsigned 9

data ScanCode = ScanCode KeyEvent KeyCode
    deriving ((forall x. ScanCode -> Rep ScanCode x)
-> (forall x. Rep ScanCode x -> ScanCode) -> Generic ScanCode
forall x. Rep ScanCode x -> ScanCode
forall x. ScanCode -> Rep ScanCode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScanCode -> Rep ScanCode x
from :: forall x. ScanCode -> Rep ScanCode x
$cto :: forall x. Rep ScanCode x -> ScanCode
to :: forall x. Rep ScanCode x -> ScanCode
Generic, ScanCode -> ScanCode -> Bool
(ScanCode -> ScanCode -> Bool)
-> (ScanCode -> ScanCode -> Bool) -> Eq ScanCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScanCode -> ScanCode -> Bool
== :: ScanCode -> ScanCode -> Bool
$c/= :: ScanCode -> ScanCode -> Bool
/= :: ScanCode -> ScanCode -> Bool
Eq, Int -> ScanCode -> ShowS
[ScanCode] -> ShowS
ScanCode -> String
(Int -> ScanCode -> ShowS)
-> (ScanCode -> String) -> ([ScanCode] -> ShowS) -> Show ScanCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScanCode -> ShowS
showsPrec :: Int -> ScanCode -> ShowS
$cshow :: ScanCode -> String
show :: ScanCode -> String
$cshowList :: [ScanCode] -> ShowS
showList :: [ScanCode] -> ShowS
Show, HasCallStack => String -> ScanCode
ScanCode -> Bool
ScanCode -> ()
ScanCode -> ScanCode
(HasCallStack => String -> ScanCode)
-> (ScanCode -> Bool)
-> (ScanCode -> ScanCode)
-> (ScanCode -> ())
-> NFDataX ScanCode
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
$cdeepErrorX :: HasCallStack => String -> ScanCode
deepErrorX :: HasCallStack => String -> ScanCode
$chasUndefined :: ScanCode -> Bool
hasUndefined :: ScanCode -> Bool
$censureSpine :: ScanCode -> ScanCode
ensureSpine :: ScanCode -> ScanCode
$crnfX :: ScanCode -> ()
rnfX :: ScanCode -> ()
NFDataX)

data ScanState
    = Init
    | Extended
    | Code KeyEvent Bit
    deriving (Int -> ScanState -> ShowS
[ScanState] -> ShowS
ScanState -> String
(Int -> ScanState -> ShowS)
-> (ScanState -> String)
-> ([ScanState] -> ShowS)
-> Show ScanState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScanState -> ShowS
showsPrec :: Int -> ScanState -> ShowS
$cshow :: ScanState -> String
show :: ScanState -> String
$cshowList :: [ScanState] -> ShowS
showList :: [ScanState] -> ShowS
Show, (forall x. ScanState -> Rep ScanState x)
-> (forall x. Rep ScanState x -> ScanState) -> Generic ScanState
forall x. Rep ScanState x -> ScanState
forall x. ScanState -> Rep ScanState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScanState -> Rep ScanState x
from :: forall x. ScanState -> Rep ScanState x
$cto :: forall x. Rep ScanState x -> ScanState
to :: forall x. Rep ScanState x -> ScanState
Generic, HasCallStack => String -> ScanState
ScanState -> Bool
ScanState -> ()
ScanState -> ScanState
(HasCallStack => String -> ScanState)
-> (ScanState -> Bool)
-> (ScanState -> ScanState)
-> (ScanState -> ())
-> NFDataX ScanState
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
$cdeepErrorX :: HasCallStack => String -> ScanState
deepErrorX :: HasCallStack => String -> ScanState
$chasUndefined :: ScanState -> Bool
hasUndefined :: ScanState -> Bool
$censureSpine :: ScanState -> ScanState
ensureSpine :: ScanState -> ScanState
$crnfX :: ScanState -> ()
rnfX :: ScanState -> ()
NFDataX)

parser :: Unsigned 8 -> WriterT (Last ScanCode) (State ScanState) ()
parser :: Unsigned 8 -> WriterT (Last ScanCode) (State ScanState) ()
parser Unsigned 8
raw = WriterT (Last ScanCode) (State ScanState) ScanState
forall s (m :: Type -> Type). MonadState s m => m s
get WriterT (Last ScanCode) (State ScanState) ScanState
-> (ScanState -> WriterT (Last ScanCode) (State ScanState) ())
-> WriterT (Last ScanCode) (State ScanState) ()
forall a b.
WriterT (Last ScanCode) (State ScanState) a
-> (a -> WriterT (Last ScanCode) (State ScanState) b)
-> WriterT (Last ScanCode) (State ScanState) b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ScanState
Init
        | Unsigned 8
raw Unsigned 8 -> Unsigned 8 -> Bool
forall a. Eq a => a -> a -> Bool
== Unsigned 8
0xe0 -> ScanState -> WriterT (Last ScanCode) (State ScanState) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (ScanState -> WriterT (Last ScanCode) (State ScanState) ())
-> ScanState -> WriterT (Last ScanCode) (State ScanState) ()
forall a b. (a -> b) -> a -> b
$ ScanState
Extended
        | Unsigned 8
raw Unsigned 8 -> Unsigned 8 -> Bool
forall a. Eq a => a -> a -> Bool
== Unsigned 8
0xf0 -> ScanState -> WriterT (Last ScanCode) (State ScanState) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (ScanState -> WriterT (Last ScanCode) (State ScanState) ())
-> ScanState -> WriterT (Last ScanCode) (State ScanState) ()
forall a b. (a -> b) -> a -> b
$ KeyEvent -> Bit -> ScanState
Code KeyEvent
KeyRelease Bit
0
        | Bool
otherwise   -> KeyEvent -> Bit -> WriterT (Last ScanCode) (State ScanState) ()
finish KeyEvent
KeyPress Bit
0
    ScanState
Extended
        | Unsigned 8
raw Unsigned 8 -> Unsigned 8 -> Bool
forall a. Eq a => a -> a -> Bool
== Unsigned 8
0xf0 -> ScanState -> WriterT (Last ScanCode) (State ScanState) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (ScanState -> WriterT (Last ScanCode) (State ScanState) ())
-> ScanState -> WriterT (Last ScanCode) (State ScanState) ()
forall a b. (a -> b) -> a -> b
$ KeyEvent -> Bit -> ScanState
Code KeyEvent
KeyRelease Bit
1
        | Bool
otherwise   -> KeyEvent -> Bit -> WriterT (Last ScanCode) (State ScanState) ()
finish KeyEvent
KeyPress Bit
1
    Code KeyEvent
ev Bit
ext       -> KeyEvent -> Bit -> WriterT (Last ScanCode) (State ScanState) ()
finish KeyEvent
ev Bit
ext
  where
    finish :: KeyEvent -> Bit -> WriterT (Last ScanCode) (State ScanState) ()
finish KeyEvent
ev Bit
ext = do
        Last ScanCode -> WriterT (Last ScanCode) (State ScanState) ()
forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell (Last ScanCode -> WriterT (Last ScanCode) (State ScanState) ())
-> Last ScanCode -> WriterT (Last ScanCode) (State ScanState) ()
forall a b. (a -> b) -> a -> b
$ Maybe ScanCode -> Last ScanCode
forall a. Maybe a -> Last a
Last (Maybe ScanCode -> Last ScanCode)
-> (ScanCode -> Maybe ScanCode) -> ScanCode -> Last ScanCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScanCode -> Maybe ScanCode
forall a. a -> Maybe a
Just (ScanCode -> Last ScanCode) -> ScanCode -> Last ScanCode
forall a b. (a -> b) -> a -> b
$ KeyEvent -> KeyCode -> ScanCode
ScanCode KeyEvent
ev (KeyCode -> ScanCode) -> KeyCode -> ScanCode
forall a b. (a -> b) -> a -> b
$ (Bit, Unsigned 8) -> KeyCode
forall a b. (BitPack a, BitPack b, BitSize a ~ BitSize b) => a -> b
bitCoerce (Bit
ext, Unsigned 8
raw)
        ScanState -> WriterT (Last ScanCode) (State ScanState) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put ScanState
Init

parseScanCode
    :: (HiddenClockResetEnable dom)
    => Signal dom (Maybe (Unsigned 8)) -> Signal dom (Maybe ScanCode)
parseScanCode :: forall (dom :: Domain).
HiddenClockResetEnable dom =>
Signal dom (Maybe (Unsigned 8)) -> Signal dom (Maybe ScanCode)
parseScanCode = (Maybe (Unsigned 8) -> State ScanState (Maybe ScanCode))
-> ScanState
-> Signal dom (Maybe (Unsigned 8))
-> Signal dom (Maybe ScanCode)
forall (dom :: Domain) s i o.
(HiddenClockResetEnable dom, NFDataX s) =>
(i -> State s o) -> s -> Signal dom i -> Signal dom o
mealyState Maybe (Unsigned 8) -> State ScanState (Maybe ScanCode)
forall {t :: Type -> Type}.
Foldable t =>
t (Unsigned 8) -> State ScanState (Maybe ScanCode)
byteParser ScanState
Init
  where
    byteParser :: t (Unsigned 8) -> State ScanState (Maybe ScanCode)
byteParser = (Last ScanCode -> Maybe ScanCode)
-> State ScanState (Last ScanCode)
-> State ScanState (Maybe ScanCode)
forall a b. (a -> b) -> State ScanState a -> State ScanState b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Last ScanCode -> Maybe ScanCode
forall a. Last a -> Maybe a
getLast (State ScanState (Last ScanCode)
 -> State ScanState (Maybe ScanCode))
-> (t (Unsigned 8) -> State ScanState (Last ScanCode))
-> t (Unsigned 8)
-> State ScanState (Maybe ScanCode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Last ScanCode) (State ScanState) ()
-> State ScanState (Last ScanCode)
forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (Last ScanCode) (State ScanState) ()
 -> State ScanState (Last ScanCode))
-> (t (Unsigned 8) -> WriterT (Last ScanCode) (State ScanState) ())
-> t (Unsigned 8)
-> State ScanState (Last ScanCode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unsigned 8 -> WriterT (Last ScanCode) (State ScanState) ())
-> t (Unsigned 8) -> WriterT (Last ScanCode) (State ScanState) ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Unsigned 8 -> WriterT (Last ScanCode) (State ScanState) ()
parser

keyPress :: ScanCode -> Maybe KeyCode
keyPress :: ScanCode -> Maybe KeyCode
keyPress (ScanCode KeyEvent
KeyPress KeyCode
kc) = KeyCode -> Maybe KeyCode
forall a. a -> Maybe a
Just KeyCode
kc
keyPress ScanCode
_ = Maybe KeyCode
forall a. Maybe a
Nothing

keyState
    :: (HiddenClockResetEnable dom)
    => KeyCode
    -> Signal dom (Maybe ScanCode)
    -> Signal dom Bool
keyState :: forall (dom :: Domain).
HiddenClockResetEnable dom =>
KeyCode -> Signal dom (Maybe ScanCode) -> Signal dom Bool
keyState KeyCode
target = Bool -> Signal dom (Maybe Bool) -> Signal dom Bool
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom (Maybe a) -> Signal dom a
regMaybe Bool
False (Signal dom (Maybe Bool) -> Signal dom Bool)
-> (Signal dom (Maybe ScanCode) -> Signal dom (Maybe Bool))
-> Signal dom (Maybe ScanCode)
-> Signal dom Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ScanCode -> Maybe Bool)
-> Signal dom (Maybe ScanCode) -> Signal dom (Maybe Bool)
forall a b. (a -> b) -> Signal dom a -> Signal dom b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ScanCode -> Maybe Bool
fromScanCode
  where
    fromScanCode :: Maybe ScanCode -> Maybe Bool
fromScanCode Maybe ScanCode
sc = do
        ScanCode KeyEvent
ev KeyCode
kc <- Maybe ScanCode
sc
        Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ KeyCode
kc KeyCode -> KeyCode -> Bool
forall a. Eq a => a -> a -> Bool
== KeyCode
target
        Bool -> Maybe Bool
forall a. a -> Maybe a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ KeyEvent
ev KeyEvent -> KeyEvent -> Bool
forall a. Eq a => a -> a -> Bool
== KeyEvent
KeyPress