{-|
Copyright : © 2015-2016, Christiaan Baaij,
              2017     , Google Inc.
              2019     , Myrtle Software Ltd
Licence   : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/)
-}

{-# LANGUAGE NoImplicitPrelude, CPP, TemplateHaskell, DataKinds, BinaryLiterals,
             FlexibleContexts, GADTs, TypeOperators, TypeApplications,
             RecordWildCards, DeriveGeneric, DeriveAnyClass #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Clash.Examples (
  -- * Decoders and Encoders
  -- $decoders_and_encoders

  -- * Counters
  -- $counters

  -- * Parity and CRC
  -- $parity_and_crc

  -- * UART model
  -- $uart
  )
where

import Clash.Prelude hiding (feedback)
import Control.Lens
import Control.Monad
import Control.Monad.Trans.State

decoderCase :: Bool -> BitVector 4 -> BitVector 16
decoderCase :: Bool -> BitVector 4 -> BitVector 16
decoderCase enable :: Bool
enable binaryIn :: BitVector 4
binaryIn | Bool
enable =
  case BitVector 4
binaryIn of
    0x0 -> 0x0001
    0x1 -> 0x0002
    0x2 -> 0x0004
    0x3 -> 0x0008
    0x4 -> 0x0010
    0x5 -> 0x0020
    0x6 -> 0x0040
    0x7 -> 0x0080
    0x8 -> 0x0100
    0x9 -> 0x0200
    0xA -> 0x0400
    0xB -> 0x0800
    0xC -> 0x1000
    0xD -> 0x2000
    0xE -> 0x4000
    0xF -> 0x8000
decoderCase _ _ = 0

decoderShift :: Bool -> BitVector 4 -> BitVector 16
decoderShift :: Bool -> BitVector 4 -> BitVector 16
decoderShift enable :: Bool
enable binaryIn :: BitVector 4
binaryIn =
  if Bool
enable
     then 1 BitVector 16 -> Int -> BitVector 16
forall a. Bits a => a -> Int -> a
`shiftL` (BitVector 4 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral BitVector 4
binaryIn)
     else 0

encoderCase :: Bool -> BitVector 16 -> BitVector 4
encoderCase :: Bool -> BitVector 16 -> BitVector 4
encoderCase enable :: Bool
enable binaryIn :: BitVector 16
binaryIn | Bool
enable =
  case BitVector 16
binaryIn of
    0x0001 -> 0x0
    0x0002 -> 0x1
    0x0004 -> 0x2
    0x0008 -> 0x3
    0x0010 -> 0x4
    0x0020 -> 0x5
    0x0040 -> 0x6
    0x0080 -> 0x7
    0x0100 -> 0x8
    0x0200 -> 0x9
    0x0400 -> 0xA
    0x0800 -> 0xB
    0x1000 -> 0xC
    0x2000 -> 0xD
    0x4000 -> 0xE
    0x8000 -> 0xF
encoderCase _ _ = 0

upCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (Unsigned 8)
upCounter :: Signal dom Bool -> Signal dom (Unsigned 8)
upCounter enable :: Signal dom Bool
enable = Signal dom (Unsigned 8)
s
  where
    s :: Signal dom (Unsigned 8)
s = Unsigned 8 -> Signal dom (Unsigned 8) -> Signal dom (Unsigned 8)
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register 0 (Signal dom Bool
-> Signal dom (Unsigned 8)
-> Signal dom (Unsigned 8)
-> Signal dom (Unsigned 8)
forall (f :: * -> *) a.
Applicative f =>
f Bool -> f a -> f a -> f a
mux Signal dom Bool
enable (Signal dom (Unsigned 8)
s Signal dom (Unsigned 8)
-> Signal dom (Unsigned 8) -> Signal dom (Unsigned 8)
forall a. Num a => a -> a -> a
+ 1) Signal dom (Unsigned 8)
s)

upCounterLdT
  :: Num a => a -> (Bool, Bool, a) -> (a,a)
upCounterLdT :: a -> (Bool, Bool, a) -> (a, a)
upCounterLdT s :: a
s (ld :: Bool
ld,en :: Bool
en,dIn :: a
dIn) = (a
s',a
s)
  where
    s' :: a
s' | Bool
ld        = a
dIn
       | Bool
en        = a
s a -> a -> a
forall a. Num a => a -> a -> a
+ 1
       | Bool
otherwise = a
s

upCounterLd
  :: HiddenClockResetEnable dom
  => Signal dom (Bool, Bool, Unsigned 8)
  -> Signal dom (Unsigned 8)
upCounterLd :: Signal dom (Bool, Bool, Unsigned 8) -> Signal dom (Unsigned 8)
upCounterLd = (Unsigned 8
 -> (Bool, Bool, Unsigned 8) -> (Unsigned 8, Unsigned 8))
-> Unsigned 8
-> Signal dom (Bool, Bool, Unsigned 8)
-> Signal dom (Unsigned 8)
forall (dom :: Domain) s i o.
(HiddenClockResetEnable dom, NFDataX s) =>
(s -> i -> (s, o)) -> s -> Signal dom i -> Signal dom o
mealy Unsigned 8 -> (Bool, Bool, Unsigned 8) -> (Unsigned 8, Unsigned 8)
forall a. Num a => a -> (Bool, Bool, a) -> (a, a)
upCounterLdT 0

upDownCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (Unsigned 8)
upDownCounter :: Signal dom Bool -> Signal dom (Unsigned 8)
upDownCounter upDown :: Signal dom Bool
upDown = Signal dom (Unsigned 8)
s
  where
    s :: Signal dom (Unsigned 8)
s = Unsigned 8 -> Signal dom (Unsigned 8) -> Signal dom (Unsigned 8)
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register 0 (Signal dom Bool
-> Signal dom (Unsigned 8)
-> Signal dom (Unsigned 8)
-> Signal dom (Unsigned 8)
forall (f :: * -> *) a.
Applicative f =>
f Bool -> f a -> f a -> f a
mux Signal dom Bool
upDown (Signal dom (Unsigned 8)
s Signal dom (Unsigned 8)
-> Signal dom (Unsigned 8) -> Signal dom (Unsigned 8)
forall a. Num a => a -> a -> a
+ 1) (Signal dom (Unsigned 8)
s Signal dom (Unsigned 8)
-> Signal dom (Unsigned 8) -> Signal dom (Unsigned 8)
forall a. Num a => a -> a -> a
- 1))

lfsrF' :: BitVector 16 -> BitVector 16
lfsrF' :: BitVector 16 -> BitVector 16
lfsrF' s :: BitVector 16
s = Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack Bit
feedback BitVector 1 -> BitVector 15 -> BitVector (1 + 15)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# SNat 15 -> SNat 1 -> BitVector 16 -> BitVector ((15 + 1) - 1)
forall a (m :: Nat) (i :: Nat) (n :: Nat).
(BitPack a, BitSize a ~ ((m + 1) + i)) =>
SNat m -> SNat n -> a -> BitVector ((m + 1) - n)
slice SNat 15
d15 SNat 1
d1 BitVector 16
s
  where
    feedback :: Bit
feedback = BitVector 16
sBitVector 16 -> Integer -> Bit
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
a -> i -> Bit
!5 Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
`xor` BitVector 16
sBitVector 16 -> Integer -> Bit
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
a -> i -> Bit
!3 Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
`xor` BitVector 16
sBitVector 16 -> Integer -> Bit
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
a -> i -> Bit
!2 Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
`xor` BitVector 16
sBitVector 16 -> Integer -> Bit
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
a -> i -> Bit
!0

lfsrF
  :: HiddenClockResetEnable dom
  => BitVector 16 -> Signal dom Bit
lfsrF :: BitVector 16 -> Signal dom Bit
lfsrF seed :: BitVector 16
seed = BitVector 16 -> Bit
forall a. (BitPack a, KnownNat (BitSize a)) => a -> Bit
msb (BitVector 16 -> Bit)
-> Signal dom (BitVector 16) -> Signal dom Bit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (BitVector 16)
r
  where r :: Signal dom (BitVector 16)
r = BitVector 16
-> Signal dom (BitVector 16) -> Signal dom (BitVector 16)
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register BitVector 16
seed (BitVector 16 -> BitVector 16
lfsrF' (BitVector 16 -> BitVector 16)
-> Signal dom (BitVector 16) -> Signal dom (BitVector 16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (BitVector 16)
r)

lfsrGP
  :: (KnownNat (n + 1), Bits a)
  => Vec (n + 1) Bool
  -> Vec (n + 1) a
  -> Vec (n + 1) a
lfsrGP :: Vec (n + 1) Bool -> Vec (n + 1) a -> Vec (n + 1) a
lfsrGP taps :: Vec (n + 1) Bool
taps regs :: Vec (n + 1) a
regs = (Bool -> a -> a)
-> Vec (n + 1) Bool -> Vec (n + 1) a -> Vec (n + 1) a
forall a b c (n :: Nat).
(a -> b -> c) -> Vec n a -> Vec n b -> Vec n c
zipWith Bool -> a -> a
xorM Vec (n + 1) Bool
taps (a
fb a -> Vec (n + 1) a -> Vec (n + 1) a
forall (n :: Nat) a. KnownNat n => a -> Vec n a -> Vec n a
+>> Vec (n + 1) a
regs)
  where
    fb :: a
fb = Vec (n + 1) a -> a
forall (n :: Nat) a. Vec (n + 1) a -> a
last Vec (n + 1) a
regs
    xorM :: Bool -> a -> a
xorM i :: Bool
i x :: a
x | Bool
i         =  a
x a -> a -> a
forall a. Bits a => a -> a -> a
`xor` a
fb
             | Bool
otherwise = a
x

lfsrG
  :: HiddenClockResetEnable dom
  => BitVector 16
  -> Signal dom Bit
lfsrG :: BitVector 16 -> Signal dom Bit
lfsrG seed :: BitVector 16
seed = Vec (15 + 1) (Signal dom Bit) -> Signal dom Bit
forall (n :: Nat) a. Vec (n + 1) a -> a
last (Signal dom (Vec 16 Bit) -> Unbundled dom (Vec 16 Bit)
forall a (dom :: Domain).
Bundle a =>
Signal dom a -> Unbundled dom a
unbundle Signal dom (Vec 16 Bit)
r)
  where r :: Signal dom (Vec 16 Bit)
r = Vec 16 Bit -> Signal dom (Vec 16 Bit) -> Signal dom (Vec 16 Bit)
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register (BitVector (BitSize (Vec 16 Bit)) -> Vec 16 Bit
forall a. BitPack a => BitVector (BitSize a) -> a
unpack BitVector 16
BitVector (BitSize (Vec 16 Bit))
seed) (Vec (15 + 1) Bool -> Vec (15 + 1) Bit -> Vec (15 + 1) Bit
forall (n :: Nat) a.
(KnownNat (n + 1), Bits a) =>
Vec (n + 1) Bool -> Vec (n + 1) a -> Vec (n + 1) a
lfsrGP (BitVector (BitSize (Vec 16 Bool)) -> Vec 16 Bool
forall a. BitPack a => BitVector (BitSize a) -> a
unpack 0b0011010000000000) (Vec 16 Bit -> Vec 16 Bit)
-> Signal dom (Vec 16 Bit) -> Signal dom (Vec 16 Bit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Vec 16 Bit)
r)

grayCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (BitVector 8)
grayCounter :: Signal dom Bool -> Signal dom (BitVector 8)
grayCounter en :: Signal dom Bool
en = Unsigned 8 -> BitVector 8
forall a (i :: Nat) (i :: Nat).
(BitPack a, KnownNat (BitSize a), BitSize a ~ (7 + i),
 BitSize a ~ (8 + i)) =>
a -> BitVector 8
gray (Unsigned 8 -> BitVector 8)
-> Signal dom (Unsigned 8) -> Signal dom (BitVector 8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom Bool -> Signal dom (Unsigned 8)
forall (dom :: Domain).
HiddenClockResetEnable dom =>
Signal dom Bool -> Signal dom (Unsigned 8)
upCounter Signal dom Bool
en
  where gray :: a -> BitVector (1 + 7)
gray xs :: a
xs = Bit -> BitVector (BitSize Bit)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (a -> Bit
forall a. (BitPack a, KnownNat (BitSize a)) => a -> Bit
msb a
xs) BitVector 1 -> BitVector 7 -> BitVector (1 + 7)
forall (m :: Nat) (n :: Nat).
KnownNat m =>
BitVector n -> BitVector m -> BitVector (n + m)
++# BitVector 7 -> BitVector 7 -> BitVector 7
forall a. Bits a => a -> a -> a
xor (SNat 7 -> SNat 1 -> a -> BitVector ((7 + 1) - 1)
forall a (m :: Nat) (i :: Nat) (n :: Nat).
(BitPack a, BitSize a ~ ((m + 1) + i)) =>
SNat m -> SNat n -> a -> BitVector ((m + 1) - n)
slice SNat 7
d7 SNat 1
d1 a
xs) (SNat 6 -> SNat 0 -> a -> BitVector ((6 + 1) - 0)
forall a (m :: Nat) (i :: Nat) (n :: Nat).
(BitPack a, BitSize a ~ ((m + 1) + i)) =>
SNat m -> SNat n -> a -> BitVector ((m + 1) - n)
slice SNat 6
d6 SNat 0
d0 a
xs)

oneHotCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (BitVector 8)
oneHotCounter :: Signal dom Bool -> Signal dom (BitVector 8)
oneHotCounter enable :: Signal dom Bool
enable = Signal dom (BitVector 8)
s
  where
    s :: Signal dom (BitVector 8)
s = BitVector 8 -> Signal dom (BitVector 8) -> Signal dom (BitVector 8)
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register 1 (Signal dom Bool
-> Signal dom (BitVector 8)
-> Signal dom (BitVector 8)
-> Signal dom (BitVector 8)
forall (f :: * -> *) a.
Applicative f =>
f Bool -> f a -> f a -> f a
mux Signal dom Bool
enable (BitVector 8 -> Int -> BitVector 8
forall a. Bits a => a -> Int -> a
rotateL (BitVector 8 -> Int -> BitVector 8)
-> Signal dom (BitVector 8) -> Signal dom (Int -> BitVector 8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (BitVector 8)
s Signal dom (Int -> BitVector 8)
-> Signal dom Int -> Signal dom (BitVector 8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 1) Signal dom (BitVector 8)
s)

crcT
  :: ( Bits a
     , KnownNat (BitSize a)
     , BitPack a
     )
  => a
  -> Bit
  -> a
crcT :: a -> Bit -> a
crcT bv :: a
bv dIn :: Bit
dIn = Integer -> Bit -> a -> a
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
i -> Bit -> a -> a
replaceBit 0  Bit
dInXor
            (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Integer -> Bit -> a -> a
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
i -> Bit -> a -> a
replaceBit 5  (a
bva -> Integer -> Bit
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
a -> i -> Bit
!4  Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
`xor` Bit
dInXor)
            (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Integer -> Bit -> a -> a
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
i -> Bit -> a -> a
replaceBit 12 (a
bva -> Integer -> Bit
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
a -> i -> Bit
!11 Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
`xor` Bit
dInXor)
              a
rotated
  where
    dInXor :: Bit
dInXor  = Bit
dIn Bit -> Bit -> Bit
forall a. Bits a => a -> a -> a
`xor` Bit
fb
    rotated :: a
rotated = a -> Int -> a
forall a. Bits a => a -> Int -> a
rotateL a
bv 1
    fb :: Bit
fb      = a -> Bit
forall a. (BitPack a, KnownNat (BitSize a)) => a -> Bit
msb a
bv

crc
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom Bool
  -> Signal dom Bit
  -> Signal dom (BitVector 16)
crc :: Signal dom Bool
-> Signal dom Bool -> Signal dom Bit -> Signal dom (BitVector 16)
crc enable :: Signal dom Bool
enable ld :: Signal dom Bool
ld dIn :: Signal dom Bit
dIn = Signal dom (BitVector 16)
s
  where
    s :: Signal dom (BitVector 16)
s = BitVector 16
-> Signal dom (BitVector 16) -> Signal dom (BitVector 16)
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register 0xFFFF (Signal dom Bool
-> Signal dom (BitVector 16)
-> Signal dom (BitVector 16)
-> Signal dom (BitVector 16)
forall (f :: * -> *) a.
Applicative f =>
f Bool -> f a -> f a -> f a
mux Signal dom Bool
enable (Signal dom Bool
-> Signal dom (BitVector 16)
-> Signal dom (BitVector 16)
-> Signal dom (BitVector 16)
forall (f :: * -> *) a.
Applicative f =>
f Bool -> f a -> f a -> f a
mux Signal dom Bool
ld 0xFFFF (BitVector 16 -> Bit -> BitVector 16
forall a.
(Bits a, KnownNat (BitSize a), BitPack a) =>
a -> Bit -> a
crcT (BitVector 16 -> Bit -> BitVector 16)
-> Signal dom (BitVector 16) -> Signal dom (Bit -> BitVector 16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (BitVector 16)
s Signal dom (Bit -> BitVector 16)
-> Signal dom Bit -> Signal dom (BitVector 16)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Signal dom Bit
dIn)) Signal dom (BitVector 16)
s)

data RxReg
  = RxReg
  { RxReg -> BitVector 8
_rx_reg        :: BitVector 8
  , RxReg -> BitVector 8
_rx_data       :: BitVector 8
  , RxReg -> Unsigned 4
_rx_sample_cnt :: Unsigned 4
  , RxReg -> Unsigned 4
_rx_cnt        :: Unsigned 4
  , RxReg -> Bool
_rx_frame_err  :: Bool
  , RxReg -> Bool
_rx_over_run   :: Bool
  , RxReg -> Bool
_rx_empty      :: Bool
  , RxReg -> Bit
_rx_d1         :: Bit
  , RxReg -> Bit
_rx_d2         :: Bit
  , RxReg -> Bool
_rx_busy       :: Bool
  } deriving ((forall x. RxReg -> Rep RxReg x)
-> (forall x. Rep RxReg x -> RxReg) -> Generic RxReg
forall x. Rep RxReg x -> RxReg
forall x. RxReg -> Rep RxReg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RxReg x -> RxReg
$cfrom :: forall x. RxReg -> Rep RxReg x
Generic, HasCallStack => String -> RxReg
RxReg -> ()
(HasCallStack => String -> RxReg) -> (RxReg -> ()) -> NFDataX RxReg
forall a. (HasCallStack => String -> a) -> (a -> ()) -> NFDataX a
rnfX :: RxReg -> ()
$crnfX :: RxReg -> ()
deepErrorX :: String -> RxReg
$cdeepErrorX :: HasCallStack => String -> RxReg
NFDataX)

makeLenses ''RxReg

data TxReg
  = TxReg
  { TxReg -> BitVector 8
_tx_reg      :: BitVector 8
  , TxReg -> Bool
_tx_empty    :: Bool
  , TxReg -> Bool
_tx_over_run :: Bool
  , TxReg -> Bit
_tx_out      :: Bit
  , TxReg -> Unsigned 4
_tx_cnt      :: Unsigned 4
  }
  deriving ((forall x. TxReg -> Rep TxReg x)
-> (forall x. Rep TxReg x -> TxReg) -> Generic TxReg
forall x. Rep TxReg x -> TxReg
forall x. TxReg -> Rep TxReg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TxReg x -> TxReg
$cfrom :: forall x. TxReg -> Rep TxReg x
Generic, HasCallStack => String -> TxReg
TxReg -> ()
(HasCallStack => String -> TxReg) -> (TxReg -> ()) -> NFDataX TxReg
forall a. (HasCallStack => String -> a) -> (a -> ()) -> NFDataX a
rnfX :: TxReg -> ()
$crnfX :: TxReg -> ()
deepErrorX :: String -> TxReg
$cdeepErrorX :: HasCallStack => String -> TxReg
NFDataX)

makeLenses ''TxReg

uartTX :: TxReg -> Bool -> BitVector 8 -> Bool -> TxReg
uartTX t :: TxReg
t@(TxReg {..}) ld_tx_data :: Bool
ld_tx_data tx_data :: BitVector 8
tx_data tx_enable :: Bool
tx_enable = (State TxReg () -> TxReg -> TxReg)
-> TxReg -> State TxReg () -> TxReg
forall a b c. (a -> b -> c) -> b -> a -> c
flip State TxReg () -> TxReg -> TxReg
forall s a. State s a -> s -> s
execState TxReg
t (State TxReg () -> TxReg) -> State TxReg () -> TxReg
forall a b. (a -> b) -> a -> b
$ do
  Bool -> State TxReg () -> State TxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ld_tx_data (State TxReg () -> State TxReg ())
-> State TxReg () -> State TxReg ()
forall a b. (a -> b) -> a -> b
$ do
    if Bool -> Bool
not Bool
_tx_empty then
      (Bool -> Identity Bool) -> TxReg -> Identity TxReg
Lens' TxReg Bool
tx_over_run ((Bool -> Identity Bool) -> TxReg -> Identity TxReg)
-> Bool -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
    else do
      (BitVector 8 -> Identity (BitVector 8)) -> TxReg -> Identity TxReg
Lens' TxReg (BitVector 8)
tx_reg   ((BitVector 8 -> Identity (BitVector 8))
 -> TxReg -> Identity TxReg)
-> BitVector 8 -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= BitVector 8
tx_data
      (Bool -> Identity Bool) -> TxReg -> Identity TxReg
Lens' TxReg Bool
tx_empty ((Bool -> Identity Bool) -> TxReg -> Identity TxReg)
-> Bool -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
  Bool -> State TxReg () -> State TxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
tx_enable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
_tx_empty) (State TxReg () -> State TxReg ())
-> State TxReg () -> State TxReg ()
forall a b. (a -> b) -> a -> b
$ do
    (Unsigned 4 -> Identity (Unsigned 4)) -> TxReg -> Identity TxReg
Lens' TxReg (Unsigned 4)
tx_cnt ((Unsigned 4 -> Identity (Unsigned 4)) -> TxReg -> Identity TxReg)
-> Unsigned 4 -> State TxReg ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= 1
    Bool -> State TxReg () -> State TxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unsigned 4
_tx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (State TxReg () -> State TxReg ())
-> State TxReg () -> State TxReg ()
forall a b. (a -> b) -> a -> b
$
      (Bit -> Identity Bit) -> TxReg -> Identity TxReg
Lens' TxReg Bit
tx_out ((Bit -> Identity Bit) -> TxReg -> Identity TxReg)
-> Bit -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 0
    Bool -> State TxReg () -> State TxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unsigned 4
_tx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Unsigned 4
_tx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Ord a => a -> a -> Bool
< 9) (State TxReg () -> State TxReg ())
-> State TxReg () -> State TxReg ()
forall a b. (a -> b) -> a -> b
$
      (Bit -> Identity Bit) -> TxReg -> Identity TxReg
Lens' TxReg Bit
tx_out ((Bit -> Identity Bit) -> TxReg -> Identity TxReg)
-> Bit -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= BitVector 8
_tx_reg BitVector 8 -> Unsigned 4 -> Bit
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
a -> i -> Bit
! (Unsigned 4
_tx_cnt Unsigned 4 -> Unsigned 4 -> Unsigned 4
forall a. Num a => a -> a -> a
- 1)
    Bool -> State TxReg () -> State TxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unsigned 4
_tx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Eq a => a -> a -> Bool
== 9) (State TxReg () -> State TxReg ())
-> State TxReg () -> State TxReg ()
forall a b. (a -> b) -> a -> b
$ do
      (Bit -> Identity Bit) -> TxReg -> Identity TxReg
Lens' TxReg Bit
tx_out   ((Bit -> Identity Bit) -> TxReg -> Identity TxReg)
-> Bit -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 1
      (Unsigned 4 -> Identity (Unsigned 4)) -> TxReg -> Identity TxReg
Lens' TxReg (Unsigned 4)
tx_cnt   ((Unsigned 4 -> Identity (Unsigned 4)) -> TxReg -> Identity TxReg)
-> Unsigned 4 -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 0
      (Bool -> Identity Bool) -> TxReg -> Identity TxReg
Lens' TxReg Bool
tx_empty ((Bool -> Identity Bool) -> TxReg -> Identity TxReg)
-> Bool -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
  Bool -> State TxReg () -> State TxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
tx_enable (State TxReg () -> State TxReg ())
-> State TxReg () -> State TxReg ()
forall a b. (a -> b) -> a -> b
$
    (Unsigned 4 -> Identity (Unsigned 4)) -> TxReg -> Identity TxReg
Lens' TxReg (Unsigned 4)
tx_cnt ((Unsigned 4 -> Identity (Unsigned 4)) -> TxReg -> Identity TxReg)
-> Unsigned 4 -> State TxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 0

uartRX :: RxReg -> Bit -> Bool -> Bool -> RxReg
uartRX r :: RxReg
r@(RxReg {..}) rx_in :: Bit
rx_in uld_rx_data :: Bool
uld_rx_data rx_enable :: Bool
rx_enable = (State RxReg () -> RxReg -> RxReg)
-> RxReg -> State RxReg () -> RxReg
forall a b c. (a -> b -> c) -> b -> a -> c
flip State RxReg () -> RxReg -> RxReg
forall s a. State s a -> s -> s
execState RxReg
r (State RxReg () -> RxReg) -> State RxReg () -> RxReg
forall a b. (a -> b) -> a -> b
$ do
  -- Synchronize the async signal
  (Bit -> Identity Bit) -> RxReg -> Identity RxReg
Lens' RxReg Bit
rx_d1 ((Bit -> Identity Bit) -> RxReg -> Identity RxReg)
-> Bit -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bit
rx_in
  (Bit -> Identity Bit) -> RxReg -> Identity RxReg
Lens' RxReg Bit
rx_d2 ((Bit -> Identity Bit) -> RxReg -> Identity RxReg)
-> Bit -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bit
_rx_d1
  -- Uload the rx data
  Bool -> State RxReg () -> State RxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
uld_rx_data (State RxReg () -> State RxReg ())
-> State RxReg () -> State RxReg ()
forall a b. (a -> b) -> a -> b
$ do
    (BitVector 8 -> Identity (BitVector 8)) -> RxReg -> Identity RxReg
Lens' RxReg (BitVector 8)
rx_data  ((BitVector 8 -> Identity (BitVector 8))
 -> RxReg -> Identity RxReg)
-> BitVector 8 -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= BitVector 8
_rx_reg
    (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_empty ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
  -- Receive data only when rx is enabled
  if Bool
rx_enable then do
    -- Check if just received start of frame
    Bool -> State RxReg () -> State RxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
_rx_busy Bool -> Bool -> Bool
&& Bit
_rx_d2 Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (State RxReg () -> State RxReg ())
-> State RxReg () -> State RxReg ()
forall a b. (a -> b) -> a -> b
$ do
      (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_busy       ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
      (Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg
Lens' RxReg (Unsigned 4)
rx_sample_cnt ((Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg)
-> Unsigned 4 -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 1
      (Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg
Lens' RxReg (Unsigned 4)
rx_cnt        ((Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg)
-> Unsigned 4 -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 0
    -- Star of frame detected, Proceed with rest of data
    Bool -> State RxReg () -> State RxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
_rx_busy (State RxReg () -> State RxReg ())
-> State RxReg () -> State RxReg ()
forall a b. (a -> b) -> a -> b
$ do
      (Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg
Lens' RxReg (Unsigned 4)
rx_sample_cnt ((Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg)
-> Unsigned 4 -> State RxReg ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= 1
      -- Logic to sample at middle of data
      Bool -> State RxReg () -> State RxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unsigned 4
_rx_sample_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Eq a => a -> a -> Bool
== 7) (State RxReg () -> State RxReg ())
-> State RxReg () -> State RxReg ()
forall a b. (a -> b) -> a -> b
$ do
        if Bit
_rx_d1 Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
&& Unsigned 4
_rx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
          (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_busy ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
        else do
          (Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg
Lens' RxReg (Unsigned 4)
rx_cnt ((Unsigned 4 -> Identity (Unsigned 4)) -> RxReg -> Identity RxReg)
-> Unsigned 4 -> State RxReg ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= 1
          -- start storing the rx data
          Bool -> State RxReg () -> State RxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unsigned 4
_rx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Unsigned 4
_rx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Ord a => a -> a -> Bool
< 9) (State RxReg () -> State RxReg ())
-> State RxReg () -> State RxReg ()
forall a b. (a -> b) -> a -> b
$ do
            (BitVector 8 -> Identity (BitVector 8)) -> RxReg -> Identity RxReg
Lens' RxReg (BitVector 8)
rx_reg ((BitVector 8 -> Identity (BitVector 8))
 -> RxReg -> Identity RxReg)
-> (BitVector 8 -> BitVector 8) -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Unsigned 4 -> Bit -> BitVector 8 -> BitVector 8
forall a i.
(BitPack a, KnownNat (BitSize a), Enum i) =>
i -> Bit -> a -> a
replaceBit (Unsigned 4
_rx_cnt Unsigned 4 -> Unsigned 4 -> Unsigned 4
forall a. Num a => a -> a -> a
- 1) Bit
_rx_d2
          Bool -> State RxReg () -> State RxReg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unsigned 4
_rx_cnt Unsigned 4 -> Unsigned 4 -> Bool
forall a. Eq a => a -> a -> Bool
== 9) (State RxReg () -> State RxReg ())
-> State RxReg () -> State RxReg ()
forall a b. (a -> b) -> a -> b
$ do
            (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_busy ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
            -- Check if End of frame received correctly
            if Bit
_rx_d2 Bit -> Bit -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then
              (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_frame_err ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
            else do
              (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_empty     ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
              (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_frame_err ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
              -- Check if last rx data was not unloaded
              (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_over_run  ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool -> Bool
not Bool
_rx_empty
  else do
    (Bool -> Identity Bool) -> RxReg -> Identity RxReg
Lens' RxReg Bool
rx_busy ((Bool -> Identity Bool) -> RxReg -> Identity RxReg)
-> Bool -> State RxReg ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False

uart :: Signal dom Bool
-> Signal dom (BitVector 8)
-> Signal dom Bool
-> Signal dom Bit
-> Signal dom Bool
-> Signal dom Bool
-> (Signal dom Bit, Signal dom Bool, Signal dom (BitVector 8),
    Signal dom Bool)
uart ld_tx_data :: Signal dom Bool
ld_tx_data tx_data :: Signal dom (BitVector 8)
tx_data tx_enable :: Signal dom Bool
tx_enable rx_in :: Signal dom Bit
rx_in uld_rx_data :: Signal dom Bool
uld_rx_data rx_enable :: Signal dom Bool
rx_enable =
    ( TxReg -> Bit
_tx_out   (TxReg -> Bit) -> Signal dom TxReg -> Signal dom Bit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom TxReg
txReg
    , TxReg -> Bool
_tx_empty (TxReg -> Bool) -> Signal dom TxReg -> Signal dom Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom TxReg
txReg
    , RxReg -> BitVector 8
_rx_data  (RxReg -> BitVector 8)
-> Signal dom RxReg -> Signal dom (BitVector 8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom RxReg
rxReg
    , RxReg -> Bool
_rx_empty (RxReg -> Bool) -> Signal dom RxReg -> Signal dom Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom RxReg
rxReg
    )
  where
    rxReg :: Signal dom RxReg
rxReg     = RxReg -> Signal dom RxReg -> Signal dom RxReg
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register RxReg
rxRegInit (RxReg -> Bit -> Bool -> Bool -> RxReg
uartRX (RxReg -> Bit -> Bool -> Bool -> RxReg)
-> Signal dom RxReg -> Signal dom (Bit -> Bool -> Bool -> RxReg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom RxReg
rxReg Signal dom (Bit -> Bool -> Bool -> RxReg)
-> Signal dom Bit -> Signal dom (Bool -> Bool -> RxReg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Signal dom Bit
rx_in Signal dom (Bool -> Bool -> RxReg)
-> Signal dom Bool -> Signal dom (Bool -> RxReg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Signal dom Bool
uld_rx_data
                                           Signal dom (Bool -> RxReg) -> Signal dom Bool -> Signal dom RxReg
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Signal dom Bool
rx_enable)
    rxRegInit :: RxReg
rxRegInit = RxReg :: BitVector 8
-> BitVector 8
-> Unsigned 4
-> Unsigned 4
-> Bool
-> Bool
-> Bool
-> Bit
-> Bit
-> Bool
-> RxReg
RxReg { _rx_reg :: BitVector 8
_rx_reg        = 0
                      , _rx_data :: BitVector 8
_rx_data       = 0
                      , _rx_sample_cnt :: Unsigned 4
_rx_sample_cnt = 0
                      , _rx_cnt :: Unsigned 4
_rx_cnt        = 0
                      , _rx_frame_err :: Bool
_rx_frame_err  = Bool
False
                      , _rx_over_run :: Bool
_rx_over_run   = Bool
False
                      , _rx_empty :: Bool
_rx_empty      = Bool
True
                      , _rx_d1 :: Bit
_rx_d1         = 1
                      , _rx_d2 :: Bit
_rx_d2         = 1
                      , _rx_busy :: Bool
_rx_busy       = Bool
False
                      }
    txReg :: Signal dom TxReg
txReg     = TxReg -> Signal dom TxReg -> Signal dom TxReg
forall (dom :: Domain) a.
(HiddenClockResetEnable dom, NFDataX a) =>
a -> Signal dom a -> Signal dom a
register TxReg
txRegInit (TxReg -> Bool -> BitVector 8 -> Bool -> TxReg
uartTX (TxReg -> Bool -> BitVector 8 -> Bool -> TxReg)
-> Signal dom TxReg
-> Signal dom (Bool -> BitVector 8 -> Bool -> TxReg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom TxReg
txReg Signal dom (Bool -> BitVector 8 -> Bool -> TxReg)
-> Signal dom Bool -> Signal dom (BitVector 8 -> Bool -> TxReg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Signal dom Bool
ld_tx_data Signal dom (BitVector 8 -> Bool -> TxReg)
-> Signal dom (BitVector 8) -> Signal dom (Bool -> TxReg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Signal dom (BitVector 8)
tx_data
                                           Signal dom (Bool -> TxReg) -> Signal dom Bool -> Signal dom TxReg
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Signal dom Bool
tx_enable)
    txRegInit :: TxReg
txRegInit = TxReg :: BitVector 8 -> Bool -> Bool -> Bit -> Unsigned 4 -> TxReg
TxReg { _tx_reg :: BitVector 8
_tx_reg      = 0
                      , _tx_empty :: Bool
_tx_empty    = Bool
True
                      , _tx_over_run :: Bool
_tx_over_run = Bool
False
                      , _tx_out :: Bit
_tx_out      = 1
                      , _tx_cnt :: Unsigned 4
_tx_cnt      = 0
                      }

{- $setup
>>> :set -XDataKinds
>>> import Clash.Prelude
>>> import Test.QuickCheck
-}

{- $decoders_and_encoders
= Decoder

Using a @case@ statement:

@
decoderCase :: Bool -> BitVector 4 -> BitVector 16
decoderCase enable binaryIn | enable =
  case binaryIn of
    0x0 -> 0x0001
    0x1 -> 0x0002
    0x2 -> 0x0004
    0x3 -> 0x0008
    0x4 -> 0x0010
    0x5 -> 0x0020
    0x6 -> 0x0040
    0x7 -> 0x0080
    0x8 -> 0x0100
    0x9 -> 0x0200
    0xA -> 0x0400
    0xB -> 0x0800
    0xC -> 0x1000
    0xD -> 0x2000
    0xE -> 0x4000
    0xF -> 0x8000
decoderCase _ _ = 0
@

Using the `shiftL` function:

@
decoderShift :: Bool -> BitVector 4 -> BitVector 16
decoderShift enable binaryIn =
  if enable
     then 1 ``shiftL`` ('fromIntegral' binaryIn)
     else 0
@

Examples:

>>> decoderCase True 3
0000_0000_0000_1000
>>> decoderShift True 7
0000_0000_1000_0000

The following property holds:

prop> \enable binaryIn -> decoderShift enable binaryIn === decoderCase enable binaryIn

= Encoder

Using a @case@ statement:

@
encoderCase :: Bool -> BitVector 16 -> BitVector 4
encoderCase enable binaryIn | enable =
  case binaryIn of
    0x0001 -> 0x0
    0x0002 -> 0x1
    0x0004 -> 0x2
    0x0008 -> 0x3
    0x0010 -> 0x4
    0x0020 -> 0x5
    0x0040 -> 0x6
    0x0080 -> 0x7
    0x0100 -> 0x8
    0x0200 -> 0x9
    0x0400 -> 0xA
    0x0800 -> 0xB
    0x1000 -> 0xC
    0x2000 -> 0xD
    0x4000 -> 0xE
    0x8000 -> 0xF
encoderCase _ _ = 0
@

The following property holds:

prop> \en decIn -> en ==> (encoderCase en (decoderCase en decIn) === decIn)
-}

{- $counters
= 8-bit Simple Up Counter

Using `register`:

@
upCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (Unsigned 8)
upCounter enable = s
  where
    s = `register` 0 (`mux` enable (s + 1) s)
@

= 8-bit Up Counter With Load

Using `mealy`:

@
upCounterLd
  :: HiddenClockResetEnable dom
  => Signal dom (Bool,Bool,Unsigned 8)
  -> Signal dom (Unsigned 8)
upCounterLd = `mealy` upCounterLdT 0

upCounterLdT s (ld,en,dIn) = (s',s)
  where
    s' | ld        = dIn
       | en        = s + 1
       | otherwise = s
@

= 8-bit Up-Down counter

Using `register` and `mux`:

@
upDownCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (Unsigned 8)
upDownCounter upDown = s
  where
    s = `register` 0 (`mux` upDown (s + 1) (s - 1))
@

The following property holds:

prop> \en -> en ==> testFor 1000 (upCounter (pure en) .==. upDownCounter (pure en) :: Signal "System" Bool)

= LFSR

External/Fibonacci LFSR, for @n=16@ and using the primitive polynominal @1 + x^11 + x^13 + x^14 + x^16@

@
lfsrF' :: BitVector 16 -> BitVector 16
lfsrF' s = 'pack' feedback '++#' 'slice' d15 d1 s
  where
    feedback = s'!'5 ``xor`` s'!'3 ``xor`` s'!'2 ``xor`` s'!'0

lfsrF
  :: HiddenClockResetEnable dom
  => BitVector 16
  -> Signal dom Bit
lfsrF seed = 'msb' '<$>' r
  where r = 'register' seed (lfsrF' '<$>' r)
@

We can also build a internal/Galois LFSR which has better timing characteristics.
We first define a Galois LFSR parameterizable in its filter taps:

@
lfsrGP taps regs = 'zipWith' xorM taps (fb '+>>' regs)
  where
    fb  = 'last' regs
    xorM i x | i         = x ``xor`` fb
             | otherwise = x
@

Then we can instantiate a 16-bit LFSR as follows:

@
lfsrG :: HiddenClockResetEnable dom  => BitVector 16 -> Signal dom Bit
lfsrG seed = 'last' ('unbundle' r)
  where r = 'register' ('unpack' seed) (lfsrGP ('unpack' 0b0011010000000000) '<$>' r)
@

The following property holds:

prop> testFor 100 (lfsrF 0xACE1 .==. lfsrG 0x4645 :: Signal "System" Bool)

= Gray counter

Using the previously defined @upCounter@:

@
grayCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (BitVector 8)
grayCounter en = gray '<$>' upCounter en
  where gray xs = 'pack' ('msb' xs) '++#' 'xor' ('slice' d7 d1 xs) ('slice' d6 d0 xs)
@

= One-hot counter

Basically a barrel-shifter:

@
oneHotCounter
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom (BitVector 8)
oneHotCounter enable = s
  where
    s = 'register' 1 ('mux' enable ('rotateL' '<$>' s '<*>' 1) s)
@
-}

{- $parity_and_crc
= Parity

Just 'reduceXor':

@
parity :: Unsigned 8 -> Bit
parity data_in = `reduceXor` data_in
@

= Serial CRC

* Width = 16 bits
* Truncated polynomial = 0x1021
* Initial value = 0xFFFF
* Input data is NOT reflected
* Output CRC is NOT reflected
* No XOR is performed on the output CRC

@
crcT bv dIn = 'replaceBit' 0  dInXor
            $ 'replaceBit' 5  (bv'!'4  ``xor`` dInXor)
            $ 'replaceBit' 12 (bv'!'11 ``xor`` dInXor)
              rotated
  where
    dInXor  = dIn ``xor`` fb
    rotated = 'rotateL' bv 1
    fb      = 'msb' bv

crc
  :: HiddenClockResetEnable dom
  => Signal dom Bool
  -> Signal dom Bool
  -> Signal dom Bit
  -> Signal dom (BitVector 16)
crc enable ld dIn = s
  where
    s = 'register' 0xFFFF ('mux' enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn)) s)
@
-}

{- $uart
@
{\-\# LANGUAGE RecordWildCards \#-\}
module UART (uart) where

import Clash.Prelude
import Control.Lens
import Control.Monad
import Control.Monad.Trans.State

-- UART RX Logic
data RxReg
  = RxReg
  { _rx_reg        :: BitVector 8
  , _rx_data       :: BitVector 8
  , _rx_sample_cnt :: Unsigned 4
  , _rx_cnt        :: Unsigned 4
  , _rx_frame_err  :: Bool
  , _rx_over_run   :: Bool
  , _rx_empty      :: Bool
  , _rx_d1         :: Bit
  , _rx_d2         :: Bit
  , _rx_busy       :: Bool
  }

makeLenses ''RxReg

uartRX r\@(RxReg {..}) rx_in uld_rx_data rx_enable = 'flip' 'execState' r $ do
  -- Synchronize the async signal
  rx_d1 '.=' rx_in
  rx_d2 '.=' _rx_d1
  -- Uload the rx data
  'when' uld_rx_data $ do
    rx_data  '.=' _rx_reg
    rx_empty '.=' True
  -- Receive data only when rx is enabled
  if rx_enable then do
    -- Check if just received start of frame
    'when' (not _rx_busy && _rx_d2 == 0) $ do
      rx_busy       '.=' True
      rx_sample_cnt '.=' 1
      rx_cnt        '.=' 0
    -- Star of frame detected, Proceed with rest of data
    'when' _rx_busy $ do
      rx_sample_cnt '+=' 1
      -- Logic to sample at middle of data
      'when' (_rx_sample_cnt == 7) $ do
        if _rx_d1 == 1 && _rx_cnt == 0 then
          rx_busy '.=' False
        else do
          rx_cnt '+=' 1
          -- start storing the rx data
          'when' (_rx_cnt > 0 && _rx_cnt < 9) $ do
            rx_reg '%=' 'replaceBit' (_rx_cnt - 1) _rx_d2
          'when' (_rx_cnt == 9) $ do
            rx_busy .= False
            -- Check if End of frame received correctly
            if _rx_d2 == 0 then
              rx_frame_err '.=' True
            else do
              rx_empty     '.=' False
              rx_frame_err '.=' False
              -- Check if last rx data was not unloaded
              rx_over_run  '.=' not _rx_empty
  else do
    rx_busy .= False

-- UART TX Logic
data TxReg
  = TxReg
  { _tx_reg      :: BitVector 8
  , _tx_empty    :: Bool
  , _tx_over_run :: Bool
  , _tx_out      :: Bit
  , _tx_cnt      :: Unsigned 4
  }

makeLenses ''TxReg

uartTX t\@(TxReg {..}) ld_tx_data tx_data tx_enable = 'flip' 'execState' t $ do
  'when' ld_tx_data $ do
    if not _tx_empty then
      tx_over_run '.=' False
    else do
      tx_reg   '.=' tx_data
      tx_empty '.=' False
  'when' (tx_enable && not _tx_empty) $ do
    tx_cnt '+=' 1
    'when' (_tx_cnt == 0) $
      tx_out '.=' 0
    'when' (_tx_cnt > 0 && _tx_cnt < 9) $
      tx_out '.=' _tx_reg '!' (_tx_cnt - 1)
    'when' (_tx_cnt == 9) $ do
      tx_out   '.=' 1
      tx_cnt   '.=' 0
      tx_empty '.=' True
  'unless' tx_enable $
    tx_cnt '.=' 0

-- Combine RX and TX logic
uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable =
    ( _tx_out   '<$>' txReg
    , _tx_empty '<$>' txReg
    , _rx_data  '<$>' rxReg
    , _rx_empty '<$>' rxReg
    )
  where
    rxReg     = register rxRegInit (uartRX '<$>' rxReg '<*>' rx_in '<*>' uld_rx_data
                                           '<*>' rx_enable)
    rxRegInit = RxReg { _rx_reg        = 0
                      , _rx_data       = 0
                      , _rx_sample_cnt = 0
                      , _rx_cnt        = 0
                      , _rx_frame_err  = False
                      , _rx_over_run   = False
                      , _rx_empty      = True
                      , _rx_d1         = 1
                      , _rx_d2         = 1
                      , _rx_busy       = False
                      }

    txReg     = register txRegInit (uartTX '<$>' txReg '<*>' ld_tx_data '<*>' tx_data
                                           '<*>' tx_enable)
    txRegInit = TxReg { _tx_reg      = 0
                      , _tx_empty    = True
                      , _tx_over_run = False
                      , _tx_out      = 1
                      , _tx_cnt      = 0
                      }
@
-}