    {-|
    Copyright  :  (C) 2013-2016, University of Twente,
                      2017-2019, Myrtle Software Ltd, Google Inc.
                      2019,2022, QBayLogic B.V.
    License    :  BSD2 (see the file LICENSE)
    Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

    The Product/Signal isomorphism
    -}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeFamilyDependencies #-}

    {-# LANGUAGE Trustworthy #-}

    --{-# OPTIONS_GHC -ddump-splices #-}
    {-# OPTIONS_HADDOCK show-extensions #-}

    module Clash.Signal.Bundle
      ( Bundle (..)
      -- ** Tools to emulate pre Clash 1.0 @Bundle ()@ instance
      , EmptyTuple(..)
      , TaggedEmptyTuple(..)
      -- ** Internal
      , vecBundle#
      )
    where

    import Data.Functor.Compose
    import GHC.Generics
    import GHC.TypeLits                 (KnownNat)
    import Prelude                      hiding (head, map, tail)

    import Clash.Annotations.Primitive (hasBlackBox)
    import Clash.Signal.Bundle.Internal (deriveBundleTuples)
    import Clash.Signal.Internal        (Signal (..), Domain)
    import Clash.Sized.BitVector        (Bit, BitVector)
    import Clash.Sized.Fixed            (Fixed)
    import Clash.Sized.Index            (Index)
    import Clash.Sized.Signed           (Signed)
    import Clash.Sized.Unsigned         (Unsigned)
    import Clash.Sized.Vector           (Vec, traverse#, lazyV)
    import Clash.Sized.RTree            (RTree, lazyT)

    -- | Isomorphism between a 'Clash.Signal.Signal' of a product type (e.g. a tuple) and a
    -- product type of 'Clash.Signal.Signal's.
    --
    -- Instances of 'Bundle' must satisfy the following laws:
    --
    -- @
    -- 'bundle' . 'unbundle' = 'id'
    -- 'unbundle' . 'bundle' = 'id'
    -- @
    --
    -- By default, 'bundle' and 'unbundle', are defined as the identity, that is,
    -- writing:
    --
    -- @
    -- data D = A | B
    --
    -- instance Bundle D
    -- @
    --
    -- is the same as:
    --
    -- @
    -- data D = A | B
    --
    -- instance Bundle D where
    --   type 'Unbundled' clk D = 'Signal' clk D
    --   'bundle'   s = s
    --   'unbundle' s = s
    -- @
    --
    -- For custom product types you'll have to write the instance manually:
    --
    -- @
    -- data Pair a b = MkPair { getA :: a, getB :: b }
    --
    -- instance Bundle (Pair a b) where
    --   type Unbundled dom (Pair a b) = Pair (Signal dom a) (Signal dom b)
    --
    --   -- bundle :: Pair (Signal dom a) (Signal dom b) -> Signal dom (Pair a b)
    --   bundle   (MkPair as bs) = MkPair '<$>' as '<*>' bs
    --
    --   -- unbundle :: Signal dom (Pair a b) -> Pair (Signal dom a) (Signal dom b)
    --   unbundle pairs = MkPair (getA '<$>' pairs) (getB '<$>' pairs)
    -- @

    class Bundle a where
      type Unbundled (dom :: Domain) a = res | res -> dom a
      type Unbundled dom a = Signal dom a
      -- | Example:
      --
      -- @
      -- __bundle__ :: ('Signal' dom a, 'Signal' dom b) -> 'Signal' dom (a,b)
      -- @
      --
      -- However:
      --
      -- @
      -- __bundle__ :: 'Signal' dom 'Clash.Sized.BitVector.Bit' -> 'Signal' dom 'Clash.Sized.BitVector.Bit'
      -- @
      bundle :: Unbundled dom a -> Signal dom a

      {-# INLINE bundle #-}
      default bundle :: (Signal dom a ~ Unbundled dom a)
                     => Unbundled dom a -> Signal dom a
      bundle Unbundled dom a
    s = Signal dom a
    Unbundled dom a
    s
      -- | Example:
      --
      -- @
      -- __unbundle__ :: 'Signal' dom (a,b) -> ('Signal' dom a, 'Signal' dom b)
      -- @
      --
      -- However:
      --
      -- @
      -- __unbundle__ :: 'Signal' dom 'Clash.Sized.BitVector.Bit' -> 'Signal' dom 'Clash.Sized.BitVector.Bit'
      -- @
      unbundle :: Signal dom a -> Unbundled dom a

      {-# INLINE unbundle #-}
      default unbundle :: (Unbundled dom a ~ Signal dom a)
                       => Signal dom a -> Unbundled dom a
      unbundle Signal dom a
    s = Signal dom a
    Unbundled dom a
    s

    instance Bundle ()
    instance Bundle Bool
    instance Bundle Integer
    instance Bundle Int
    instance Bundle Float
    instance Bundle Double
    instance Bundle (Maybe a)
    instance Bundle (Either a b)

    instance Bundle Bit
    instance Bundle (BitVector n)
    instance Bundle (Index n)
    instance Bundle (Fixed rep int frac)
    instance Bundle (Signed n)
    instance Bundle (Unsigned n)

    -- | __NB__: The documentation only shows instances up to /3/-tuples. By
    -- default, instances up to and including /12/-tuples will exist. If the flag
    -- @large-tuples@ is set instances up to the GHC imposed limit will exist. The
    -- GHC imposed limit is either 62 or 64 depending on the GHC version.
    deriveBundleTuples ''Bundle ''Unbundled 'bundle 'unbundle

    instance KnownNat n => Bundle (Vec n a) where
      type Unbundled t (Vec n a) = Vec n (Signal t a)
      -- The 'Traversable' instance of 'Vec' is not synthesizable, so we must
      -- define 'bundle' as a primitive.
      bundle :: forall (dom :: Domain).
    Unbundled dom (Vec n a) -> Signal dom (Vec n a)
    bundle   = Vec n (Signal dom a) -> Signal dom (Vec n a)
    Unbundled dom (Vec n a) -> Signal dom (Vec n a)
    forall (n :: Nat) (t :: Domain) a.
    Vec n (Signal t a) -> Signal t (Vec n a)
    vecBundle#
      unbundle :: forall (dom :: Domain).
    Signal dom (Vec n a) -> Unbundled dom (Vec n a)
    unbundle = Signal dom (Vec n a) -> Vec n (Signal dom a)
    forall (t :: Type -> Type) (f :: Type -> Type) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    forall (f :: Type -> Type) a.
    Applicative f =>
    Signal dom (f a) -> f (Signal dom a)
    sequenceA (Signal dom (Vec n a) -> Vec n (Signal dom a))
    -> (Signal dom (Vec n a) -> Signal dom (Vec n a))
    -> Signal dom (Vec n a)
    -> Vec n (Signal dom a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Vec n a -> Vec n a)
    -> Signal dom (Vec n a) -> Signal dom (Vec n a)
    forall a b. (a -> b) -> Signal dom a -> Signal dom b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Vec n a -> Vec n a
    forall (n :: Nat) a. KnownNat n => Vec n a -> Vec n a
    lazyV

    -- See: https://github.com/clash-lang/clash-compiler/pull/2511
    {-# CLASH_OPAQUE vecBundle# #-}
    {-# ANN vecBundle# hasBlackBox #-}
    vecBundle# :: Vec n (Signal t a) -> Signal t (Vec n a)
    vecBundle# :: forall (n :: Nat) (t :: Domain) a.
    Vec n (Signal t a) -> Signal t (Vec n a)
    vecBundle# = (Signal t a -> Signal t a)
    -> Vec n (Signal t a) -> Signal t (Vec n a)
    forall a (f :: Type -> Type) b (n :: Nat).
    Applicative f =>
    (a -> f b) -> Vec n a -> f (Vec n b)
    traverse# Signal t a -> Signal t a
    forall a. a -> a
    id

    instance KnownNat d => Bundle (RTree d a) where
      type Unbundled t (RTree d a) = RTree d (Signal t a)
      bundle :: forall (dom :: Domain).
    Unbundled dom (RTree d a) -> Signal dom (RTree d a)
    bundle   = RTree d (Signal dom a) -> Signal dom (RTree d a)
    Unbundled dom (RTree d a) -> Signal dom (RTree d a)
    forall (t :: Type -> Type) (f :: Type -> Type) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    forall (f :: Type -> Type) a.
    Applicative f =>
    RTree d (f a) -> f (RTree d a)
    sequenceA
      unbundle :: forall (dom :: Domain).
    Signal dom (RTree d a) -> Unbundled dom (RTree d a)
    unbundle = Signal dom (RTree d a) -> RTree d (Signal dom a)
    forall (t :: Type -> Type) (f :: Type -> Type) a.
    (Traversable t, Applicative f) =>
    t (f a) -> f (t a)
    forall (f :: Type -> Type) a.
    Applicative f =>
    Signal dom (f a) -> f (Signal dom a)
    sequenceA (Signal dom (RTree d a) -> RTree d (Signal dom a))
    -> (Signal dom (RTree d a) -> Signal dom (RTree d a))
    -> Signal dom (RTree d a)
    -> RTree d (Signal dom a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (RTree d a -> RTree d a)
    -> Signal dom (RTree d a) -> Signal dom (RTree d a)
    forall a b. (a -> b) -> Signal dom a -> Signal dom b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap RTree d a -> RTree d a
    forall (d :: Nat) a. KnownNat d => RTree d a -> RTree d a
    lazyT

    instance Bundle ((f :*: g) a) where
      type Unbundled t ((f :*: g) a) = (Compose (Signal t) f :*: Compose (Signal t) g) a
      bundle :: forall (dom :: Domain).
    Unbundled dom ((:*:) f g a) -> Signal dom ((:*:) f g a)
    bundle (Compose Signal dom (f a)
    l :*: Compose Signal dom (g a)
    r) = f a -> g a -> (:*:) f g a
    forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
    f p -> g p -> (:*:) f g p
    (:*:) (f a -> g a -> (:*:) f g a)
    -> Signal dom (f a) -> Signal dom (g a -> (:*:) f g a)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Signal dom (f a)
    l Signal dom (g a -> (:*:) f g a)
    -> Signal dom (g a) -> Signal dom ((:*:) f g a)
    forall a b. Signal dom (a -> b) -> Signal dom a -> Signal dom b
    forall (f :: Type -> Type) a b.
    Applicative f =>
    f (a -> b) -> f a -> f b
    <*> Signal dom (g a)
    r
      unbundle :: forall (dom :: Domain).
    Signal dom ((:*:) f g a) -> Unbundled dom ((:*:) f g a)
    unbundle Signal dom ((:*:) f g a)
    s = Signal dom (f a) -> Compose (Signal dom) f a
    forall {k} {k1} (f :: k -> Type) (g :: k1 -> k) (a :: k1).
    f (g a) -> Compose f g a
    Compose ((:*:) f g a -> f a
    forall {f :: Type -> Type} {g :: Type -> Type} {p}.
    (:*:) f g p -> f p
    getL ((:*:) f g a -> f a)
    -> Signal dom ((:*:) f g a) -> Signal dom (f a)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Signal dom ((:*:) f g a)
    s) Compose (Signal dom) f a
    -> Compose (Signal dom) g a
    -> (:*:) (Compose (Signal dom) f) (Compose (Signal dom) g) a
    forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
    f p -> g p -> (:*:) f g p
    :*: Signal dom (g a) -> Compose (Signal dom) g a
    forall {k} {k1} (f :: k -> Type) (g :: k1 -> k) (a :: k1).
    f (g a) -> Compose f g a
    Compose ((:*:) f g a -> g a
    forall {f :: Type -> Type} {g :: Type -> Type} {p}.
    (:*:) f g p -> g p
    getR ((:*:) f g a -> g a)
    -> Signal dom ((:*:) f g a) -> Signal dom (g a)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Signal dom ((:*:) f g a)
    s)
       where
        getL :: (:*:) f g p -> f p
    getL (f p
    l :*: g p
    _) = f p
    l
        getR :: (:*:) f g p -> g p
    getR (f p
    _ :*: g p
    r) = g p
    r

    -- | See 'TaggedEmptyTuple'
    data EmptyTuple = EmptyTuple

    -- | Helper type to emulate the "old" behavior of Bundle's unit instance. I.e.,
    -- the instance for @Bundle ()@ used to be defined as:
    --
    -- @
    -- class Bundle () where
    --   bundle   :: () -> Signal dom ()
    --   unbundle :: Signal dom () -> ()
    -- @
    --
    -- In order to have sensible type inference, the 'Bundle' class specifies that
    -- the argument type of 'bundle' should uniquely identify the result type, and
    -- vice versa for 'unbundle'. The type signatures in the snippet above don't
    -- though, as @()@ doesn't uniquely map to a specific domain. In other words,
    -- @domain@ should occur in both the argument and result of both functions.
    --
    -- 'TaggedEmptyTuple' tackles this by carrying the domain in its type. The
    -- 'bundle' and 'unbundle' instance now looks like:
    --
    -- @
    -- class Bundle EmptyTuple where
    --   bundle   :: TaggedEmptyTuple dom -> Signal dom EmptyTuple
    --   unbundle :: Signal dom EmptyTuple -> TaggedEmptyTuple dom
    -- @
    --
    -- @dom@ is now mentioned both the argument and result for both 'bundle' and
    -- 'unbundle'.
    data TaggedEmptyTuple (dom :: Domain) = TaggedEmptyTuple

    -- | See [commit 94b0bff5](https://github.com/clash-lang/clash-compiler/pull/539/commits/94b0bff5770aa4961e04ddce2515130df3fc7863)
    -- and documentation for 'TaggedEmptyTuple'.
    instance Bundle EmptyTuple where
      type Unbundled dom EmptyTuple = TaggedEmptyTuple dom

      bundle :: TaggedEmptyTuple dom -> Signal dom EmptyTuple
      bundle :: forall (dom :: Domain).
    TaggedEmptyTuple dom -> Signal dom EmptyTuple
    bundle TaggedEmptyTuple dom
    TaggedEmptyTuple = EmptyTuple -> Signal dom EmptyTuple
    forall a. a -> Signal dom a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure EmptyTuple
    EmptyTuple

      unbundle :: Signal dom EmptyTuple -> TaggedEmptyTuple dom
      unbundle :: forall (dom :: Domain).
    Signal dom EmptyTuple -> TaggedEmptyTuple dom
    unbundle Signal dom EmptyTuple
    s = Signal dom EmptyTuple
    -> TaggedEmptyTuple dom -> TaggedEmptyTuple dom
    forall a b. a -> b -> b
    seq Signal dom EmptyTuple
    s TaggedEmptyTuple dom
    forall (dom :: Domain). TaggedEmptyTuple dom
    TaggedEmptyTuple