{-# LANGUAGE StandaloneDeriving, LambdaCase #-}
{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}
module RetroClash.I2C (i2cMaster) where

import Clash.Prelude
import RetroClash.Utils
import RetroClash.Clock
import Control.Monad.State
import Data.Maybe (isJust, 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 (Int -> MessageState -> ShowS
[MessageState] -> ShowS
MessageState -> String
(Int -> MessageState -> ShowS)
-> (MessageState -> String)
-> ([MessageState] -> ShowS)
-> Show MessageState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageState] -> ShowS
$cshowList :: [MessageState] -> ShowS
show :: MessageState -> String
$cshow :: MessageState -> String
showsPrec :: Int -> MessageState -> ShowS
$cshowsPrec :: Int -> MessageState -> ShowS
Show, (forall x. MessageState -> Rep MessageState x)
-> (forall x. Rep MessageState x -> MessageState)
-> Generic MessageState
forall x. Rep MessageState x -> MessageState
forall x. MessageState -> Rep MessageState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MessageState x -> MessageState
$cfrom :: forall x. MessageState -> Rep MessageState x
Generic, KnownNat (BitSize MessageState)
KnownNat (BitSize MessageState)
-> (MessageState -> BitVector (BitSize MessageState))
-> (BitVector (BitSize MessageState) -> MessageState)
-> BitPack MessageState
BitVector (BitSize MessageState) -> MessageState
MessageState -> BitVector (BitSize MessageState)
forall a.
KnownNat (BitSize a)
-> (a -> BitVector (BitSize a))
-> (BitVector (BitSize a) -> a)
-> BitPack a
unpack :: BitVector (BitSize MessageState) -> MessageState
$cunpack :: BitVector (BitSize MessageState) -> MessageState
pack :: MessageState -> BitVector (BitSize MessageState)
$cpack :: MessageState -> BitVector (BitSize MessageState)
$cp1BitPack :: KnownNat (BitSize MessageState)
BitPack, HasCallStack => String -> MessageState
MessageState -> Bool
MessageState -> ()
MessageState -> MessageState
(HasCallStack => String -> MessageState)
-> (MessageState -> Bool)
-> (MessageState -> MessageState)
-> (MessageState -> ())
-> NFDataX MessageState
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
rnfX :: MessageState -> ()
$crnfX :: MessageState -> ()
ensureSpine :: MessageState -> MessageState
$censureSpine :: MessageState -> MessageState
hasUndefined :: MessageState -> Bool
$chasUndefined :: MessageState -> Bool
deepErrorX :: String -> MessageState
$cdeepErrorX :: HasCallStack => String -> MessageState
NFDataX)

data SendBits n
    = SendBit SendTransition (BitVector n) (Index n)
    | SendAck SendTransition
    deriving (Int -> SendBits n -> ShowS
[SendBits n] -> ShowS
SendBits n -> String
(Int -> SendBits n -> ShowS)
-> (SendBits n -> String)
-> ([SendBits n] -> ShowS)
-> Show (SendBits n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: Nat). KnownNat n => Int -> SendBits n -> ShowS
forall (n :: Nat). KnownNat n => [SendBits n] -> ShowS
forall (n :: Nat). KnownNat n => SendBits n -> String
showList :: [SendBits n] -> ShowS
$cshowList :: forall (n :: Nat). KnownNat n => [SendBits n] -> ShowS
show :: SendBits n -> String
$cshow :: forall (n :: Nat). KnownNat n => SendBits n -> String
showsPrec :: Int -> SendBits n -> ShowS
$cshowsPrec :: forall (n :: Nat). KnownNat n => Int -> SendBits n -> ShowS
Show, (forall x. SendBits n -> Rep (SendBits n) x)
-> (forall x. Rep (SendBits n) x -> SendBits n)
-> Generic (SendBits n)
forall x. Rep (SendBits n) x -> SendBits n
forall x. SendBits n -> Rep (SendBits n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (n :: Nat) x. Rep (SendBits n) x -> SendBits n
forall (n :: Nat) x. SendBits n -> Rep (SendBits n) x
$cto :: forall (n :: Nat) x. Rep (SendBits n) x -> SendBits n
$cfrom :: forall (n :: Nat) x. SendBits n -> Rep (SendBits n) x
Generic, HasCallStack => String -> SendBits n
SendBits n -> Bool
SendBits n -> ()
SendBits n -> SendBits n
(HasCallStack => String -> SendBits n)
-> (SendBits n -> Bool)
-> (SendBits n -> SendBits n)
-> (SendBits n -> ())
-> NFDataX (SendBits n)
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
forall (n :: Nat).
(KnownNat n, HasCallStack) =>
String -> SendBits n
forall (n :: Nat). KnownNat n => SendBits n -> Bool
forall (n :: Nat). KnownNat n => SendBits n -> ()
forall (n :: Nat). KnownNat n => SendBits n -> SendBits n
rnfX :: SendBits n -> ()
$crnfX :: forall (n :: Nat). KnownNat n => SendBits n -> ()
ensureSpine :: SendBits n -> SendBits n
$censureSpine :: forall (n :: Nat). KnownNat n => SendBits n -> SendBits n
hasUndefined :: SendBits n -> Bool
$chasUndefined :: forall (n :: Nat). KnownNat n => SendBits n -> Bool
deepErrorX :: String -> SendBits n
$cdeepErrorX :: forall (n :: Nat).
(KnownNat n, HasCallStack) =>
String -> SendBits n
NFDataX)
deriving instance (KnownNat n, 1 <= n) => BitPack (SendBits n)

data SendTransition = SDASet | Tick
  deriving (Int -> SendTransition -> ShowS
[SendTransition] -> ShowS
SendTransition -> String
(Int -> SendTransition -> ShowS)
-> (SendTransition -> String)
-> ([SendTransition] -> ShowS)
-> Show SendTransition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SendTransition] -> ShowS
$cshowList :: [SendTransition] -> ShowS
show :: SendTransition -> String
$cshow :: SendTransition -> String
showsPrec :: Int -> SendTransition -> ShowS
$cshowsPrec :: Int -> SendTransition -> ShowS
Show, Int -> SendTransition
SendTransition -> Int
SendTransition -> [SendTransition]
SendTransition -> SendTransition
SendTransition -> SendTransition -> [SendTransition]
SendTransition
-> SendTransition -> SendTransition -> [SendTransition]
(SendTransition -> SendTransition)
-> (SendTransition -> SendTransition)
-> (Int -> SendTransition)
-> (SendTransition -> Int)
-> (SendTransition -> [SendTransition])
-> (SendTransition -> SendTransition -> [SendTransition])
-> (SendTransition -> SendTransition -> [SendTransition])
-> (SendTransition
    -> SendTransition -> SendTransition -> [SendTransition])
-> Enum SendTransition
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SendTransition
-> SendTransition -> SendTransition -> [SendTransition]
$cenumFromThenTo :: SendTransition
-> SendTransition -> SendTransition -> [SendTransition]
enumFromTo :: SendTransition -> SendTransition -> [SendTransition]
$cenumFromTo :: SendTransition -> SendTransition -> [SendTransition]
enumFromThen :: SendTransition -> SendTransition -> [SendTransition]
$cenumFromThen :: SendTransition -> SendTransition -> [SendTransition]
enumFrom :: SendTransition -> [SendTransition]
$cenumFrom :: SendTransition -> [SendTransition]
fromEnum :: SendTransition -> Int
$cfromEnum :: SendTransition -> Int
toEnum :: Int -> SendTransition
$ctoEnum :: Int -> SendTransition
pred :: SendTransition -> SendTransition
$cpred :: SendTransition -> SendTransition
succ :: SendTransition -> SendTransition
$csucc :: SendTransition -> SendTransition
Enum, SendTransition
SendTransition -> SendTransition -> Bounded SendTransition
forall a. a -> a -> Bounded a
maxBound :: SendTransition
$cmaxBound :: SendTransition
minBound :: SendTransition
$cminBound :: SendTransition
Bounded, SendTransition -> SendTransition -> Bool
(SendTransition -> SendTransition -> Bool)
-> (SendTransition -> SendTransition -> Bool) -> Eq SendTransition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SendTransition -> SendTransition -> Bool
$c/= :: SendTransition -> SendTransition -> Bool
== :: SendTransition -> SendTransition -> Bool
$c== :: SendTransition -> SendTransition -> Bool
Eq, (forall x. SendTransition -> Rep SendTransition x)
-> (forall x. Rep SendTransition x -> SendTransition)
-> Generic SendTransition
forall x. Rep SendTransition x -> SendTransition
forall x. SendTransition -> Rep SendTransition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SendTransition x -> SendTransition
$cfrom :: forall x. SendTransition -> Rep SendTransition x
Generic, KnownNat (BitSize SendTransition)
KnownNat (BitSize SendTransition)
-> (SendTransition -> BitVector (BitSize SendTransition))
-> (BitVector (BitSize SendTransition) -> SendTransition)
-> BitPack SendTransition
BitVector (BitSize SendTransition) -> SendTransition
SendTransition -> BitVector (BitSize SendTransition)
forall a.
KnownNat (BitSize a)
-> (a -> BitVector (BitSize a))
-> (BitVector (BitSize a) -> a)
-> BitPack a
unpack :: BitVector (BitSize SendTransition) -> SendTransition
$cunpack :: BitVector (BitSize SendTransition) -> SendTransition
pack :: SendTransition -> BitVector (BitSize SendTransition)
$cpack :: SendTransition -> BitVector (BitSize SendTransition)
$cp1BitPack :: KnownNat (BitSize SendTransition)
BitPack, HasCallStack => String -> SendTransition
SendTransition -> Bool
SendTransition -> ()
SendTransition -> SendTransition
(HasCallStack => String -> SendTransition)
-> (SendTransition -> Bool)
-> (SendTransition -> SendTransition)
-> (SendTransition -> ())
-> NFDataX SendTransition
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
rnfX :: SendTransition -> ()
$crnfX :: SendTransition -> ()
ensureSpine :: SendTransition -> SendTransition
$censureSpine :: SendTransition -> SendTransition
hasUndefined :: SendTransition -> Bool
$chasUndefined :: SendTransition -> Bool
deepErrorX :: String -> SendTransition
$cdeepErrorX :: HasCallStack => String -> SendTransition
NFDataX)

data Init = StartInit | SDALow | SCLLow
  deriving (Int -> Init -> ShowS
[Init] -> ShowS
Init -> String
(Int -> Init -> ShowS)
-> (Init -> String) -> ([Init] -> ShowS) -> Show Init
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Init] -> ShowS
$cshowList :: [Init] -> ShowS
show :: Init -> String
$cshow :: Init -> String
showsPrec :: Int -> Init -> ShowS
$cshowsPrec :: Int -> Init -> ShowS
Show, Int -> Init
Init -> Int
Init -> [Init]
Init -> Init
Init -> Init -> [Init]
Init -> Init -> Init -> [Init]
(Init -> Init)
-> (Init -> Init)
-> (Int -> Init)
-> (Init -> Int)
-> (Init -> [Init])
-> (Init -> Init -> [Init])
-> (Init -> Init -> [Init])
-> (Init -> Init -> Init -> [Init])
-> Enum Init
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Init -> Init -> Init -> [Init]
$cenumFromThenTo :: Init -> Init -> Init -> [Init]
enumFromTo :: Init -> Init -> [Init]
$cenumFromTo :: Init -> Init -> [Init]
enumFromThen :: Init -> Init -> [Init]
$cenumFromThen :: Init -> Init -> [Init]
enumFrom :: Init -> [Init]
$cenumFrom :: Init -> [Init]
fromEnum :: Init -> Int
$cfromEnum :: Init -> Int
toEnum :: Int -> Init
$ctoEnum :: Int -> Init
pred :: Init -> Init
$cpred :: Init -> Init
succ :: Init -> Init
$csucc :: Init -> Init
Enum, Init
Init -> Init -> Bounded Init
forall a. a -> a -> Bounded a
maxBound :: Init
$cmaxBound :: Init
minBound :: Init
$cminBound :: Init
Bounded, Init -> Init -> Bool
(Init -> Init -> Bool) -> (Init -> Init -> Bool) -> Eq Init
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Init -> Init -> Bool
$c/= :: Init -> Init -> Bool
== :: Init -> Init -> Bool
$c== :: Init -> Init -> Bool
Eq, (forall x. Init -> Rep Init x)
-> (forall x. Rep Init x -> Init) -> Generic Init
forall x. Rep Init x -> Init
forall x. Init -> Rep Init x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Init x -> Init
$cfrom :: forall x. Init -> Rep Init x
Generic, KnownNat (BitSize Init)
KnownNat (BitSize Init)
-> (Init -> BitVector (BitSize Init))
-> (BitVector (BitSize Init) -> Init)
-> BitPack Init
BitVector (BitSize Init) -> Init
Init -> BitVector (BitSize Init)
forall a.
KnownNat (BitSize a)
-> (a -> BitVector (BitSize a))
-> (BitVector (BitSize a) -> a)
-> BitPack a
unpack :: BitVector (BitSize Init) -> Init
$cunpack :: BitVector (BitSize Init) -> Init
pack :: Init -> BitVector (BitSize Init)
$cpack :: Init -> BitVector (BitSize Init)
$cp1BitPack :: KnownNat (BitSize Init)
BitPack, HasCallStack => String -> Init
Init -> Bool
Init -> ()
Init -> Init
(HasCallStack => String -> Init)
-> (Init -> Bool) -> (Init -> Init) -> (Init -> ()) -> NFDataX Init
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
rnfX :: Init -> ()
$crnfX :: Init -> ()
ensureSpine :: Init -> Init
$censureSpine :: Init -> Init
hasUndefined :: Init -> Bool
$chasUndefined :: Init -> Bool
deepErrorX :: String -> Init
$cdeepErrorX :: HasCallStack => String -> Init
NFDataX)

data Teardown = StartTeardown | SCLHigh | SDAHigh
  deriving (Int -> Teardown -> ShowS
[Teardown] -> ShowS
Teardown -> String
(Int -> Teardown -> ShowS)
-> (Teardown -> String) -> ([Teardown] -> ShowS) -> Show Teardown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Teardown] -> ShowS
$cshowList :: [Teardown] -> ShowS
show :: Teardown -> String
$cshow :: Teardown -> String
showsPrec :: Int -> Teardown -> ShowS
$cshowsPrec :: Int -> Teardown -> ShowS
Show, Int -> Teardown
Teardown -> Int
Teardown -> [Teardown]
Teardown -> Teardown
Teardown -> Teardown -> [Teardown]
Teardown -> Teardown -> Teardown -> [Teardown]
(Teardown -> Teardown)
-> (Teardown -> Teardown)
-> (Int -> Teardown)
-> (Teardown -> Int)
-> (Teardown -> [Teardown])
-> (Teardown -> Teardown -> [Teardown])
-> (Teardown -> Teardown -> [Teardown])
-> (Teardown -> Teardown -> Teardown -> [Teardown])
-> Enum Teardown
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Teardown -> Teardown -> Teardown -> [Teardown]
$cenumFromThenTo :: Teardown -> Teardown -> Teardown -> [Teardown]
enumFromTo :: Teardown -> Teardown -> [Teardown]
$cenumFromTo :: Teardown -> Teardown -> [Teardown]
enumFromThen :: Teardown -> Teardown -> [Teardown]
$cenumFromThen :: Teardown -> Teardown -> [Teardown]
enumFrom :: Teardown -> [Teardown]
$cenumFrom :: Teardown -> [Teardown]
fromEnum :: Teardown -> Int
$cfromEnum :: Teardown -> Int
toEnum :: Int -> Teardown
$ctoEnum :: Int -> Teardown
pred :: Teardown -> Teardown
$cpred :: Teardown -> Teardown
succ :: Teardown -> Teardown
$csucc :: Teardown -> Teardown
Enum, Teardown
Teardown -> Teardown -> Bounded Teardown
forall a. a -> a -> Bounded a
maxBound :: Teardown
$cmaxBound :: Teardown
minBound :: Teardown
$cminBound :: Teardown
Bounded, Teardown -> Teardown -> Bool
(Teardown -> Teardown -> Bool)
-> (Teardown -> Teardown -> Bool) -> Eq Teardown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Teardown -> Teardown -> Bool
$c/= :: Teardown -> Teardown -> Bool
== :: Teardown -> Teardown -> Bool
$c== :: Teardown -> Teardown -> Bool
Eq, (forall x. Teardown -> Rep Teardown x)
-> (forall x. Rep Teardown x -> Teardown) -> Generic Teardown
forall x. Rep Teardown x -> Teardown
forall x. Teardown -> Rep Teardown x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Teardown x -> Teardown
$cfrom :: forall x. Teardown -> Rep Teardown x
Generic, KnownNat (BitSize Teardown)
KnownNat (BitSize Teardown)
-> (Teardown -> BitVector (BitSize Teardown))
-> (BitVector (BitSize Teardown) -> Teardown)
-> BitPack Teardown
BitVector (BitSize Teardown) -> Teardown
Teardown -> BitVector (BitSize Teardown)
forall a.
KnownNat (BitSize a)
-> (a -> BitVector (BitSize a))
-> (BitVector (BitSize a) -> a)
-> BitPack a
unpack :: BitVector (BitSize Teardown) -> Teardown
$cunpack :: BitVector (BitSize Teardown) -> Teardown
pack :: Teardown -> BitVector (BitSize Teardown)
$cpack :: Teardown -> BitVector (BitSize Teardown)
$cp1BitPack :: KnownNat (BitSize Teardown)
BitPack, HasCallStack => String -> Teardown
Teardown -> Bool
Teardown -> ()
Teardown -> Teardown
(HasCallStack => String -> Teardown)
-> (Teardown -> Bool)
-> (Teardown -> Teardown)
-> (Teardown -> ())
-> NFDataX Teardown
forall a.
(HasCallStack => String -> a)
-> (a -> Bool) -> (a -> a) -> (a -> ()) -> NFDataX a
rnfX :: Teardown -> ()
$crnfX :: Teardown -> ()
ensureSpine :: Teardown -> Teardown
$censureSpine :: Teardown -> Teardown
hasUndefined :: Teardown -> Bool
$chasUndefined :: Teardown -> Bool
deepErrorX :: String -> Teardown
$cdeepErrorX :: HasCallStack => String -> Teardown
NFDataX)

startBit :: (KnownNat n) => BitVector n -> SendBits n
startBit :: BitVector n -> SendBits n
startBit BitVector n
xs = SendTransition -> BitVector n -> Index n -> SendBits n
forall (n :: Nat).
SendTransition -> BitVector n -> Index n -> SendBits n
SendBit SendTransition
forall a. Bounded a => a
minBound BitVector n
xs Index n
forall a. Bounded a => a
minBound

succBit :: (KnownNat n) => SendBits n -> Maybe (SendBits n)
succBit :: SendBits n -> Maybe (SendBits n)
succBit (SendBit SendTransition
transition BitVector n
xs Index n
i) = SendBits n -> Maybe (SendBits n)
forall a. a -> Maybe a
Just (SendBits n -> Maybe (SendBits n))
-> SendBits n -> Maybe (SendBits n)
forall a b. (a -> b) -> a -> b
$ case SendTransition -> Maybe SendTransition
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
succIdx SendTransition
transition of
    Just SendTransition
transition' -> SendTransition -> BitVector n -> Index n -> SendBits n
forall (n :: Nat).
SendTransition -> BitVector n -> Index n -> SendBits n
SendBit SendTransition
transition' BitVector n
xs Index n
i
    Maybe SendTransition
Nothing -> SendBits n
-> (Index n -> SendBits n) -> Maybe (Index n) -> SendBits n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SendTransition -> SendBits n
forall (n :: Nat). SendTransition -> SendBits n
SendAck SendTransition
forall a. Bounded a => a
minBound) (SendTransition -> BitVector n -> Index n -> SendBits n
forall (n :: Nat).
SendTransition -> BitVector n -> Index n -> SendBits n
SendBit SendTransition
forall a. Bounded a => a
minBound (BitVector n
xs BitVector n -> Int -> BitVector n
forall a. Bits a => a -> Int -> a
`shiftL` Int
1)) (Maybe (Index n) -> SendBits n) -> Maybe (Index n) -> SendBits n
forall a b. (a -> b) -> a -> b
$ Index n -> Maybe (Index n)
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
succIdx Index n
i
succBit (SendAck SendTransition
transition) = SendTransition -> SendBits n
forall (n :: Nat). SendTransition -> SendBits n
SendAck (SendTransition -> SendBits n)
-> Maybe SendTransition -> Maybe (SendBits n)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> SendTransition -> Maybe SendTransition
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
succIdx SendTransition
transition

shiftOut :: (KnownNat n) => SendBits n -> (Maybe Bit, Maybe Bit)
shiftOut :: SendBits n -> (Maybe Bit, Maybe Bit)
shiftOut (SendBit SendTransition
transition BitVector n
xs Index n
i) = (Bit -> Maybe Bit
forall a. a -> Maybe a
Just (Bit -> Maybe Bit) -> Bit -> Maybe Bit
forall a b. (a -> b) -> a -> b
$ Bool -> Bit
boolToBit (Bool -> Bit) -> Bool -> Bit
forall a b. (a -> b) -> a -> b
$ SendTransition
transition SendTransition -> SendTransition -> Bool
forall a. Eq a => a -> a -> Bool
== SendTransition
Tick, Bit -> Maybe Bit
forall a. a -> Maybe a
Just (Bit -> Maybe Bit) -> Bit -> Maybe Bit
forall a b. (a -> b) -> a -> b
$ BitVector n -> Bit
forall a. BitPack a => a -> Bit
msb BitVector n
xs)
shiftOut (SendAck SendTransition
transition) = (Bit -> Maybe Bit
forall a. a -> Maybe a
Just (Bit -> Maybe Bit) -> Bit -> Maybe Bit
forall a b. (a -> b) -> a -> b
$ Bool -> Bit
boolToBit (Bool -> Bit) -> Bool -> Bit
forall a b. (a -> b) -> a -> b
$ SendTransition
transition SendTransition -> SendTransition -> Bool
forall a. Eq a => a -> a -> Bool
== SendTransition
Tick, Maybe Bit
forall a. Maybe a
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 :: Maybe Message
-> Bit -> Bit -> Maybe MessageState -> Maybe MessageState
i2cNext Maybe Message
newMsg Bit
_sdaIn Bit
_sclIn = \case
    Maybe MessageState
Nothing                                     -> Message -> Init -> MessageState
Init (Message -> Init -> MessageState)
-> Maybe Message -> Maybe (Init -> MessageState)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Message
newMsg Maybe (Init -> MessageState) -> Maybe Init -> Maybe MessageState
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Init -> Maybe Init
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Init
StartInit

    Just (Init        xss :: Message
xss@(BitVector 8
xs1, BitVector 8
xs2, BitVector 8
xs3) Init
ramp) -> MessageState -> Maybe MessageState
forall a. a -> Maybe a
Just (MessageState -> Maybe MessageState)
-> MessageState -> Maybe MessageState
forall a b. (a -> b) -> a -> b
$ MessageState
-> (Init -> MessageState) -> Maybe Init -> MessageState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((BitVector 8, BitVector 8) -> SendBits 8 -> MessageState
SendAddr    (BitVector 8
xs2, BitVector 8
xs3) (BitVector 8 -> SendBits 8
forall (n :: Nat). KnownNat n => BitVector n -> SendBits n
startBit BitVector 8
xs1)) (Message -> Init -> MessageState
Init        Message
xss) (Maybe Init -> MessageState) -> Maybe Init -> MessageState
forall a b. (a -> b) -> a -> b
$ Init -> Maybe Init
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
succIdx Init
ramp
    Just (SendAddr    xss :: (BitVector 8, BitVector 8)
xss@(BitVector 8
xs2, BitVector 8
xs3)      SendBits 8
b)    -> MessageState -> Maybe MessageState
forall a. a -> Maybe a
Just (MessageState -> Maybe MessageState)
-> MessageState -> Maybe MessageState
forall a b. (a -> b) -> a -> b
$ MessageState
-> (SendBits 8 -> MessageState)
-> Maybe (SendBits 8)
-> MessageState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BitVector 8 -> SendBits 8 -> MessageState
SendSubaddr BitVector 8
xs3        (BitVector 8 -> SendBits 8
forall (n :: Nat). KnownNat n => BitVector n -> SendBits n
startBit BitVector 8
xs2)) ((BitVector 8, BitVector 8) -> SendBits 8 -> MessageState
SendAddr    (BitVector 8, BitVector 8)
xss) (Maybe (SendBits 8) -> MessageState)
-> Maybe (SendBits 8) -> MessageState
forall a b. (a -> b) -> a -> b
$ SendBits 8 -> Maybe (SendBits 8)
forall (n :: Nat). KnownNat n => SendBits n -> Maybe (SendBits n)
succBit SendBits 8
b
    Just (SendSubaddr xss :: BitVector 8
xss@BitVector 8
xs3             SendBits 8
b)    -> MessageState -> Maybe MessageState
forall a. a -> Maybe a
Just (MessageState -> Maybe MessageState)
-> MessageState -> Maybe MessageState
forall a b. (a -> b) -> a -> b
$ MessageState
-> (SendBits 8 -> MessageState)
-> Maybe (SendBits 8)
-> MessageState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SendBits 8 -> MessageState
SendDat                (BitVector 8 -> SendBits 8
forall (n :: Nat). KnownNat n => BitVector n -> SendBits n
startBit BitVector 8
xs3)) (BitVector 8 -> SendBits 8 -> MessageState
SendSubaddr BitVector 8
xss) (Maybe (SendBits 8) -> MessageState)
-> Maybe (SendBits 8) -> MessageState
forall a b. (a -> b) -> a -> b
$ SendBits 8 -> Maybe (SendBits 8)
forall (n :: Nat). KnownNat n => SendBits n -> Maybe (SendBits n)
succBit SendBits 8
b
    Just (SendDat                         SendBits 8
b)    -> MessageState -> Maybe MessageState
forall a. a -> Maybe a
Just (MessageState -> Maybe MessageState)
-> MessageState -> Maybe MessageState
forall a b. (a -> b) -> a -> b
$ MessageState
-> (SendBits 8 -> MessageState)
-> Maybe (SendBits 8)
-> MessageState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Teardown -> MessageState
Teardown Teardown
StartTeardown)                SendBits 8 -> MessageState
SendDat           (Maybe (SendBits 8) -> MessageState)
-> Maybe (SendBits 8) -> MessageState
forall a b. (a -> b) -> a -> b
$ SendBits 8 -> Maybe (SendBits 8)
forall (n :: Nat). KnownNat n => SendBits n -> Maybe (SendBits n)
succBit SendBits 8
b

    Just (Teardown Teardown
ramp)                        -> Teardown -> MessageState
Teardown (Teardown -> MessageState) -> Maybe Teardown -> Maybe MessageState
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Teardown -> Maybe Teardown
forall a. (Eq a, Enum a, Bounded a) => a -> Maybe a
succIdx Teardown
ramp

i2cOutput :: Maybe MessageState -> (Maybe Bit, Maybe Bit)
i2cOutput :: Maybe MessageState -> (Maybe Bit, Maybe Bit)
i2cOutput = \case
    Maybe MessageState
Nothing                       -> (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1, Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1)

    Just (Init Message
_ Init
StartInit)       -> (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1, Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1)
    Just (Init Message
_ Init
SDALow)          -> (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1, Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
0)
    Just (Init Message
_ Init
SCLLow)          -> (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
0, Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
0)

    Just (SendAddr (BitVector 8, BitVector 8)
_ SendBits 8
b)           -> SendBits 8 -> (Maybe Bit, Maybe Bit)
forall (n :: Nat).
KnownNat n =>
SendBits n -> (Maybe Bit, Maybe Bit)
shiftOut SendBits 8
b
    Just (SendSubaddr BitVector 8
_ SendBits 8
b)        -> SendBits 8 -> (Maybe Bit, Maybe Bit)
forall (n :: Nat).
KnownNat n =>
SendBits n -> (Maybe Bit, Maybe Bit)
shiftOut SendBits 8
b
    Just (SendDat SendBits 8
b)              -> SendBits 8 -> (Maybe Bit, Maybe Bit)
forall (n :: Nat).
KnownNat n =>
SendBits n -> (Maybe Bit, Maybe Bit)
shiftOut SendBits 8
b

    Just (Teardown Teardown
StartTeardown) -> (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
0, Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
0)
    Just (Teardown Teardown
SCLHigh)       -> (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1, Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
0)
    Just (Teardown Teardown
SDAHigh)       -> (Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1, Bit -> Maybe Bit
forall a. a -> Maybe a
Just Bit
1)

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 :: SNat i2cRate
-> ("DATA" ::: Signal dom (Maybe Message))
-> ("SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit))
-> ("SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit))
-> ("SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit),
    "SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit),
    "READY" ::: Signal dom Bool)
i2cMaster i2cRate :: SNat i2cRate
i2cRate@SNat i2cRate
SNat "DATA" ::: Signal dom (Maybe Message)
msg "SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
sclIn "SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
sdaIn = ("SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
sclOut, "SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
sdaOut, "READY" ::: Signal dom Bool
ready)
  where
    i2cClock :: "READY" ::: Signal dom Bool
i2cClock = SNat i2cRate -> "READY" ::: Signal dom Bool
forall (rate :: Nat) (dom :: Symbol).
(HiddenClockResetEnable dom, KnownNat rate,
 KnownNat (DomainConfigurationPeriod (KnownConf dom)),
 (1 <=? rate) ~ 'True,
 (1 <=? DomainConfigurationPeriod (KnownConf dom)) ~ 'True) =>
SNat rate -> Signal dom Bool
riseRate SNat i2cRate
i2cRate
    sclIn' :: Signal dom Bit
sclIn' = ("SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit))
-> Signal dom Bit
forall a (ds :: BiSignalDefault) (d :: Symbol).
(HasCallStack, BitPack a) =>
BiSignalIn ds d (BitSize a) -> Signal d a
readFromBiSignal "SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
sclIn
    sdaIn' :: Signal dom Bit
sdaIn' = ("SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit))
-> Signal dom Bit
forall a (ds :: BiSignalDefault) (d :: Symbol).
(HasCallStack, BitPack a) =>
BiSignalIn ds d (BitSize a) -> Signal d a
readFromBiSignal "SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
sdaIn

    (Signal dom (Maybe Bit)
sclOut', Signal dom (Maybe Bit)
sdaOut', "READY" ::: Signal dom Bool
ready) = ((Bool, Maybe Message, Bit, Bit)
 -> State (Maybe MessageState) (Maybe Bit, Maybe Bit, Bool))
-> Maybe MessageState
-> Unbundled dom (Bool, Maybe Message, Bit, Bit)
-> Unbundled dom (Maybe Bit, Maybe Bit, Bool)
forall (dom :: Symbol) s i o.
(HiddenClockResetEnable dom, NFDataX s, Bundle i, Bundle o) =>
(i -> State s o) -> s -> Unbundled dom i -> Unbundled dom o
mealyStateB (Bool, Maybe Message, Bit, Bit)
-> State (Maybe MessageState) (Maybe Bit, Maybe Bit, Bool)
step Maybe MessageState
forall a. Maybe a
Nothing ("READY" ::: Signal dom Bool
i2cClock, "DATA" ::: Signal dom (Maybe Message)
msg, Signal dom Bit
sclIn', Signal dom Bit
sdaIn')
    sclOut :: "SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
sclOut = ("SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit))
-> Signal dom (Maybe Bit)
-> "SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
forall a (ds :: BiSignalDefault) (d :: Symbol).
(HasCallStack, BitPack a) =>
BiSignalIn ds d (BitSize a)
-> Signal d (Maybe a) -> BiSignalOut ds d (BitSize a)
writeToBiSignal "SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
sclIn Signal dom (Maybe Bit)
sclOut'
    sdaOut :: "SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
sdaOut = ("SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit))
-> Signal dom (Maybe Bit)
-> "SCL_OUT" ::: BiSignalOut 'PullUp dom (BitSize Bit)
forall a (ds :: BiSignalDefault) (d :: Symbol).
(HasCallStack, BitPack a) =>
BiSignalIn ds d (BitSize a)
-> Signal d (Maybe a) -> BiSignalOut ds d (BitSize a)
writeToBiSignal "SCL_IN" ::: BiSignalIn 'PullUp dom (BitSize Bit)
sdaIn Signal dom (Maybe Bit)
sdaOut'

    step :: (Bool, Maybe Message, Bit, Bit) -> State (Maybe MessageState) (Maybe Bit, Maybe Bit, Bool)
    step :: (Bool, Maybe Message, Bit, Bit)
-> State (Maybe MessageState) (Maybe Bit, Maybe Bit, Bool)
step (Bool
tick, Maybe Message
msg, Bit
sclIn, Bit
sdaIn) = do
        Maybe MessageState
s <- StateT (Maybe MessageState) Identity (Maybe MessageState)
forall s (m :: Type -> Type). MonadState s m => m s
get
        Bool
-> StateT (Maybe MessageState) Identity ()
-> StateT (Maybe MessageState) Identity ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
tick (StateT (Maybe MessageState) Identity ()
 -> StateT (Maybe MessageState) Identity ())
-> StateT (Maybe MessageState) Identity ()
-> StateT (Maybe MessageState) Identity ()
forall a b. (a -> b) -> a -> b
$ (Maybe MessageState -> Maybe MessageState)
-> StateT (Maybe MessageState) Identity ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((Maybe MessageState -> Maybe MessageState)
 -> StateT (Maybe MessageState) Identity ())
-> (Maybe MessageState -> Maybe MessageState)
-> StateT (Maybe MessageState) Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe Message
-> Bit -> Bit -> Maybe MessageState -> Maybe MessageState
i2cNext Maybe Message
msg Bit
sdaIn Bit
sclIn
        Maybe MessageState
s' <- StateT (Maybe MessageState) Identity (Maybe MessageState)
forall s (m :: Type -> Type). MonadState s m => m s
get
        let ready :: Bool
ready = Bool
tick Bool -> Bool -> Bool
&& Maybe MessageState -> Bool
forall a. Maybe a -> Bool
isNothing Maybe MessageState
s'
            (Maybe Bit
sclOut, Maybe Bit
sdaOut) = Maybe MessageState -> (Maybe Bit, Maybe Bit)
i2cOutput Maybe MessageState
s
        (Maybe Bit, Maybe Bit, Bool)
-> State (Maybe MessageState) (Maybe Bit, Maybe Bit, Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Bit
sclOut, Maybe Bit
sdaOut, Bool
ready)