{-# LANGUAGE LambdaCase #-} module UartLed where import Clash.Prelude import Clash.Annotations.TH import Control.Monad import Control.Monad.RWS import Control.Lens hiding (Index) import Data.Maybe (fromMaybe) import Data.Monoid import Veldt.Counter import qualified Veldt.PWM.Rgb as P import qualified Veldt.Ice40.Rgb as R import qualified Veldt.Uart as U type Byte = BitVector 8 type Timer = Index 36000000 data Speed = Low | Mid | Hi deriving (NFDataX, Generic, Eq, Bounded, Enum) toPeriod :: Speed -> Timer toPeriod = \case Low -> 35999999 Mid -> 11999999 Hi -> 2999999 data Color = Red | Green | Blue deriving (NFDataX, Generic) fromColor :: Color -> (Byte, Byte, Byte) fromColor = \case Red -> (0xFF, 0x00, 0x00) Green -> (0x00, 0xFF, 0x00) Blue -> (0x00, 0x00, 0xFF) data Led = On | Off deriving (NFDataX, Generic, Eq) toggle :: Led -> Led toggle On = Off toggle Off = On data Instr = Speed | Color Color deriving (NFDataX, Generic) encodeInstrM :: Byte -> Maybe Instr encodeInstrM = \case 0x73 -> Just Speed -- 's' 0x72 -> Just $ Color Red -- 'r' 0x67 -> Just $ Color Green -- 'g' 0x62 -> Just $ Color Blue -- 'b' _ -> Nothing data UartLed = UartLed { _uart :: U.Uart , _pwmRgb :: P.PWMRgb Byte , _speed :: Speed , _led :: Led , _timer :: Timer } deriving (NFDataX, Generic) makeLenses ''UartLed mkUartLed :: UartLed mkUartLed = UartLed { _uart = U.mkUart 624 , _pwmRgb = P.mkPWMRgb $ fromColor Red , _speed = Low , _led = On , _timer = 0 } uartLed :: RWS U.Rx (First R.Rgb) UartLed () uartLed = do -- Output pwm rgb when Led on isOn <- uses led (== On) when isOn $ tell . First . Just =<< zoom pwmRgb P.pwmRgb -- Check toggle led period <- uses speed toPeriod t <- timer <<%= incrementUnless (== period) when (t == period) $ led %= toggle -- Update color/speed from uart bM <- zoom uart U.read forM_ (bM >>= encodeInstrM) $ \case Speed -> do speed %= increment timer .= 0 Color c -> zoom pwmRgb $ P.setRgb $ fromColor c uartLedS :: HiddenClockResetEnable dom => Signal dom Bit -> Signal dom R.Rgb uartLedS = R.rgb . fmap (fromMaybe (0, 0, 0) . getFirst) . mealy uartLedMealy mkUartLed where uartLedMealy s i = let ((), s', o) = runRWS uartLed (U.Rx i) s in (s', o) {-# NOINLINE topEntity #-} topEntity :: "clk" ::: Clock XilinxSystem -> "rx" ::: Signal XilinxSystem Bit -> "led" ::: Signal XilinxSystem R.Rgb topEntity clk = withClockResetEnable clk rst enableGen uartLedS where rst = unsafeFromHighPolarity $ pure False makeTopEntityWithName 'topEntity "UartLed"