add I2C

4 files changed, 253 insertions, 72 deletions

diff --git a/fpga.cabal b/blinker.cabal
index 14ac474..35e0781 100644
--- a/fpga.cabal
+++ b/blinker.cabal
@@ -83,5 +83,5 @@ common common-options
 library
   import: common-options
   hs-source-dirs: src
-  exposed-modules: Main
+  exposed-modules: Blinker
   default-language: Haskell2010
\ No newline at end of file
diff --git a/src/Blinker.hs b/src/Blinker.hs
new file mode 100644
index 0000000..365012a
--- /dev/null
+++ b/src/Blinker.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -option #-}
+module Blinker where
+
+import Clash.Prelude
+import Clash.Annotations.SynthesisAttributes
+import Clash.Cores.UART
+import Control.Monad.Trans.State.Strict
+import I2C (i2cMaster, Message)
+
+
+-- 50 MHz
+createDomain vSystem{vName="Input", vPeriod=20_000}
+
+{-# ANN topEntity
+  (Synthesize
+    { t_name   = "Blinker"
+    , t_inputs = [
+      PortName "CLK0",
+      PortName "UART_RX"
+       ]
+    , t_output = PortName "UART_TX"
+    }) #-}
+topEntity ::
+  "CLK" ::: Clock Input
+    `Annotate` 'StringAttr "chip_pin" "R20"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"3.3-V LVTTL\""
+  -> "RX" ::: Signal Input Bit
+    `Annotate` 'StringAttr
+                "chip_pin" "M9"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"2.5V\""
+  -> "KEY0" ::: Signal Input Bit
+    `Annotate` 'StringAttr
+                "chip_pin" "P11"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"1.2V\""
+  -> "I2C_SCL" ::: BiSignalIn 'PullUp Input (BitSize Bit)
+    `Annotate` 'StringAttr
+                "chip_pin B7"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"2.5V\""
+  -> "I2C_SDA" ::: BiSignalIn 'PullUp Input (BitSize Bit)
+    `Annotate` 'StringAttr
+                "chip_pin G11"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"2.5V\""
+  -> (Signal Input Bit
+    `Annotate` 'StringAttr
+                "chip_pin" "L9"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"2.5V\""
+    ,"I2C_SCL" ::: BiSignalIn 'PullUp Input (BitSize Bit)
+    `Annotate` 'StringAttr
+                "chip_pin B7"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"2.5V\""
+    ,"I2C_SDA" ::: BiSignalIn 'PullUp Input (BitSize Bit)
+    `Annotate` 'StringAttr
+                "chip_pin G11"
+    `Annotate` 'StringAttr
+                "altera_attribute" "-name IO_STANDARD \"2.5V\""
+    )
+topEntity clk rx key0 sclIn sdaIn = (txBit,sclOut,sdaOut)
+  where
+    baud = SNat @115200
+    uart' = exposeClockResetEnable (uart baud) clk resetGen enableGen
+    (rxWord, txBit, ackUART) = uart' rx txM
+    (sclOut, sdaOut, ackI2C) = exposeClockResetEnable (i2cMaster (SNat @20_000) i2cM sclIn sdaIn) clk resetGen enableGen
+    (txM,i2cM) = exposeClockResetEnable mealyS clk resetGen enableGen cpu Initialization (CPUIn <$> key0 <*> (ackUART,ackI2C) <*> rxWord)
+
+
+data CPUIn = CPUIn {
+  key0 :: Bit,
+  ackUART :: Bool,
+  ackI2C :: Bool,
+  rx :: Maybe (BitVector 8)
+}
+
+type CPUOut = (Maybe (BitVector 8),Maybe Message)
+
+data CPUState = Initialization
+                | TransmittingUART (BitVector 8)
+                | TransmittingI2C Message
+                | Listening 
+                deriving (Generic, NFDataX)
+cpu :: CPUIn -> State CPUState CPUOut
+cpu CPUIn{rx=Just rx} = do
+  put $ Transmitting rx
+  return (Nothing, Nothing)
+
+cpu CPUIn{ackUART=True} = put Listening >> return (Nothing, Nothing)
+cpu CPUIn{ackI2C=True} = put Listening >> return (Nothing, Nothing)
+
+cpu _ = get >>= \case
+  Initialization -> put Listening >> return (Nothing, Nothing)
+  TransmittingUART s -> return (Just s, Nothing)
+  TransmittingI2C s -> return (Nothing, Just s)
+  Listening -> return (Nothing, Nothing)
diff --git a/src/I2C.hs b/src/I2C.hs
new file mode 100644
index 0000000..d2b4466
--- /dev/null
+++ b/src/I2C.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE StandaloneDeriving, LambdaCase #-}
+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+module I2C (i2cMaster, Message) where
+
+import Clash.Prelude
+-- import RetroClash.Utils
+-- import RetroClash.Clock
+import Control.Monad.State
+import Data.Maybe (isNothing)
+
+type Message = (BitVector 8, BitVector 8, BitVector 8)
+
+data MessageState
+    = Init        (BitVector 8, BitVector 8, BitVector 8) Init
+    | SendAddr    (BitVector 8, BitVector 8)              (SendBits 8)
+    | SendSubaddr (BitVector 8)                           (SendBits 8)
+    | SendDat                                             (SendBits 8)
+    | Teardown                                            Teardown
+    deriving (Show, Generic, BitPack, NFDataX)
+
+data SendBits n
+    = SendBit SendTransition (BitVector n) (Index n)
+    | SendAck SendTransition
+    deriving (Show, Generic, NFDataX)
+deriving instance (KnownNat n, 1 <= n) => BitPack (SendBits n)
+
+data SendTransition = SDASet | Tick
+  deriving (Show, Enum, Bounded, Eq, Generic, BitPack, NFDataX)
+
+data Init = StartInit | SDALow | SCLLow
+  deriving (Show, Enum, Bounded, Eq, Generic, BitPack, NFDataX)
+
+data Teardown = StartTeardown | SCLHigh | SDAHigh
+  deriving (Show, Enum, Bounded, Eq, Generic, BitPack, NFDataX)
+
+startBit :: (KnownNat n) => BitVector n -> SendBits n
+startBit xs = SendBit minBound xs minBound
+
+succIdx :: (Eq a, Enum a, Bounded a) => a -> Maybe a
+succIdx x | x == maxBound = Nothing
+          | otherwise = Just $ succ x
+
+succBit :: (KnownNat n) => SendBits n -> Maybe (SendBits n)
+succBit (SendBit transition xs i) = Just $ case succIdx transition of
+    Just transition' -> SendBit transition' xs i
+    Nothing -> maybe (SendAck minBound) (SendBit minBound (xs `shiftL` 1)) $ succIdx i
+succBit (SendAck transition) = SendAck <$> succIdx transition
+
+shiftOut :: (KnownNat n) => SendBits n -> (Maybe Bit, Maybe Bit)
+shiftOut (SendBit transition xs i) = (Just $ boolToBit $ transition == Tick, Just $ msb xs)
+shiftOut (SendAck transition) = (Just $ boolToBit $ transition == Tick, Nothing)
+
+-- We only drive clk (clock stretching not implemented), and we never query
+-- peripherals over I2C, so we never actually use sdaIn and sclIn
+i2cNext :: Maybe Message -> Bit -> Bit -> Maybe MessageState -> Maybe MessageState
+i2cNext newMsg _sdaIn _sclIn = \case
+    Nothing                                     -> Init <$> newMsg <*> pure StartInit
+
+    Just (Init        xss@(xs1, xs2, xs3) ramp) -> Just $ maybe (SendAddr    (xs2, xs3) (startBit xs1)) (Init        xss) $ succIdx ramp
+    Just (SendAddr    xss@(xs2, xs3)      b)    -> Just $ maybe (SendSubaddr xs3        (startBit xs2)) (SendAddr    xss) $ succBit b
+    Just (SendSubaddr xss@xs3             b)    -> Just $ maybe (SendDat                (startBit xs3)) (SendSubaddr xss) $ succBit b
+    Just (SendDat                         b)    -> Just $ maybe (Teardown StartTeardown)                SendDat           $ succBit b
+
+    Just (Teardown ramp)                        -> Teardown <$> succIdx ramp
+
+i2cOutput :: Maybe MessageState -> (Maybe Bit, Maybe Bit)
+i2cOutput = \case
+    Nothing                       -> (Just 1, Just 1)
+
+    Just (Init _ StartInit)       -> (Just 1, Just 1)
+    Just (Init _ SDALow)          -> (Just 1, Just 0)
+    Just (Init _ SCLLow)          -> (Just 0, Just 0)
+
+    Just (SendAddr _ b)           -> shiftOut b
+    Just (SendSubaddr _ b)        -> shiftOut b
+    Just (SendDat b)              -> shiftOut b
+
+    Just (Teardown StartTeardown) -> (Just 0, Just 0)
+    Just (Teardown SCLHigh)       -> (Just 1, Just 0)
+    Just (Teardown SDAHigh)       -> (Just 1, Just 1)
+
+mealyState
+   :: (HiddenClockResetEnable dom, NFDataX s)
+   => (i -> State s o) -> s -> (Signal dom i -> Signal dom o)
+mealyState f = mealy step
+  where
+    step s x = let (y, s') = runState (f x) s in (s', y)
+
+mealyStateB
+    :: (HiddenClockResetEnable dom, NFDataX s, Bundle i, Bundle o)
+    => (i -> State s o) -> s -> (Unbundled dom i -> Unbundled dom o)
+mealyStateB f s0 = unbundle . mealyState f s0 . bundle
+
+i2cMaster
+    :: (HiddenClockResetEnable dom, 1 <= i2cRate, KnownNat (DomainPeriod dom), 1 <= DomainPeriod dom)
+    => SNat i2cRate
+    -> "DATA"   ::: Signal dom (Maybe Message)
+    -> "SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
+    -> "SDA_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
+    -> ( "SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
+       , "SDA_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
+       , "READY"   ::: Signal dom Bool
+       )
+i2cMaster i2cRate@SNat msg sclIn sdaIn = (sclOut, sdaOut, ready)
+  where
+    i2cClock = riseRate i2cRate
+    sclIn' = readFromBiSignal sclIn
+    sdaIn' = readFromBiSignal sdaIn
+
+    (sclOut', sdaOut', ready) = mealyStateB step Nothing (i2cClock, msg, sclIn', sdaIn')
+    sclOut = writeToBiSignal sclIn sclOut'
+    sdaOut = writeToBiSignal sdaIn sdaOut'
+
+    step :: (Bool, Maybe Message, Bit, Bit) -> State (Maybe MessageState) (Maybe Bit, Maybe Bit, Bool)
+    step (tick, msg, sclIn, sdaIn) = do
+        s <- get
+        when tick $ modify $ i2cNext msg sdaIn sclIn
+        s' <- get
+        let ready = tick && isNothing s'
+            (sclOut, sdaOut) = i2cOutput s
+        return (sclOut, sdaOut, ready)
+
+
+type HzToPeriod (rate :: Nat) = Seconds 1 `Div` rate
+
+type Seconds      (s  :: Nat) = Milliseconds (1_000 * s)
+type Milliseconds (ms :: Nat) = Microseconds (1_000 * ms)
+type Microseconds (us :: Nat) = Nanoseconds  (1_000 * us)
+type Nanoseconds  (ns :: Nat) = Picoseconds  (1_000 * ns)
+type Picoseconds  (ps :: Nat) = ps
+
+type ClockDivider dom ps = ps `Div` DomainPeriod dom
+
+risePeriod
+    :: forall ps dom. (HiddenClockResetEnable dom, _)
+    => SNat ps
+    -> Signal dom Bool
+risePeriod _ = riseEvery (SNat @(ClockDivider dom ps))
+
+riseRate
+    :: forall rate dom. (HiddenClockResetEnable dom, _)
+    => SNat rate
+    -> Signal dom Bool
+riseRate _ = risePeriod (SNat @(HzToPeriod rate))
\ No newline at end of file
diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644
index 43f4746..0000000
--- a/src/Main.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# OPTIONS_GHC -option #-}
-module Main where
-
-import Clash.Prelude
-import Clash.Annotations.SynthesisAttributes
-import Clash.Cores.UART
-import Data.Char (ord)
-import Control.Monad.Trans.State.Strict
-
--- 50 MHz
-createDomain vSystem{vName="Input", vPeriod=20_000}
-
-{-# ANN topEntity
-  (Synthesize
-    { t_name   = "Main"
-    , t_inputs = [
-      PortName "CLK0",
-      PortName "UART_RX"
-       ]
-    , t_output = PortName "UART_TX"
-    }) #-}
-topEntity ::
-  "CLK" ::: Clock Input
-    `Annotate` 'StringAttr "chip_pin" "R20"
-    `Annotate` 'StringAttr
-                "altera_attribute" "-name IO_STANDARD \"3.3-V LVTTL\""
-  -> "RX" ::: Signal Input Bit
-    `Annotate` 'StringAttr
-                "chip_pin" "M9"
-    `Annotate` 'StringAttr
-                "altera_attribute" "-name IO_STANDARD \"2.5V\""
-  -> "KEY0" ::: Signal Input Bit
-    `Annotate` 'StringAttr
-                "chip_pin" "P11"
-    `Annotate` 'StringAttr
-                "altera_attribute" "-name IO_STANDARD \"1.2V\""
-  -> Signal Input Bit
-    `Annotate` 'StringAttr
-                "chip_pin" "L9"
-    `Annotate` 'StringAttr
-                "altera_attribute" "-name IO_STANDARD \"2.5V\""
-topEntity clk rx key0 = txBit
-  where
-    baud = SNat @115200
-    uart' = exposeClockResetEnable (uart baud) clk resetGen enableGen
-    (rxWord, txBit, ack) = uart' rx txM
-    txM = (exposeClockResetEnable mealyS clk resetGen enableGen) cpu Listening (CPUIn <$> key0 <*> ack <*> rxWord)
-
-
-data CPUIn = CPUIn {
-  key0 :: Bit,
-  ack :: Bool,
-  rx :: Maybe (BitVector 8)
-}
-
-data CPUState = Transmitting (BitVector 8) | Listening deriving (Generic, NFDataX)
-cpu :: CPUIn -> State CPUState (Maybe (BitVector 8))
-cpu CPUIn{rx=Just rx} = do
-  put $ Transmitting $ rx
-  return Nothing
-
-cpu CPUIn{ack=True} = put Listening >> return Nothing
-
-cpu CPUIn{ack=False,rx=Nothing} = get >>= \case 
-  Transmitting s -> return $ Just s
-  Listening -> return Nothing
\ No newline at end of file