{-# LANGUAGE RecordWildCards, LambdaCase #-}
module RetroClash.SerialTx
    ( serialTx
    , serialTxDyn
    , fifo
    , TxState(..)
    , TxBit(..)
    , txStep
    ) where

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

import Control.Monad (mplus)
import Control.Monad.State
import Control.Monad.Writer
import Data.Foldable (traverse_)
import Data.Monoid (Any(..))
import Data.Word

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

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

txStep :: forall n. (KnownNat n) => Word32 -> Maybe (BitVector n) -> State (TxState n) (Bit, Bool)
txStep :: forall (n :: Nat).
KnownNat n =>
Word32 -> Maybe (BitVector n) -> State (TxState n) (Bit, Bool)
txStep Word32
bitDuration Maybe (BitVector n)
input = ((Bit, Any) -> (Bit, Bool))
-> StateT (TxState n) Identity (Bit, Any)
-> StateT (TxState n) Identity (Bit, Bool)
forall a b.
(a -> b)
-> StateT (TxState n) Identity a -> StateT (TxState n) Identity b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Any -> Bool) -> (Bit, Any) -> (Bit, Bool)
forall a b. (a -> b) -> (Bit, a) -> (Bit, b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Any -> Bool
getAny) (StateT (TxState n) Identity (Bit, Any)
 -> StateT (TxState n) Identity (Bit, Bool))
-> (WriterT Any (StateT (TxState n) Identity) Bit
    -> StateT (TxState n) Identity (Bit, Any))
-> WriterT Any (StateT (TxState n) Identity) Bit
-> StateT (TxState n) Identity (Bit, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT Any (StateT (TxState n) Identity) Bit
-> StateT (TxState n) Identity (Bit, Any)
forall w (m :: Type -> Type) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Any (StateT (TxState n) Identity) Bit
 -> StateT (TxState n) Identity (Bit, Bool))
-> WriterT Any (StateT (TxState n) Identity) Bit
-> StateT (TxState n) Identity (Bit, Bool)
forall a b. (a -> b) -> a -> b
$ WriterT Any (StateT (TxState n) Identity) (TxState n)
forall s (m :: Type -> Type). MonadState s m => m s
get WriterT Any (StateT (TxState n) Identity) (TxState n)
-> (TxState n -> WriterT Any (StateT (TxState n) Identity) Bit)
-> WriterT Any (StateT (TxState n) Identity) Bit
forall a b.
WriterT Any (StateT (TxState n) Identity) a
-> (a -> WriterT Any (StateT (TxState n) Identity) b)
-> WriterT Any (StateT (TxState n) Identity) b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TxState n
TxIdle -> do
        Any -> WriterT Any (StateT (TxState n) Identity) ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any (StateT (TxState n) Identity) ())
-> Any -> WriterT Any (StateT (TxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
        (BitVector n -> WriterT Any (StateT (TxState n) Identity) ())
-> Maybe (BitVector n)
-> WriterT Any (StateT (TxState n) Identity) ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (TxBit n -> WriterT Any (StateT (TxState n) Identity) ()
goto (TxBit n -> WriterT Any (StateT (TxState n) Identity) ())
-> (BitVector n -> TxBit n)
-> BitVector n
-> WriterT Any (StateT (TxState n) Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitVector n -> TxBit n
forall (n :: Nat). BitVector n -> TxBit n
StartBit) Maybe (BitVector n)
input
        Bit -> WriterT Any (StateT (TxState n) Identity) Bit
forall a. a -> WriterT Any (StateT (TxState n) Identity) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bit
high
    TxBit Word32
cnt TxBit n
tx -> Word32
-> TxBit n
-> WriterT Any (StateT (TxState n) Identity) Bit
-> WriterT Any (StateT (TxState n) Identity) Bit
forall {f :: Type -> Type} {n :: Nat} {a}.
MonadState (TxState n) f =>
Word32 -> TxBit n -> f a -> f a
slowly Word32
cnt TxBit n
tx (WriterT Any (StateT (TxState n) Identity) Bit
 -> WriterT Any (StateT (TxState n) Identity) Bit)
-> WriterT Any (StateT (TxState n) Identity) Bit
-> WriterT Any (StateT (TxState n) Identity) Bit
forall a b. (a -> b) -> a -> b
$ case TxBit n
tx of
        StartBit BitVector n
xs -> do
            TxBit n -> WriterT Any (StateT (TxState n) Identity) ()
goto (TxBit n -> WriterT Any (StateT (TxState n) Identity) ())
-> TxBit n -> WriterT Any (StateT (TxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ BitVector n -> Index n -> TxBit n
forall (n :: Nat). BitVector n -> Index n -> TxBit n
DataBit BitVector n
xs Index n
0
            Bit -> WriterT Any (StateT (TxState n) Identity) Bit
forall a. a -> WriterT Any (StateT (TxState n) Identity) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bit
low
        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
0 BitVector n
xs
            TxBit n -> WriterT Any (StateT (TxState n) Identity) ()
goto (TxBit n -> WriterT Any (StateT (TxState n) Identity) ())
-> TxBit n -> WriterT Any (StateT (TxState n) Identity) ()
forall a b. (a -> b) -> a -> b
$ TxBit n -> (Index n -> TxBit n) -> Maybe (Index n) -> TxBit n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TxBit n
forall (n :: Nat). TxBit n
StopBit (BitVector n -> Index n -> TxBit n
forall (n :: Nat). BitVector n -> Index n -> TxBit n
DataBit BitVector n
xs') (Maybe (Index n) -> TxBit n) -> Maybe (Index n) -> TxBit 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
            Bit -> WriterT Any (StateT (TxState n) Identity) Bit
forall a. a -> WriterT Any (StateT (TxState n) Identity) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bit -> WriterT Any (StateT (TxState n) Identity) Bit)
-> Bit -> WriterT Any (StateT (TxState n) Identity) Bit
forall a b. (a -> b) -> a -> b
$ BitVector n -> Bit
forall a. BitPack a => a -> Bit
lsb BitVector n
xs
        TxBit n
StopBit -> do
            TxState n -> WriterT Any (StateT (TxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put TxState n
forall (n :: Nat). TxState n
TxIdle
            Bit -> WriterT Any (StateT (TxState n) Identity) Bit
forall a. a -> WriterT Any (StateT (TxState n) Identity) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bit
high
  where
    goto :: TxBit n -> WriterT Any (StateT (TxState n) Identity) ()
goto = TxState n -> WriterT Any (StateT (TxState n) Identity) ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (TxState n -> WriterT Any (StateT (TxState n) Identity) ())
-> (TxBit n -> TxState n)
-> TxBit n
-> WriterT Any (StateT (TxState n) Identity) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> TxBit n -> TxState n
forall (n :: Nat). Word32 -> TxBit n -> TxState n
TxBit Word32
bitDuration

    slowly :: Word32 -> TxBit n -> f a -> f a
slowly Word32
cnt TxBit n
tx f a
act
        | Word32
cnt Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
1 = f a
act f a -> f () -> f a
forall a b. f a -> f b -> f a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* TxState n -> f ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put (Word32 -> TxBit n -> TxState n
forall (n :: Nat). Word32 -> TxBit n -> TxState n
TxBit (Word32
cnt Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) TxBit n
tx)
        | Bool
otherwise = f a
act

serialTxDyn
    :: (KnownNat n, HiddenClockResetEnable dom)
    => Signal dom Word32
    -> Signal dom (Maybe (BitVector n))
    -> (Signal dom Bit, Signal dom Bool)
serialTxDyn :: forall (n :: Nat) (dom :: Symbol).
(KnownNat n, HiddenClockResetEnable dom) =>
Signal dom Word32
-> Signal dom (Maybe (BitVector n))
-> (Signal dom Bit, Signal dom Bool)
serialTxDyn Signal dom Word32
bitDuration Signal dom (Maybe (BitVector n))
input = ((Word32, Maybe (BitVector n)) -> State (TxState n) (Bit, Bool))
-> TxState n
-> Unbundled dom (Word32, Maybe (BitVector n))
-> Unbundled dom (Bit, Bool)
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 -> Maybe (BitVector n) -> State (TxState n) (Bit, Bool))
-> (Word32, Maybe (BitVector n)) -> State (TxState n) (Bit, Bool)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word32 -> Maybe (BitVector n) -> State (TxState n) (Bit, Bool)
forall (n :: Nat).
KnownNat n =>
Word32 -> Maybe (BitVector n) -> State (TxState n) (Bit, Bool)
txStep) TxState n
forall (n :: Nat). TxState n
TxIdle (Signal dom Word32
bitDuration, Signal dom (Maybe (BitVector n))
input)

serialTx
    :: forall n rate dom. (KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)), HiddenClockResetEnable dom)
    => SNat rate
    -> Signal dom (Maybe (BitVector n))
    -> (Signal dom Bit, Signal dom Bool)
serialTx :: forall (n :: Nat) (rate :: Nat) (dom :: Symbol).
(KnownNat n, KnownNat (ClockDivider dom (HzToPeriod rate)),
 HiddenClockResetEnable dom) =>
SNat rate
-> Signal dom (Maybe (BitVector n))
-> (Signal dom Bit, Signal dom Bool)
serialTx SNat rate
rate = Signal dom Word32
-> Signal dom (Maybe (BitVector n))
-> (Signal dom Bit, Signal dom Bool)
forall (n :: Nat) (dom :: Symbol).
(KnownNat n, HiddenClockResetEnable dom) =>
Signal dom Word32
-> Signal dom (Maybe (BitVector n))
-> (Signal dom Bit, Signal dom Bool)
serialTxDyn (Signal dom Word32
 -> Signal dom (Maybe (BitVector n))
 -> (Signal dom Bit, Signal dom Bool))
-> Signal dom Word32
-> Signal dom (Maybe (BitVector n))
-> (Signal dom Bit, Signal dom Bool)
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 -> Signal dom Word32)
-> (SNat (ClockDivider dom (HzToPeriod rate)) -> Word32)
-> SNat (ClockDivider dom (HzToPeriod rate))
-> Signal dom Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32)
-> (SNat
      (Div
         (Div (Picoseconds 1000000000000) rate)
         (DomainConfigurationPeriod (KnownConf dom)))
    -> Integer)
-> SNat
     (Div
        (Div (Picoseconds 1000000000000) rate)
        (DomainConfigurationPeriod (KnownConf dom)))
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SNat
  (Div
     (Div (Picoseconds 1000000000000) rate)
     (DomainConfigurationPeriod (KnownConf dom)))
-> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (SNat (ClockDivider dom (HzToPeriod rate)) -> Signal dom Word32)
-> SNat (ClockDivider dom (HzToPeriod rate)) -> Signal dom Word32
forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => SNat n
SNat @(ClockDivider dom (HzToPeriod rate))

fifo
    :: forall a dom. (NFDataX a, HiddenClockResetEnable dom)
    => Signal dom (Maybe a) -> Signal dom Bool -> Signal dom (Maybe a)
fifo :: forall a (dom :: Symbol).
(NFDataX a, HiddenClockResetEnable dom) =>
Signal dom (Maybe a) -> Signal dom Bool -> Signal dom (Maybe a)
fifo Signal dom (Maybe a)
input Signal dom Bool
outReady = Signal dom (Maybe a)
r
  where
    r :: Signal dom (Maybe a)
r = Maybe a -> Signal dom (Maybe a) -> Signal dom (Maybe a)
forall (dom :: Symbol) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register Maybe a
forall a. Maybe a
Nothing (Signal dom (Maybe a) -> Signal dom (Maybe a))
-> Signal dom (Maybe a) -> Signal dom (Maybe a)
forall a b. (a -> b) -> a -> b
$ Signal dom Bool
-> Signal dom (Maybe a)
-> Signal dom (Maybe a)
-> Signal dom (Maybe a)
forall (f :: Type -> Type) a.
Applicative f =>
f Bool -> f a -> f a -> f a
mux Signal dom Bool
outReady Signal dom (Maybe a)
input (Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: Type -> Type) a. MonadPlus m => m a -> m a -> m a
mplus (Maybe a -> Maybe a -> Maybe a)
-> Signal dom (Maybe a) -> Signal dom (Maybe a -> Maybe a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Maybe a)
r Signal dom (Maybe a -> Maybe a)
-> Signal dom (Maybe a) -> Signal dom (Maybe a)
forall a b. Signal dom (a -> b) -> Signal dom a -> Signal dom b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Signal dom (Maybe a)
input)