-
Notifications
You must be signed in to change notification settings - Fork 3
/
UartLed.hs
109 lines (92 loc) · 2.61 KB
/
UartLed.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
{-# 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"