package App where

import BRAM
import GetPut

interface App =
  led :: Bit 1

hexToBits :: Bit 8 -> Maybe (Bit 4)
hexToBits 0x30 = Just 0b0000
hexToBits 0x31 = Just 0b0001
hexToBits 0x32 = Just 0b0010
hexToBits 0x33 = Just 0b0011
hexToBits 0x34 = Just 0b0100
hexToBits 0x35 = Just 0b0101
hexToBits 0x36 = Just 0b0110
hexToBits 0x37 = Just 0b0111
hexToBits 0x38 = Just 0b1000
hexToBits 0x39 = Just 0b1001
hexToBits 0x41 = Just 0b1010
hexToBits 0x42 = Just 0b1011
hexToBits 0x43 = Just 0b1100
hexToBits 0x44 = Just 0b1101
hexToBits 0x45 = Just 0b1110
hexToBits 0x46 = Just 0b1111
hexToBits 0x61 = Just 0b1010
hexToBits 0x62 = Just 0b1011
hexToBits 0x63 = Just 0b1100
hexToBits 0x64 = Just 0b1101
hexToBits 0x65 = Just 0b1110
hexToBits 0x66 = Just 0b1111
hexToBits _ = Nothing

bitsToHex :: Bit 4 -> Bit 8
bitsToHex b =
  if b < 10
  then 0x30 + (0 ++ b)
  else 0x41 + (0 ++ (b - 10))

data State
  = WaitingForAddrHiNybble
  | WaitingForAddrLoNybble (Bit 4)
  | WaitingForRW (Bit 8)
  | WaitingForRead
  | WritingData3 (Bit 12)
  | WritingData2 (Bit 8)
  | WritingData1 (Bit 4)
  | WritingCR
  | WritingLF
  | WaitingForValueNybble1 (Bit 8)
  | WaitingForValueNybble2 (Bit 8) (Bit 4)
  | WaitingForValueNybble3 (Bit 8) (Bit 8)
  | WaitingForValueNybble4 (Bit 8) (Bit 12)
  deriving (Bits)

mkApp :: Get (Bit 8) -> Put (Bit 8) -> Module App
mkApp uartRecv uartSend =
  module
    led :: Reg (Bit 1) <- mkReg 1
    state :: Reg State <- mkReg WaitingForAddrHiNybble
    ebr :: BRAM2Port (Bit 8) (Bit 16) <- mkBRAM2Server
      (defaultValue { memorySize = 256 })

    rules
      "get_hi_nybble": when WaitingForAddrHiNybble <- state ==> do
        byte <- uartRecv.get
        case hexToBits byte of
          Just hiNybble -> do
            uartSend.put byte
            state := WaitingForAddrLoNybble hiNybble
          Nothing -> return ()
      "get_lo_nybble": when WaitingForAddrLoNybble hiNybble <- state ==> do
        byte <- uartRecv.get
        case hexToBits byte of
          Just loNybble -> do
            uartSend.put byte
            state := WaitingForRW (hiNybble ++ loNybble)
            led := 0
          Nothing -> return ()
      "get_rw": when WaitingForRW addr <- state ==> do
        byte <- uartRecv.get
        case byte of
          0x72 {- r -} -> do
            uartSend.put byte
            ebr.portA.request.put (BRAMRequest
              { write = False
              ; responseOnWrite = _
              ; address = addr
              ; datain = _
              })
            state := WaitingForRead
          0x77 {- w -} -> do
            uartSend.put byte
            state := WaitingForValueNybble1 addr
          _ -> return ()
      "get_read": when WaitingForRead <- state ==> do
        resp <- ebr.portA.response.get
        uartSend.put (bitsToHex resp[15:12])
        state := WritingData3 resp[11:0]
      "write_data_3": when WritingData3 resp <- state ==> do
        uartSend.put (bitsToHex resp[11:8])
        state := WritingData2 resp[7:0]
      "write_data_2": when WritingData2 resp <- state ==> do
        uartSend.put (bitsToHex resp[7:4])
        state := WritingData1 resp[3:0]
      "write_data_1": when WritingData1 resp <- state ==> do
        uartSend.put (bitsToHex resp)
        state := WritingCR
      "write_cr": when WritingCR <- state ==> do
        uartSend.put 0x0d
        state := WritingLF
      "write_lf": when WritingLF <- state ==> do
        uartSend.put 0x0a
        state := WaitingForAddrHiNybble
        led := 1
      "get_nybble_1": when WaitingForValueNybble1 addr <- state ==> do
        byte <- uartRecv.get
        case hexToBits byte of
          Just nybble -> do
            uartSend.put byte
            state := WaitingForValueNybble2 addr nybble
          Nothing -> return ()
      "get_nybble_2": when WaitingForValueNybble2 addr value <- state ==> do
        byte <- uartRecv.get
        case hexToBits byte of
          Just nybble -> do
            uartSend.put byte
            state := WaitingForValueNybble3 addr (value ++ nybble)
          Nothing -> return ()
      "get_nybble_3": when WaitingForValueNybble3 addr value <- state ==> do
        byte <- uartRecv.get
        case hexToBits byte of
          Just nybble -> do
            uartSend.put byte
            state := WaitingForValueNybble4 addr (value ++ nybble)
          Nothing -> return ()
      "get_nybble_4": when WaitingForValueNybble4 addr value <- state ==> do
        byte <- uartRecv.get
        case hexToBits byte of
          Just nybble -> do
            uartSend.put byte
            ebr.portA.request.put (BRAMRequest
              { write = True
              ; responseOnWrite = False
              ; address = addr
              ; datain = value ++ nybble
              })
            state := WritingCR
          Nothing -> return ()

    interface App
      led = led

-- vim: set ft=haskell :