clash-prelude-0.99: src/Clash/Signal/Bundle.hs
{-|
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