I2C.hs

{-# LANGUAGE DerivingVia #-}
module I2C where

import           Clash.Annotations.TH           ( makeTopEntity )
import           Clash.Prelude           hiding ( lift
                                                , moore
                                                , select
                                                )
import           Control.Lens                   ( makeLenses )
import           Control.Monad.State.Strict

import           Barbies
import           Barbies.Bare
import           Barbies.TH                     ( declareBareB )
import           Control.Monad.Reader.Class     ( asks )
import           Data.Functor.Identity
import           Data.Monoid                    ( Last )
import           Imperative

data Ready = NotReady | Ready
type Byte = BitVector 8
type Addr = BitVector 8
data I2CLine = HighImpedance | DriveLow
  deriving (Generic, NFDataX, Show)

data I2CIn = I2CIn
  { inSCL :: Bit
  , inSDA :: Bit
  }
  deriving (Generic, NFDataX)

declareBareB [d|
  data I2COut = I2COut
    { _outSCL :: I2CLine
    , _outSDA :: I2CLine
    }
    deriving(Generic)
  |]

deriving via Barbie (I2COut Covered ) Last
  instance Semigroup (I2COut Covered Last)
deriving via Barbie (I2COut Covered ) Last
  instance Monoid (I2COut Covered Last)
deriving instance NFDataX (I2COut Covered Last)
deriving instance Show (I2COut Covered Last)

makeLenses 'I2COut

newtype I2CState = I2CState
  { _started :: Bool
  }
  deriving (Show)
  deriving newtype (NFDataX)

makeLenses 'I2CState

i2c
  :: Signal dom I2CIn
  -> Signal dom (Maybe Addr)
  -> Signal dom (Maybe Byte)
  -> Signal dom (I2COut Bare Identity, Ready, Maybe Byte)
i2c = undefined

i2cStart :: Imp I2CIn (I2COut Covered Last) I2CState ()
i2cStart = do
  -- If we've already started, send restart condition
  whenS (liftS (gets _started)) $ do
    outSDA .:= HighImpedance
    wait
    outSCL .:= HighImpedance
    -- Wait for clock stretching from slave
    waitFor ((== 0) <$> asks inSCL)
    wait
    pure ()
  -- Pull sda low before scl
  outSDA .:= DriveLow
  wait
  outSCL .:= DriveLow
  started .= True
  loop
  pure ()

-- >>> simulateN 6 (hideClockResetEnable topEntity) (Prelude.repeat (I2CIn 0 0))
topEntity
  :: "clk" ::: Clock System
  -> "rst" ::: Reset System
  -> "en" ::: Enable System
  -> "in" ::: Signal System I2CIn
  -> "out" ::: Signal System (I2COut Covered Last)
-- topEntity = exposeClockResetEnable (toMealy' i2cStart (I2CState False))
topEntity = exposeClockResetEnable (toMealy (forClash i2cStart) (I2CState False))

makeTopEntity 'topEntity

Imperative.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DerivingVia #-}
module Imperative where

import           Clash.Prelude           hiding ( lift
                                                , many
                                                , max
                                                , pi
                                                , select
                                                , someNatVal
                                                )
import           Control.Lens                   ( ASetter
                                                , Setter'
                                                , scribe
                                                )
import           Control.Lens.Setter            ( assign )
import           Control.Monad.Except           ( MonadError(throwError) )
import           Control.Monad.RWS       hiding ( Last )
import           Control.Monad.State
import           Control.Monad.Trans.Except
import           Control.Selective.Multi
-- import           Control.Selective.Free
import           Data.Bifunctor                 ( first )
import           Data.Bool
import           Data.Functor.Compose
import           Data.Functor.Identity
import           Data.Proxy
import           Data.Semigroup                 ( Last(Last) )
import           GHC.TypeNats

newtype Waiter m a = Waiter { unWaiter :: ExceptT () (StateT Int m) a }
  deriving newtype (Functor, Applicative, Monad, MonadError ())

instance Monad m => Selective (Waiter m) where
  match = matchM

runWaiter :: Functor m => Int -> Waiter m a -> m (Maybe a, Int)
runWaiter n =
  fmap (first (either (const Nothing) Just))
    . flip runStateT n
    . runExceptT
    . unWaiter

instance MonadTrans (Waiter ) where
  lift = Waiter . lift . lift

data Inst m n a where
  Inst ::m a -> Inst m n a
  Wait ::n -> Inst m n ()
  WaitFor ::m Bool -> Inst m n ()
  Loop ::Inst m n ()

type Imp i o s = Select (Inst (RWS i o s) ())

liftS :: m a -> Select (Inst m n) a
liftS = liftSelect . Inst

wait :: Select (Inst m ()) ()
wait = liftSelect (Wait ())

waitFor :: m Bool -> Select (Inst m n) ()
waitFor = liftSelect . WaitFor

loop :: Select (Inst m ()) ()
loop = liftSelect Loop

infix 4 .:=
(.:=)
  :: (Monoid w, Applicative f, MonadWriter w m)
  => Setter' w (f a)
  -> a
  -> Select (Inst m n) ()
fd .:= x = liftS (scribe fd (pure x))

infix 4 .=
(.=) :: MonadState s m => ASetter s s a b -> b -> Select (Inst m n) ()
fd .= x = liftS (fd `assign` x)

tellS :: a -> Select (Inst (RWS () (Maybe (Last a)) ()) n) ()
tellS = liftS . tell . Just . Last

newtype Number f a = Number { unNumber :: Int -> (f a, Int) }
  deriving (Functor, Applicative) via Compose (State Int) f

-- Each branch increments the numbering by the max of all the alternatives
instance Selective f => Selective (Number f) where
  match (Number s) pi = Number
    (\n ->
      let (f, n') = s n
          x       = match f (runNumber' n' . pi)
          n''     = maximum (n' : ms n')
      in  (x, n'')
    )
   where
    ms :: Int -> [Int]
    ms n = [ snd . ($ n) . unNumber . pi $ t | Some t <- enumerate ]

runNumber' :: Int -> Number f a -> f a
runNumber' i = fst . ($ i) . unNumber

runNumber :: Number f a -> f a
runNumber = runNumber' 1

runNumber'' :: Number f a -> (f a, Int)
runNumber'' = ($ 1) . unNumber

numberWaits :: Select (Inst m n) () -> Select (Inst m Int) ()
numberWaits = runNumber . runSelect go
 where
  go :: Inst m n a -> Number (Select (Inst m Int)) a
  go = \case
    Inst x    -> Number . (,) . liftSelect $ Inst x
    Loop      -> Number . (,) . liftSelect $ Loop
    Wait    _ -> Number $ \n -> (liftSelect (Wait n), succ n)
    WaitFor c -> Number . (,) . liftSelect $ WaitFor c

withNumberedWaits
  :: (forall b . KnownNat b => Select (Inst m (Index b)) () -> a)
  -> Select (Inst m n) ()
  -> a
withNumberedWaits k p =
  let bound = 20
      c     = case someNatVal (fromIntegral bound) of
        SomeNat (_ :: Proxy b) ->
          k . fst . runNumber'' . runSelect (go @(Index b)) $ p
  in  c

go :: forall b m i a . Num b => Inst m i a -> Number (Select (Inst m (b))) a
go = \case
  Inst x    -> Number . (,) . liftSelect $ Inst x
  Loop      -> Number . (,) . liftSelect $ Loop
  Wait    _ -> Number $ \n -> (liftSelect (Wait (fromIntegral n)), succ n)
  WaitFor c -> Number . (,) . liftSelect $ WaitFor c

withNumberedWaits'
  :: (forall b . KnownNat b => Select (Inst m (Index b)) () -> a)
  -> Select (Inst m n) ()
  -> a
withNumberedWaits' k p =
  let (c, bound) = case someNatVal (fromIntegral bound) of
        SomeNat (_ :: Proxy b) -> first k . runNumber'' . runSelect (go @b) $ p
  in  c
 where
  go
    :: forall b m i a
     . KnownNat b
    => Inst m i a
    -> Number (Select (Inst m (Index b))) a
  go = \case
    Inst x    -> Number . (,) . liftSelect $ Inst x
    Loop      -> Number . (,) . liftSelect $ Loop
    Wait    _ -> Number $ \n -> (liftSelect (Wait (fromIntegral n)), succ n)
    WaitFor c -> Number . (,) . liftSelect $ WaitFor c

toMealy
  :: forall dom i o s a
   . (KnownDomain dom, HiddenClockResetEnable dom, NFDataX s)
  => Waiter (RWS i o s) a
  -> s
  -> Signal dom i
  -> Signal dom o
toMealy p initial =
  let t :: (s, Int) -> i -> ((s, Int), o)
      t (s, n) i =
        (\((_, n'), s', o) -> ((s', n'), o))
          . (\x -> runRWS x i s)
          . runWaiter n
          $ p
  in  mealy t (initial, 0)

forClash :: Monad m => Select (Inst m n) () -> Waiter m ()
forClash =
  runSelect
      (\case
        Inst x -> lift x
        Loop   -> do
          Waiter $ put 0
          throwError ()
        Wait n -> do
          x <- Waiter get
          if x < n
            then do
              Waiter $ put n
              throwError ()
            else pure ()
        WaitFor c -> do
          lift c >>= \case
            False -> throwError ()
            True  -> pure ()
      )
    . numberWaits

-- forClash'
--   :: forall m n a
--    . Monad m
--   => (forall b . KnownNat b => Waiter (Index b) m () -> a)
--   -> Select (Inst m n) ()
--   -> a
-- forClash' k = withNumberedWaits go
--  where
--   go :: forall b . KnownNat b => (Select (Inst m (Index b)) () -> a)
--   go = k @b . runSelect
--     (\case
--       Inst x -> lift x
--       Loop   -> do
--         Waiter $ put 0
--         throwError ()
--       Wait n -> do
--         x <- Waiter get
--         if x < n
--           then do
--             Waiter $ put n
--             throwError ()
--           else pure ()
--       WaitFor c -> do
--         lift c >>= \case
--           False -> throwError ()
--           True  -> pure ()
--     )

-- toMealy'
--   :: forall dom i o s
--    . (KnownDomain dom, HiddenClockResetEnable dom, NFDataX s, Monoid o)
--   => Imp i o s ()
--   -> s
--   -> Signal dom i
--   -> Signal dom o
-- toMealy' = forClash' toMealy

----------------------------------------------------------------
-- Selective Free Multi
----------------------------------------------------------------

-- | Free selective functors.
newtype Select f a = Select (forall g. Selective g => (forall x. f x -> g x) -> g a)

-- Ignoring the hint, since GHC can't type check the suggested code.
{-# ANN module "HLint: ignore Use fmap" #-}
instance Functor (Select f) where
  fmap f (Select x) = Select $ \k -> f <$> x k

instance Applicative (Select f) where
  pure a = Select $ \_ -> pure a
  Select x <*> Select y = Select $ \k -> x k <*> y k

instance Selective (Select f) where
  match (Select x) pi = Select $ \k -> match (x k) ((\(Select g) -> g k) . pi)

-- | Lift a functor into a free selective computation.
liftSelect :: f a -> Select f a
liftSelect x = Select (\f -> f x)

-- | Given a natural transformation from @f@ to @g@, this gives a canonical
-- natural transformation from @Select f@ to @g@. Note that here we rely on the
-- fact that @g@ is a lawful selective functor.
runSelect :: Selective g => (forall x . f x -> g x) -> Select f a -> g a
runSelect k (Select x) = x k

whenS :: Selective f => f Bool -> f () -> f ()
whenS x y = select (bool (Right ()) (Left ()) <$> x) (const <$> y)

ifS :: Selective f => f Bool -> f a -> f a -> f a
ifS b t f = match (many <$> b) $ \case
  Many True  -> const <$> t
  Many False -> const <$> f