SerialDecoder.hs

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module SerialDecoder where

import CLaSH.Prelude
import CLaSH.Prelude.DataFlow
import CLaSH.Prelude.Explicit
import Data.Maybe
import Prelude hiding (repeat, length, replicate)

--import Flow
--import Signal

-- whether or not data is being requested, serial in
type In i = (Bool, i)
-- par out, shift clock, shift register clock inhibit, shift register should load
type Out n i = (Maybe (Vec n i), Bool, Bool, Bool)

data DecodeST n i idx where
  Halted :: DecodeST n i idx
  ReadShift :: Maybe (Vec n i) -> DecodeST n i idx
  RcvBit :: idx -> Vec n i -> Maybe (Vec n i) -> DecodeST n i idx

clockStep :: DecodeST n i idx -> (Bool, DecodeST n i idx)
clockStep = (,) False

decodeSTSizeS :: KnownNat n => DecodeST n i idx -> SNat n
decodeSTSizeS _ = snat

dstSize :: KnownNat n => DecodeST n i idx -> Integer
dstSize d = snatToInteger $ decodeSTSizeS d

-- the actual state is a pair, the shift clock + DecodeST
mooreTransition :: (KnownNat n) => (Bool, DecodeST n i Integer) -> (In i) -> (Bool, DecodeST n i Integer)
mooreTransition (False, x) _ = (True, x)
mooreTransition (_ , _) (False, _) = clockStep Halted
mooreTransition (_, Halted) (True, _) = clockStep $ ReadShift Nothing
mooreTransition (_, st@(ReadShift ov)) _ = clockStep $ RcvBit (dstSize st) (replicate (decodeSTSizeS st) undefined) ov
mooreTransition (_, (RcvBit idx v _)) (_, i) | 0 == (fromEnum idx) = clockStep $ ReadShift (Just $ replace 0 i v)
mooreTransition (_, (RcvBit idx v ov)) (_, i) = clockStep $ RcvBit (pred idx) (replace idx i v) ov

mooreOutput :: KnownNat n => (Bool, DecodeST n i idx) -> Out n i
mooreOutput (clk, Halted) = (Nothing, clk, True, True)
mooreOutput (clk, (ReadShift ov)) = (ov, clk, True, False)
mooreOutput (clk, (RcvBit _ _ ov)) = (ov, clk, False, True)

serialDecoder' :: (KnownNat n) => SNat n -> SClock clk -> Unbundled' clk (In i) -> Unbundled' clk (Out n i)
serialDecoder' n clk = mooreB' clk mooreTransition mooreOutput (False, Halted)



-- MAIN

type IOClock = Clk "io" 2000

ioclock :: SClock IOClock
ioclock = sclock

type IOSignal a = Signal' IOClock a

ioRegister :: a -> IOSignal a -> IOSignal a
ioRegister a s = register' ioclock a s

type IOBundled' a = Unbundled' IOClock a

newtype Board wc_ins wc_outs = Board {
  boardF :: (KnownNat wc_ins, KnownNat wc_outs) =>
            IOSignal (BitVector wc_ins) ->
            IOBundled' (LEDs, BitVector wc_outs) }

type LEDs  = BitVector 5

topLevel :: Board 1 7
topLevel = Board (\ ins -> let decode = serialDecoder' d8 ioclock
                               inSig = (unpack :: Bit -> Bool) <$> ins
                               (pout, shclk, inhout, modeout) = decode $ ((,) $ pure True) inSig
                               pout' = fromMaybe <$> pure (repeat False) <*> pout
                               poutB = (pack :: Vec 8 Bool -> BitVector 8) <$> pout'
                               shclkB = (pack :: Bool -> Bit) <$> shclk
                               inhoutB = (pack :: Bool -> Bit) <$> inhout
                               modeoutB = (pack :: Bool -> Bit) <$> modeout
                               shiftOutB = (++#) <$> shclkB <*> ((++#) <$> inhoutB <*> modeoutB)
                               ledsOut = slice <$> pure d4 <*> pure d0 <*> poutB
                               wingsOut = (++#) <$> shiftOutB <*> pure ($$(bLit "0000") :: BitVector 4)
                             in (ledsOut, wingsOut))

{-# ANN topEntity
  (defTop {
    t_name = "clash",
    t_inputs = ["wing_c_in"],
    t_outputs = ["leds", "wing_c_out"],
    t_extraIn = [("reset_switch", 1),
                 ("master_osc", 1)],
    t_clocks = [ClockSource {
                  c_name  = "main_clock",
                  c_inp   = [("crystal_in", "master_osc(0)")],
                  c_outp  = [("system_clk", show systemClock),
                             ("io_clk", show (sclock :: SClock IOClock))],
                  c_reset = Just ("master_reset", "reset_switch(0)"),
                  c_lock  = "locked",
                  c_sync  = False }]
  }) #-}
topEntity = boardF topLevel