{-|
Copyright  :  (C) 2017, Google Inc.
                  2019, Myrtle Software Ltd
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

Wires are fundamentally bidirectional, and in traditional HDLs we can exploit
this aspect by explicitly marking the endpoint, or port, of such a wire as
/inout/, thereby making this port function as both a source and a drain for the
signals flowing over the wire.

Clash has support for 'inout' ports through the implementation of /BiSignal/s.
To cleanly map to functions (and thus support software simulation using Haskell),
a /BiSignal/ comes in two parts; the __in__ part:

@
'BiSignalIn' (ds :: 'BiSignalDefault') (dom :: 'Domain') (n :: Nat)
@

and the __out__ part:

@
'BiSignalOut' (ds :: 'BiSignalDefault') (dom :: 'Domain') (n :: Nat)
@

Where:

  * The internal representation is a 'BitVector'
  * /n/ indicates the number of bits in the 'BitVector'
  * /dom/ is the /clock-/ (and /reset-/) domain to which the memory elements
    manipulating these BiSignals belong.
  * Lastly, /ds/ indicates the default behavior for the BiSignal if nothing is
    being written (pull-down, pull-up, or undefined).

'BiSignalIn' is used by Clash to generate the 'inout' ports on a HDL level,
while 'BiSignalOut' is only used for simulation purposes and generally discarded
by the compiler.

= Example

The following describes a system where two circuits, in alternating fashion,
read the current value from the /bus/, increment it, and write it on the next
cycle.

@
import Clash.Explicit.Prelude
import Clash.Signal.BiSignal

-- | Alternatingly read / increment+write
counter
  :: (Bool, Int)
  -- ^ Internal flip + previous read
  -> Int
  -- ^ Int from inout
  -> ((Bool, Int), Maybe Int)
counter (write, prevread) i = ((write', prevread'), output)
  where
    output    = if write then Just (succ prevread) else Nothing
    prevread' = if write then prevread else i
    write' = not write

-- | Write on odd cyles
f :: Clock System
  -> Reset System
  -> Enable System
  -> BiSignalIn  'Floating System (BitSize Int)
  -> BiSignalOut 'Floating System (BitSize Int)
f clk rst en s = writeToBiSignal s (mealy clk rst en counter (False, 0) (readFromBiSignal s))

-- | Write on even cyles
g :: Clock System
  -> Reset System
  -> Enable System
  -> BiSignalIn  'Floating System (BitSize Int)
  -> BiSignalOut 'Floating System (BitSize Int)
g clk rst en s = writeToBiSignal s (mealy clk rst en counter (True, 0) (readFromBiSignal s))


-- | Connect the /f/ and /g/ circuits to the same bus
topEntity
  :: Clock System
  -> Reset System
  -> Enable System
  -> Signal System Int
topEntity clk rst en = readFromBiSignal bus'
  where
    bus  = mergeBiSignalOuts $ f clk rst en bus' :> g clk rst en bus' :> Nil
    bus' = veryUnsafeToBiSignalIn bus
@
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif

{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}
{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}

module Clash.Signal.BiSignal (
    BiSignalIn()
  , BiSignalOut()
  , BiSignalDefault(..)
  , mergeBiSignalOuts
  , readFromBiSignal
  , writeToBiSignal
  , veryUnsafeToBiSignalIn
  ) where

import           Data.Kind                  (Type)
import           Data.List                  (intercalate)
import           Data.Maybe                 (fromMaybe,isJust)

import           Clash.Class.HasDomain
import           Clash.Class.BitPack        (BitPack (..))
import           Clash.Sized.BitVector      (BitVector)
import qualified Clash.Sized.Vector         as V
import           Clash.Sized.Vector         (Vec)
import           Clash.Signal.Internal      (Signal(..), Domain, head#, tail#)
import           Clash.XException           (errorX, fromJustX)

import           GHC.TypeLits               (KnownNat, Nat)
import           GHC.Stack                  (HasCallStack)
import           Data.Reflection            (Given (..))

-- | Used to specify the /default/ behavior of a 'BiSignal', i.e. what value is
-- read when no value is being written to it.
data BiSignalDefault
  = PullUp
  -- ^ __inout__ port behaves as if connected to a pull-up resistor
  | PullDown
  -- ^ __inout__ port behaves as if connected to a pull-down resistor
  | Floating
  -- ^ __inout__ port behaves as if is /floating/. Reading a /floating/
  -- 'BiSignal' value in simulation will yield an errorX (undefined value).
  deriving (Int -> BiSignalDefault -> ShowS
[BiSignalDefault] -> ShowS
BiSignalDefault -> String
(Int -> BiSignalDefault -> ShowS)
-> (BiSignalDefault -> String)
-> ([BiSignalDefault] -> ShowS)
-> Show BiSignalDefault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BiSignalDefault] -> ShowS
$cshowList :: [BiSignalDefault] -> ShowS
show :: BiSignalDefault -> String
$cshow :: BiSignalDefault -> String
showsPrec :: Int -> BiSignalDefault -> ShowS
$cshowsPrec :: Int -> BiSignalDefault -> ShowS
Show)

-- | Singleton versions of 'BiSignalDefault'
data SBiSignalDefault :: BiSignalDefault -> Type where
  SPullUp   :: SBiSignalDefault 'PullUp
  SPullDown :: SBiSignalDefault 'PullDown
  SFloating :: SBiSignalDefault 'Floating

instance Given (SBiSignalDefault 'PullUp) where
  given :: SBiSignalDefault 'PullUp
given = SBiSignalDefault 'PullUp
SPullUp

instance Given (SBiSignalDefault 'PullDown) where
  given :: SBiSignalDefault 'PullDown
given = SBiSignalDefault 'PullDown
SPullDown

instance Given (SBiSignalDefault 'Floating) where
  given :: SBiSignalDefault 'Floating
given = SBiSignalDefault 'Floating
SFloating

-- | The /in/ part of an __inout__ port
data BiSignalIn (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)
  = BiSignalIn (SBiSignalDefault ds) (Signal dom (Maybe (BitVector n)))

-- | The /out/ part of an __inout__ port
--
-- Wraps (multiple) writing signals. The semantics are such that only one of
-- the signals may write at a single time step.
newtype BiSignalOut (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)
  = BiSignalOut [Signal dom (Maybe (BitVector n))]

type instance HasDomain dom1 (BiSignalOut ds dom2 n) = DomEq dom1 dom2
type instance TryDomain t (BiSignalOut ds dom n) = 'Found dom

instance Semigroup (BiSignalOut defaultState dom n) where
  (BiSignalOut [Signal dom (Maybe (BitVector n))]
b1) <> :: BiSignalOut defaultState dom n
-> BiSignalOut defaultState dom n -> BiSignalOut defaultState dom n
<> (BiSignalOut [Signal dom (Maybe (BitVector n))]
b2) = [Signal dom (Maybe (BitVector n))]
-> BiSignalOut defaultState dom n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut ([Signal dom (Maybe (BitVector n))]
b1 [Signal dom (Maybe (BitVector n))]
-> [Signal dom (Maybe (BitVector n))]
-> [Signal dom (Maybe (BitVector n))]
forall a. [a] -> [a] -> [a]
++ [Signal dom (Maybe (BitVector n))]
b2)

-- | Monoid instance to support concatenating
--
-- __NB__ Not synthesizable
instance Monoid (BiSignalOut defaultState dom n) where
  mempty :: BiSignalOut defaultState dom n
mempty = [Signal dom (Maybe (BitVector n))]
-> BiSignalOut defaultState dom n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut []

-- /Lazily/ prepend a value to a 'BiSignalIn'.
--
-- Uses a /reified/ 'SBiSignalDefault', the 'Given' constraint, so we can fully
-- create 'BiSignalIn' "out of nowhere" when dealing with circular definitions.
prepend#
  :: Given (SBiSignalDefault ds)
  => Maybe (BitVector n)
  -> BiSignalIn ds d n
  -> BiSignalIn ds d n
prepend# :: Maybe (BitVector n) -> BiSignalIn ds d n -> BiSignalIn ds d n
prepend# Maybe (BitVector n)
a ~(BiSignalIn SBiSignalDefault ds
_ Signal d (Maybe (BitVector n))
as) = SBiSignalDefault ds
-> Signal d (Maybe (BitVector n)) -> BiSignalIn ds d n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
SBiSignalDefault ds
-> Signal dom (Maybe (BitVector n)) -> BiSignalIn ds dom n
BiSignalIn SBiSignalDefault ds
forall a. Given a => a
given (Maybe (BitVector n)
a Maybe (BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (Maybe (BitVector n))
forall (dom :: Domain) a. a -> Signal dom a -> Signal dom a
:- Signal d (Maybe (BitVector n))
as)

readFromBiSignal#
  :: ( HasCallStack
     , KnownNat n)
  => BiSignalIn ds d n
  -> Signal d (BitVector n)
readFromBiSignal# :: BiSignalIn ds d n -> Signal d (BitVector n)
readFromBiSignal# (BiSignalIn SBiSignalDefault ds
ds Signal d (Maybe (BitVector n))
s) =
  case SBiSignalDefault ds
ds of
    SBiSignalDefault ds
SFloating -> BitVector n -> Maybe (BitVector n) -> BitVector n
forall a. a -> Maybe a -> a
fromMaybe (String -> BitVector n
forall a. HasCallStack => String -> a
errorX String
" undefined value on BiSignalIn") (Maybe (BitVector n) -> BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (BitVector n)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe (BitVector n))
s
    SBiSignalDefault ds
SPullDown  -> BitVector n -> Maybe (BitVector n) -> BitVector n
forall a. a -> Maybe a -> a
fromMaybe BitVector n
forall a. Bounded a => a
minBound (Maybe (BitVector n) -> BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (BitVector n)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe (BitVector n))
s
    SBiSignalDefault ds
SPullUp    -> BitVector n -> Maybe (BitVector n) -> BitVector n
forall a. a -> Maybe a -> a
fromMaybe BitVector n
forall a. Bounded a => a
maxBound (Maybe (BitVector n) -> BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (BitVector n)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe (BitVector n))
s
{-# NOINLINE readFromBiSignal# #-}

-- | Read the value from an __inout__ port
readFromBiSignal
  :: ( HasCallStack
     , BitPack a)
  => BiSignalIn ds d (BitSize a)
  -- ^ A 'BiSignalIn' with a number of bits needed to represent /a/
  -> Signal d a
readFromBiSignal :: BiSignalIn ds d (BitSize a) -> Signal d a
readFromBiSignal = (BitVector (BitSize a) -> a)
-> Signal d (BitVector (BitSize a)) -> Signal d a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap BitVector (BitSize a) -> a
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (Signal d (BitVector (BitSize a)) -> Signal d a)
-> (BiSignalIn ds d (BitSize a)
    -> Signal d (BitVector (BitSize a)))
-> BiSignalIn ds d (BitSize a)
-> Signal d a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiSignalIn ds d (BitSize a) -> Signal d (BitVector (BitSize a))
forall (n :: Nat) (ds :: BiSignalDefault) (d :: Domain).
(HasCallStack, KnownNat n) =>
BiSignalIn ds d n -> Signal d (BitVector n)
readFromBiSignal#

-- | Combine several __inout__ signals into one.
mergeBiSignalOuts
  :: ( HasCallStack
     , KnownNat n
     )
  => Vec n (BiSignalOut defaultState dom m)
  -> BiSignalOut defaultState dom m
mergeBiSignalOuts :: Vec n (BiSignalOut defaultState dom m)
-> BiSignalOut defaultState dom m
mergeBiSignalOuts = [BiSignalOut defaultState dom m] -> BiSignalOut defaultState dom m
forall a. Monoid a => [a] -> a
mconcat ([BiSignalOut defaultState dom m]
 -> BiSignalOut defaultState dom m)
-> (Vec n (BiSignalOut defaultState dom m)
    -> [BiSignalOut defaultState dom m])
-> Vec n (BiSignalOut defaultState dom m)
-> BiSignalOut defaultState dom m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec n (BiSignalOut defaultState dom m)
-> [BiSignalOut defaultState dom m]
forall (n :: Nat) a. Vec n a -> [a]
V.toList
{-# NOINLINE mergeBiSignalOuts #-}

writeToBiSignal#
  :: HasCallStack
  => BiSignalIn ds d n
  -> Signal d (Maybe (BitVector n))
  -> Signal d Bool
  -> Signal d (BitVector n)
  -> BiSignalOut ds d n
-- writeToBiSignal# = writeToBiSignal#
writeToBiSignal# :: BiSignalIn ds d n
-> Signal d (Maybe (BitVector n))
-> Signal d Bool
-> Signal d (BitVector n)
-> BiSignalOut ds d n
writeToBiSignal# BiSignalIn ds d n
_ Signal d (Maybe (BitVector n))
maybeSignal Signal d Bool
_ Signal d (BitVector n)
_ = [Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut [Signal d (Maybe (BitVector n))
maybeSignal]
{-# NOINLINE writeToBiSignal# #-}

-- | Write to an __inout__ port
writeToBiSignal
  :: (HasCallStack, BitPack a)
  => BiSignalIn ds d (BitSize a)
  -> Signal d (Maybe a)
  -- ^ Value to write
  --
  --   * /Just a/ writes an /a/ value
  --   * /Nothing/ puts the port in a /high-impedance/ state
  -> BiSignalOut ds d (BitSize a)
writeToBiSignal :: BiSignalIn ds d (BitSize a)
-> Signal d (Maybe a) -> BiSignalOut ds d (BitSize a)
writeToBiSignal BiSignalIn ds d (BitSize a)
input Signal d (Maybe a)
writes =
  BiSignalIn ds d (BitSize a)
-> Signal d (Maybe (BitVector (BitSize a)))
-> Signal d Bool
-> Signal d (BitVector (BitSize a))
-> BiSignalOut ds d (BitSize a)
forall (ds :: BiSignalDefault) (d :: Domain) (n :: Nat).
HasCallStack =>
BiSignalIn ds d n
-> Signal d (Maybe (BitVector n))
-> Signal d Bool
-> Signal d (BitVector n)
-> BiSignalOut ds d n
writeToBiSignal#
    BiSignalIn ds d (BitSize a)
input
    ((a -> BitVector (BitSize a))
-> Maybe a -> Maybe (BitVector (BitSize a))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> BitVector (BitSize a)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (Maybe a -> Maybe (BitVector (BitSize a)))
-> Signal d (Maybe a) -> Signal d (Maybe (BitVector (BitSize a)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe a)
writes)
    (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Signal d (Maybe a) -> Signal d Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe a)
writes)
    (a -> BitVector (BitSize a)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (a -> BitVector (BitSize a))
-> (Maybe a -> a) -> Maybe a -> BitVector (BitSize a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJustX (Maybe a -> BitVector (BitSize a))
-> Signal d (Maybe a) -> Signal d (BitVector (BitSize a))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe a)
writes)
{-# INLINE writeToBiSignal #-}

-- | Converts the 'out' part of a BiSignal to an 'in' part. In simulation it
-- checks whether multiple components are writing and will error accordingly.
-- Make sure this is only called ONCE for every BiSignal.
veryUnsafeToBiSignalIn
  :: ( HasCallStack
     , KnownNat n
     , Given (SBiSignalDefault ds)
     )
  => BiSignalOut ds d n
  -> BiSignalIn ds d n
veryUnsafeToBiSignalIn :: BiSignalOut ds d n -> BiSignalIn ds d n
veryUnsafeToBiSignalIn (BiSignalOut [Signal d (Maybe (BitVector n))]
signals) = Maybe (BitVector n) -> BiSignalIn ds d n -> BiSignalIn ds d n
forall (ds :: BiSignalDefault) (n :: Nat) (d :: Domain).
Given (SBiSignalDefault ds) =>
Maybe (BitVector n) -> BiSignalIn ds d n -> BiSignalIn ds d n
prepend# Maybe (BitVector n)
result BiSignalIn ds d n
biSignalOut'
  where
    -- Enforce that only one component is writing
    result :: Maybe (BitVector n)
result = case (Signal d (Maybe (BitVector n)) -> Bool)
-> [Signal d (Maybe (BitVector n))]
-> [Signal d (Maybe (BitVector n))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (BitVector n) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (BitVector n) -> Bool)
-> (Signal d (Maybe (BitVector n)) -> Maybe (BitVector n))
-> Signal d (Maybe (BitVector n))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal d (Maybe (BitVector n)) -> Maybe (BitVector n)
forall (dom :: Domain) a. Signal dom a -> a
head#) [Signal d (Maybe (BitVector n))]
signals of
      []  -> Maybe (BitVector n)
forall a. Maybe a
Nothing
      [Signal d (Maybe (BitVector n))
w] -> Signal d (Maybe (BitVector n)) -> Maybe (BitVector n)
forall (dom :: Domain) a. Signal dom a -> a
head# Signal d (Maybe (BitVector n))
w
      [Signal d (Maybe (BitVector n))]
_   -> String -> Maybe (BitVector n)
forall a. HasCallStack => String -> a
errorX String
err

    err :: String
err = [String] -> String
unwords
      [ String
"Multiple components wrote to the BiSignal. This is undefined behavior"
      , String
"in hardware and almost certainly a logic error. The components wrote:\n"
      , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n  " ((Signal d (Maybe (BitVector n)) -> String)
-> [Signal d (Maybe (BitVector n))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (BitVector n) -> String
forall a. Show a => a -> String
show (Maybe (BitVector n) -> String)
-> (Signal d (Maybe (BitVector n)) -> Maybe (BitVector n))
-> Signal d (Maybe (BitVector n))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal d (Maybe (BitVector n)) -> Maybe (BitVector n)
forall (dom :: Domain) a. Signal dom a -> a
head#) [Signal d (Maybe (BitVector n))]
signals)
      ]

    -- Recursive step
    biSignalOut' :: BiSignalIn ds d n
biSignalOut' = BiSignalOut ds d n -> BiSignalIn ds d n
forall (n :: Nat) (ds :: BiSignalDefault) (d :: Domain).
(HasCallStack, KnownNat n, Given (SBiSignalDefault ds)) =>
BiSignalOut ds d n -> BiSignalIn ds d n
veryUnsafeToBiSignalIn (BiSignalOut ds d n -> BiSignalIn ds d n)
-> BiSignalOut ds d n -> BiSignalIn ds d n
forall a b. (a -> b) -> a -> b
$ [Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut ([Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n)
-> [Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n
forall a b. (a -> b) -> a -> b
$ (Signal d (Maybe (BitVector n)) -> Signal d (Maybe (BitVector n)))
-> [Signal d (Maybe (BitVector n))]
-> [Signal d (Maybe (BitVector n))]
forall a b. (a -> b) -> [a] -> [b]
map Signal d (Maybe (BitVector n)) -> Signal d (Maybe (BitVector n))
forall (dom :: Domain) a. Signal dom a -> Signal dom a
tail# [Signal d (Maybe (BitVector n))]
signals
{-# NOINLINE veryUnsafeToBiSignalIn #-}