{-# LANGUAGE RecordWildCards, LambdaCase #-}
module RetroClash.SerialRx
    ( serialRx
    , serialRxDyn
    , RxState(..)
    , RxBit(..)
    , rxStep
    ) where

import Clash.Prelude
import RetroClash.Utils
import RetroClash.Clock

import Control.Monad (when)
import Control.Monad.State
import Control.Monad.Trans.Writer
import Data.Monoid
import Data.Word

data RxState n
    = RxIdle
    | RxBit Word32 (Maybe Bit) (RxBit n)
    deriving ((forall x. RxState n -> Rep (RxState n) x)
-> (forall x. Rep (RxState n) x -> RxState n)
-> Generic (RxState n)
forall (n :: Nat) x. Rep (RxState n) x -> RxState n
forall (n :: Nat) x. RxState n -> Rep (RxState n) x
forall x. Rep (RxState n) x -> RxState n
forall x. RxState n -> Rep (RxState n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (n :: Nat) x. RxState n -> Rep (RxState n) x
from :: forall x. RxState n -> Rep (RxState n) x
$cto :: forall (n :: Nat) x. Rep (RxState n) x -> RxState n
to :: forall x. Rep (RxState n) x -> RxState n
Generic, RxState n -> RxState n -> Bool
(RxState n -> RxState n -> Bool)
-> (RxState n -> RxState n -> Bool) -> Eq (RxState n)
forall (n :: Nat). KnownNat n => RxState n -> RxState n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (n :: Nat). KnownNat n => RxState n -> RxState n -> Bool
== :: RxState n -> RxState n -> Bool
$c/= :: forall (n :: Nat). KnownNat n => RxState n -> RxState n -> Bool
/= :: RxState n -> RxState n -> Bool
Eq, Int -> RxState n -> ShowS
[RxState n] -> ShowS
RxState n -> String
(Int -> RxState n -> ShowS)
-> (RxState n -> String)
-> ([RxState n] -> ShowS)
-> Show (RxState n)
forall (n :: Nat). KnownNat n => Int -> RxState n -> ShowS
forall (n :: Nat). KnownNat n => [RxState n] -> ShowS
forall (n :: Nat). KnownNat n => RxState n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (n :: Nat). KnownNat n => Int -> RxState n -> ShowS
showsPrec :: Int -> RxState n -> ShowS
$cshow :: forall (n :: Nat). KnownNat n => RxState n -> String
show :: RxState n -> String
$cshowList :: forall (n :: Nat). KnownNat n => [RxState n] -> ShowS
showList :: [RxState n] -> ShowS
Show, HasCallStack => String -> RxState n
RxState n -> Bool
RxState n -> ()
RxState n -> RxState n
(HasCallStack => String -> RxState n)
-> (RxState n -> Bool)
-> (RxState n -> RxState n)
-> (RxState n -> ())
-> NFDataX (RxState n)
forall (n :: Nat).
(KnownNat n, HasCallStack) =>
String -> RxState n
forall (n :: Nat). KnownNat n => RxState n -> Bool
forall (n :: Nat). KnownNat n => RxState n -> ()
forall (n :: Nat). KnownNat n => RxState n -> RxState n
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
$cdeepErrorX :: forall (n :: Nat).
(KnownNat n, HasCallStack) =>
String -> RxState n
deepErrorX :: HasCallStack => String -> RxState n
$chasUndefined :: forall (n :: Nat). KnownNat n => RxState n -> Bool
hasUndefined :: RxState n -> Bool
$censureSpine :: forall (n :: Nat). KnownNat n => RxState n -> RxState n
ensureSpine :: RxState n -> RxState n
$crnfX :: forall (n :: Nat). KnownNat n => RxState n -> ()
rnfX :: RxState n -> ()
NFDataX)

data RxBit n
    = StartBit
    | DataBit (BitVector n) (Index n)
    | StopBit (BitVector n)
    deriving ((forall x. RxBit n -> Rep (RxBit n) x)
-> (forall x. Rep (RxBit n) x -> RxBit n) -> Generic (RxBit n)
forall (n :: Nat) x. Rep (RxBit n) x -> RxBit n
forall (n :: Nat) x. RxBit n -> Rep (RxBit n) x
forall x. Rep (RxBit n) x -> RxBit n
forall x. RxBit n -> Rep (RxBit n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (n :: Nat) x. RxBit n -> Rep (RxBit n) x
from :: forall x. RxBit n -> Rep (RxBit n) x
$cto :: forall (n :: Nat) x. Rep (RxBit n) x -> RxBit n
to :: forall x. Rep (RxBit n) x -> RxBit n
Generic, RxBit n -> RxBit n -> Bool
(RxBit n -> RxBit n -> Bool)
-> (RxBit n -> RxBit n -> Bool) -> Eq (RxBit n)
forall (n :: Nat). KnownNat n => RxBit n -> RxBit n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (n :: Nat). KnownNat n => RxBit n -> RxBit n -> Bool
== :: RxBit n -> RxBit n -> Bool
$c/= :: forall (n :: Nat). KnownNat n => RxBit n -> RxBit n -> Bool
/= :: RxBit n -> RxBit n -> Bool
Eq, Int -> RxBit n -> ShowS
[RxBit n] -> ShowS
RxBit n -> String
(Int -> RxBit n -> ShowS)
-> (RxBit n -> String) -> ([RxBit n] -> ShowS) -> Show (RxBit n)
forall (n :: Nat). KnownNat n => Int -> RxBit n -> ShowS
forall (n :: Nat). KnownNat n => [RxBit n] -> ShowS
forall (n :: Nat). KnownNat n => RxBit n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (n :: Nat). KnownNat n => Int -> RxBit n -> ShowS
showsPrec :: Int -> RxBit n -> ShowS
$cshow :: forall (n :: Nat). KnownNat n => RxBit n -> String
show :: RxBit n -> String
$cshowList :: forall (n :: Nat). KnownNat n => [RxBit n] -> ShowS
showList :: [RxBit n] -> ShowS
Show, HasCallStack => String -> RxBit n
RxBit n -> Bool
RxBit n -> ()
RxBit n -> RxBit n
(HasCallStack => String -> RxBit n)
-> (RxBit n -> Bool)
-> (RxBit n -> RxBit n)
-> (RxBit n -> ())
-> NFDataX (RxBit n)
forall (n :: Nat). (KnownNat n, HasCallStack) => String -> RxBit n
forall (n :: Nat). KnownNat n => RxBit n -> Bool
forall (n :: Nat). KnownNat n => RxBit n -> ()
forall (n :: Nat). KnownNat n => RxBit n -> RxBit n
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
$cdeepErrorX :: forall (n :: Nat). (KnownNat n, HasCallStack) => String -> RxBit n
deepErrorX :: HasCallStack => String -> RxBit n
$chasUndefined :: forall (n :: Nat). KnownNat n => RxBit n -> Bool
hasUndefined :: RxBit n -> Bool
$censureSpine :: forall (n :: Nat). KnownNat n => RxBit n -> RxBit n
ensureSpine :: RxBit n -> RxBit n
$crnfX :: forall (n :: Nat). KnownNat n => RxBit n -> ()
rnfX :: RxBit n -> ()
NFDataX)

rxStep :: (KnownNat n) => Word32 -> Bit -> State (RxState n) (Maybe (BitVector n))
rxStep :: forall (n :: Nat).
KnownNat n =>
Word32 -> Bit -> State (RxState n) (Maybe (BitVector n))
rxStep Word32
bitDuration Bit
input = (Last (BitVector n) -> Maybe (BitVector n))
-> StateT (RxState n) Identity (Last (BitVector n))
-> StateT (RxState n) Identity (Maybe (BitVector n))
forall a b.
(a -> b)
-> StateT (RxState n) Identity a -> StateT (RxState n) Identity b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Last (BitVector n) -> Maybe (BitVector n)
forall a. Last a -> Maybe a
getLast (StateT (RxState n) Identity (Last (BitVector n))
 -> StateT (RxState n) Identity (Maybe (BitVector n)))
-> (WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
    -> StateT (RxState n) Identity (Last (BitVector n)))
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
-> StateT (RxState n) Identity (Maybe (BitVector n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
-> StateT (RxState n) Identity (Last (BitVector n))
forall (m :: Type -> Type) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
 -> StateT (RxState n) Identity (Maybe (BitVector n)))
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
-> StateT (RxState n) Identity (Maybe (BitVector n))
forall a b. (a -> b) -> a -> b
$ WriterT
  (Last (BitVector n)) (StateT (RxState n) Identity) (RxState n)
forall s (m :: Type -> Type). MonadState s m => m s
get WriterT
  (Last (BitVector n)) (StateT (RxState n) Identity) (RxState n)
-> (RxState n
    -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall a b.
WriterT (Last (BitVector n)) (StateT (RxState n) Identity) a
-> (a
    -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) b)
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    RxState n
RxIdle -> do
        Bool
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bit
input Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
low) (WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (RxState n
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Maybe Bit -> RxBit n -> RxState n
forall (n :: Nat). Word32 -> Maybe Bit -> RxBit n -> RxState n
RxBit (Word32
bitDuration1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) Maybe Bit
forall a. Maybe a
Nothing RxBit n
forall (n :: Nat). RxBit n
StartBit
    RxBit Word32
cnt Maybe Bit
sample RxBit n
b | Word32
cnt Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
1 -> do
        RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (RxState n
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Maybe Bit -> RxBit n -> RxState n
forall (n :: Nat). Word32 -> Maybe Bit -> RxBit n -> RxState n
RxBit (Word32
cnt Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) Maybe Bit
sample RxBit n
b
    RxBit Word32
_ Maybe Bit
Nothing RxBit n
b -> do
        Bit
-> RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
consume Bit
input RxBit n
b
    RxBit Word32
_ (Just Bit
sample) RxBit n
rx -> case RxBit n
rx of
        RxBit n
StartBit -> do
            if Bit
sample Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
low then RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
waitFor (BitVector n -> Index n -> RxBit n
forall (n :: Nat). BitVector n -> Index n -> RxBit n
DataBit BitVector n
0 Index n
0) else RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put RxState n
forall (n :: Nat). RxState n
RxIdle
        DataBit BitVector n
xs Index n
i -> do
            let (BitVector n
xs', Bit
_) = Bit -> BitVector n -> (BitVector n, Bit)
forall (n :: Nat).
KnownNat n =>
Bit -> BitVector n -> (BitVector n, Bit)
bvShiftR Bit
sample BitVector n
xs
            RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
waitFor (RxBit n
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ RxBit n -> (Index n -> RxBit n) -> Maybe (Index n) -> RxBit n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BitVector n -> RxBit n
forall (n :: Nat). BitVector n -> RxBit n
StopBit BitVector n
xs') (BitVector n -> Index n -> RxBit n
forall (n :: Nat). BitVector n -> Index n -> RxBit n
DataBit BitVector n
xs') (Maybe (Index n) -> RxBit n) -> Maybe (Index n) -> RxBit n
forall a b. (a -> b) -> a -> b
$ Index n -> Maybe (Index n)
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
succIdx Index n
i
        StopBit BitVector n
xs -> do
            Bool
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bit
sample Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== Bit
high) (WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ Last (BitVector n)
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell (Last (BitVector n)
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> Last (BitVector n)
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ BitVector n -> Last (BitVector n)
forall a. a -> Last a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure BitVector n
xs
            RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put RxState n
forall (n :: Nat). RxState n
RxIdle
  where
    bitDuration1 :: Word32
bitDuration1 = Word32 -> Word32
forall a. Bits a => a -> a
half Word32
bitDuration
    bitDuration2 :: Word32
bitDuration2 = Word32
bitDuration Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
bitDuration1

    waitFor :: RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
waitFor = RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (RxState n
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> (RxBit n -> RxState n)
-> RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Maybe Bit -> RxBit n -> RxState n
forall (n :: Nat). Word32 -> Maybe Bit -> RxBit n -> RxState n
RxBit Word32
bitDuration1 Maybe Bit
forall a. Maybe a
Nothing
    consume :: Bit
-> RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
consume Bit
input = RxState n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (RxState n
 -> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ())
-> (RxBit n -> RxState n)
-> RxBit n
-> WriterT (Last (BitVector n)) (StateT (RxState n) Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Maybe Bit -> RxBit n -> RxState n
forall (n :: Nat). Word32 -> Maybe Bit -> RxBit n -> RxState n
RxBit Word32
bitDuration2 (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
input)

serialRxDyn
    :: (KnownNat n, HiddenClockResetEnable dom)
    => Signal dom Word32
    -> Signal dom Bit
    -> Signal dom (Maybe (BitVector n))
serialRxDyn :: forall (n :: Nat) (dom :: Symbol).
(KnownNat n, HiddenClockResetEnable dom) =>
Signal dom Word32
-> Signal dom Bit -> Signal dom (Maybe (BitVector n))
serialRxDyn Signal dom Word32
bitDuration Signal dom Bit
input = ((Word32, Bit) -> State (RxState n) (Maybe (BitVector n)))
-> RxState n
-> Unbundled dom (Word32, Bit)
-> Unbundled dom (Maybe (BitVector n))
forall (dom :: Symbol) s i o.
(HiddenClockResetEnable dom, NFDataX s, Bundle i, Bundle o) =>
(i -> State s o) -> s -> Unbundled dom i -> Unbundled dom o
mealyStateB ((Word32 -> Bit -> State (RxState n) (Maybe (BitVector n)))
-> (Word32, Bit) -> State (RxState n) (Maybe (BitVector n))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word32 -> Bit -> State (RxState n) (Maybe (BitVector n))
forall (n :: Nat).
KnownNat n =>
Word32 -> Bit -> State (RxState n) (Maybe (BitVector n))
rxStep) RxState n
forall (n :: Nat). RxState n
RxIdle (Signal dom Word32
bitDuration, Signal dom Bit
input)

serialRx
    :: forall n rate dom. (KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)), HiddenClockResetEnable dom)
    => SNat rate
    -> Signal dom Bit
    -> Signal dom (Maybe (BitVector n))
serialRx :: forall (n :: Nat) (rate :: Nat) (dom :: Symbol).
(KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)),
 HiddenClockResetEnable dom) =>
SNat rate -> Signal dom Bit -> Signal dom (Maybe (BitVector n))
serialRx SNat rate
rate = Signal dom Word32
-> Signal dom Bit -> Signal dom (Maybe (BitVector n))
forall (n :: Nat) (dom :: Symbol).
(KnownNat n, HiddenClockResetEnable dom) =>
Signal dom Word32
-> Signal dom Bit -> Signal dom (Maybe (BitVector n))
serialRxDyn (Signal dom Word32
 -> Signal dom Bit -> Signal dom (Maybe (BitVector n)))
-> Signal dom Word32
-> Signal dom Bit
-> Signal dom (Maybe (BitVector n))
forall a b. (a -> b) -> a -> b
$ Word32 -> Signal dom Word32
forall a. a -> Signal dom a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Word32
bitDuration
  where
    bitDuration :: Word32
bitDuration = Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32)
-> (SNat (ClockDivider dom (HzToPeriod rate)) -> Integer)
-> SNat (ClockDivider dom (HzToPeriod rate))
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SNat
  (Div
     (Div (Picoseconds 1000000000000) rate)
     (DomainConfigurationPeriod (KnownConf dom)))
-> Integer
SNat (ClockDivider dom (HzToPeriod rate)) -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (SNat (ClockDivider dom (HzToPeriod rate)) -> Word32)
-> SNat (ClockDivider dom (HzToPeriod rate)) -> Word32
forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => SNat n
SNat @(ClockDivider dom (HzToPeriod rate))