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

The Product/Signal isomorphism
-}

{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MagicHash              #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators          #-}

{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_HADDOCK show-extensions #-}

module Clash.Signal.Bundle
  ( Bundle (..)
  )
where

import Control.Applicative   (liftA2)
import GHC.TypeLits          (KnownNat)
import Prelude               hiding (head, map, tail)

import Clash.NamedTypes      ((:::))
import Clash.Signal.Internal (Domain, Signal (..))
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
-- @
--
class Bundle a where
  type Unbundled (domain :: Domain) a = res | res -> domain a
  type Unbundled domain a = Signal domain a
  -- | Example:
  --
  -- @
  -- __bundle__ :: ('Signal' domain a, 'Signal' domain b) -> 'Signal' clk (a,b)
  -- @
  --
  -- However:
  --
  -- @
  -- __bundle__ :: 'Signal' domain 'Clash.Sized.BitVector.Bit' -> 'Signal' domain 'Clash.Sized.BitVector.Bit'
  -- @
  bundle :: Unbundled domain a -> Signal domain a

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

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

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)

-- | Note that:
--
-- > bundle   :: () -> Signal domain ()
-- > unbundle :: Signal domain () -> ()
instance Bundle () where
  type Unbundled t () = t ::: ()
  -- ^ This is just to satisfy the injectivity annotation
  bundle   u = pure u
  unbundle _ = ()

instance Bundle (a,b) where
  type Unbundled t (a,b) = (Signal t a, Signal t b)
  bundle       = uncurry (liftA2 (,))
  unbundle tup = (fmap fst tup, fmap snd tup)

instance Bundle (a,b,c) where
  type Unbundled t (a,b,c) = (Signal t a, Signal t b, Signal t c)
  bundle   (a,b,c) = (,,) <$> a <*> b <*> c
  unbundle tup     = (fmap (\(x,_,_) -> x) tup
                     ,fmap (\(_,x,_) -> x) tup
                     ,fmap (\(_,_,x) -> x) tup
                     )

instance Bundle (a,b,c,d) where
  type Unbundled t (a,b,c,d) = ( Signal t a, Signal t b, Signal t c
                               , Signal t d
                               )
  bundle   (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d
  unbundle tup       = (fmap (\(x,_,_,_) -> x) tup
                       ,fmap (\(_,x,_,_) -> x) tup
                       ,fmap (\(_,_,x,_) -> x) tup
                       ,fmap (\(_,_,_,x) -> x) tup
                       )

instance Bundle (a,b,c,d,e) where
  type Unbundled t (a,b,c,d,e) = ( Signal t a, Signal t b, Signal t c
                                 , Signal t d, Signal t e
                                 )
  bundle   (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e
  unbundle tup         = (fmap (\(x,_,_,_,_) -> x) tup
                         ,fmap (\(_,x,_,_,_) -> x) tup
                         ,fmap (\(_,_,x,_,_) -> x) tup
                         ,fmap (\(_,_,_,x,_) -> x) tup
                         ,fmap (\(_,_,_,_,x) -> x) tup
                         )

instance Bundle (a,b,c,d,e,f) where
  type Unbundled t (a,b,c,d,e,f) = ( Signal t a, Signal t b, Signal t c
                                   , Signal t d, Signal t e, Signal t f
                                   )
  bundle   (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f
  unbundle tup           = (fmap (\(x,_,_,_,_,_) -> x) tup
                           ,fmap (\(_,x,_,_,_,_) -> x) tup
                           ,fmap (\(_,_,x,_,_,_) -> x) tup
                           ,fmap (\(_,_,_,x,_,_) -> x) tup
                           ,fmap (\(_,_,_,_,x,_) -> x) tup
                           ,fmap (\(_,_,_,_,_,x) -> x) tup
                           )

instance Bundle (a,b,c,d,e,f,g) where
  type Unbundled t (a,b,c,d,e,f,g) = ( Signal t a, Signal t b, Signal t c
                                     , Signal t d, Signal t e, Signal t f
                                     , Signal t g
                                     )
  bundle   (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f
                                      <*> g
  unbundle tup             = (fmap (\(x,_,_,_,_,_,_) -> x) tup
                             ,fmap (\(_,x,_,_,_,_,_) -> x) tup
                             ,fmap (\(_,_,x,_,_,_,_) -> x) tup
                             ,fmap (\(_,_,_,x,_,_,_) -> x) tup
                             ,fmap (\(_,_,_,_,x,_,_) -> x) tup
                             ,fmap (\(_,_,_,_,_,x,_) -> x) tup
                             ,fmap (\(_,_,_,_,_,_,x) -> x) tup
                             )

instance Bundle (a,b,c,d,e,f,g,h) where
  type Unbundled t (a,b,c,d,e,f,g,h) = ( Signal t a, Signal t b, Signal t c
                                       , Signal t d, Signal t e, Signal t f
                                       , Signal t g, Signal t h
                                       )
  bundle   (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f
                                         <*> g <*> h
  unbundle tup               = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup
                               ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup
                               ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup
                               ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup
                               ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup
                               ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup
                               ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup
                               ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup
                               )

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 synthesisable, so we must
  -- define 'bundle' as a primitive.
  bundle   = vecBundle#
  unbundle = sequenceA . fmap lazyV

{-# NOINLINE vecBundle# #-}
vecBundle# :: Vec n (Signal t a) -> Signal t (Vec n a)
vecBundle# = traverse# id

instance KnownNat d => Bundle (RTree d a) where
  type Unbundled t (RTree d a) = RTree d (Signal t a)
  bundle   = sequenceA
  unbundle = sequenceA . fmap lazyT