Tagged implementation

example/Example.hs

@@ -36,7 +36,7 @@ module Example where
 
 import           Circuit
 
-import           Clash.Prelude (Signal, Vec (..))
+import           Clash.Prelude
 
 idCircuit :: Circuit a a
 idCircuit = idC
@@ -88,14 +88,25 @@ sigExpr sig = circuit do
 -- sigPat :: (( Signal Int -> Signal Int ))
 sigPat :: Circuit (Signal domain Int) (Signal domain Int)
 sigPat = circuit $ \(Signal a) -> do
-  i <- (idC :: Circuit (Signal domain Int) (Signal domain Int)) -< Signal a
+  i <- idC -< Signal a
   idC -< i
 
 sigPat2 :: Circuit (Signal dom Int) (Signal dom Int)
 sigPat2 = circuit $ \(Signal a) -> do
   i <- (idC :: Circuit (Signal dom Int) (Signal dom Int)) -< Signal a
   idC -< i
 
+fwdCircuit :: Circuit (Vec 3 (Signal dom Int)) (Vec 3 (Signal dom Int))
+fwdCircuit = circuit $ \(Fwd x) -> do
+  i <- idC -< Fwd (fmap (+1) x)
+  idC -< i
+
+fwdWithLetCircuit :: KnownNat n => Circuit (Vec n (Signal dom Int)) (Vec n (Signal dom Int))
+fwdWithLetCircuit = circuit $ \(Fwd x) -> do
+  let y = fmap (+1) x
+  i <- idC -< Fwd y
+  idC -< i
+
 fstC :: Circuit (Signal domain a, Signal domain b) (Signal domain a)
 fstC = circuit $ \(a, _b) -> do idC -< a
 
@@ -122,6 +133,21 @@ unfstC3 = circuit $ \a -> do
   ab' <- idC -< ab
   idC -< ab'
 
+-- a version of `idC` on `Signal domain Int` which has bad type inference.
+idCHard
+  :: (Fwd a ~ Signal domain Int, Bwd a ~ (), Fwd b ~ Signal domain Int, Bwd b ~ ())
+  => Circuit a b
+idCHard = Circuit $ \ (aFwd :-> ()) -> () :-> aFwd
+
+typedBus1 :: forall domain . Circuit (Signal domain Int) (Signal domain Int)
+typedBus1 = circuit $ \a -> do
+  (b :: Signal domain Int) <- idCHard -< a
+  idCHard -< b
+
+typedBus2 :: forall domain . Circuit (Signal domain Int) (Signal domain Int)
+typedBus2 = circuit $ \a -> do
+  b <- idCHard -< a
+  idCHard -< (b :: Signal domain Int)
 
 swapTest :: forall a b. Circuit (a,b) (b,a)
 -- swapTest = circuit $ \(a,b) -> (idCircuit :: Circuit (b, a) (b, a)) -< (b, a)
@@ -152,16 +178,16 @@ dupSignalC1 = circuit $ \x -> do
 -- -- myDesire = Circuit (\(aM2S,bS2M) -> let
 -- --   (aM2S', bS2M') = runCircuit myCircuit (aM2S, bS2M)
 -- --   in (aM2S', bS2M'))
-
+--
 -- -- var :: (Int, Int)
 -- -- var = (3, 5)
-
+--
 -- -- myLet :: Int
 -- -- myLet = let (yo, yo') = var in yo
-
+--
 -- -- ah :: (Int,Int)
 -- -- ah = (7,11)
-
+--
 -- -- tupCir1 :: Circuit (Int, Char) (Char, Int)
 -- -- tupCir1 = circuit \ input -> do
 -- --   (c,i) <- swapC @Int -< input
@@ -170,7 +196,7 @@ dupSignalC1 = circuit $ \x -> do
 -- --   c' <- myCircuitRev -< c
 -- --   c'' <- myIdCircuit -< c'
 -- --   idC -< (i', c'')
-
+--
 -- tupleCircuit :: Circuit Int Char
 -- tupleCircuit = id $ circuit \a -> do
 --   let b = 3
@@ -179,15 +205,15 @@ dupSignalC1 = circuit $ \x -> do
 --   b' <- myCircuit -< a'
 --   b'' <- (circuit \aa -> do idC -< aa) -< b'
 --   idC -< b''
-
+--
 -- -- simpleCircuit :: Circuit Int Char
 -- -- simpleCircuit = id $ circuit \a -> do
 -- --   b <- (circuit \a -> do b <- myCircuit -< a;idC -< b) -< a
 -- --   a' <- myCircuitRev -< b
 -- --   b' <- myCircuit -< a'
 -- --   b'' <- (circuit \aa -> do idC -< aa) -< b'
 -- --   idC -< b''
-
+--
 -- myCircuit :: Int
 -- myCircuit = circuit \(v1 :: DF d a) (v3 :: blah) -> do
 --   v1' <- total -< (v3 :: DF domain Int) -< (v4 :: DF domain Int)
@@ -196,39 +222,39 @@ dupSignalC1 = circuit $ \x -> do
 --   -- v2' <- total2 -< v2
 --   -- v3 <- zipC -< (v1', v2')
 --   v1 <- idC -< v3
-
+--
 -- -- type RunCircuit a b = (Circuit a b -> (M2S a, S2M b) -> (M2S b, S2M a))
 -- -- type CircuitId a b = Circuit a b -> Circuit a b
-
+--
 -- -- myCircuit = let
 -- --   _circuits :: (RunCircuit a b, RunCircuit c d, RunCircuit (b,d) e, CircuitId (a,c) e)
 -- --   _circuits@(runC1, runC2, runC2, cId) = (runCircuit, runCircuit, runCircuit, id)
-
+--
 -- --   in cId $ Circuit $ \((v1M2S, v2M2S),outputS2M) -> let
-
+--
 -- --   (v1'M2S, v1S2M) = runC1 total (v1M2s, v1'S2M)
 -- --   (v2'M2S, v2S2M) = runC2 total2 (v2M2s, v2'S2M)
 -- --   (v3M2S, (v1'S2M, v2'S2M)) = runC3 zipC ((v1'M2S, v2'M2S), v3S2M)
-
+--
 -- --   in (v3M2S, (v1S2M, v2S2M))
-
-
-
-
+--
+--
+--
+--
 --   -- circuitHelper
 --   --   :: Circuit a b
 --   --   -> Circuit c d
 --   --   -> Circuit (b,d) e
-
-
+--
+--
 -- -- myCircuit :: Int
 -- -- myCircuit = circuit (\(v1,v2) -> (v2,v1))
-
+--
 -- -- myCircuit :: Int
 -- -- myCircuit = circuit do
 -- --   (v2,v1) <- yeah
 -- --   idC -< (v1, v2)
-
+--
 -- -- myCircuit = proc v1 -> do
 -- --   x <- total -< value
 --   -- fin -< a

shell.nix

@@ -8,8 +8,8 @@ stdenv.mkDerivation {
 
   buildInputs = [
     ghc
-    # cabal-install
-    # haskellPackages.ghcid
+    cabal-install
+    haskellPackages.ghcid
     haskellPackages.stylish-haskell
   ];
 

src/Circuit.hs

@@ -10,15 +10,18 @@
 This file contains the 'Circuit' type, that the notation describes.
 -}
 
-{-# LANGUAGE DeriveFunctor       #-}
-{-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE PatternSynonyms     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE PatternSynonyms        #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE ViewPatterns           #-}
 
 module Circuit where
 
@@ -70,6 +73,26 @@ type instance Bwd (Signal dom a) = ()
 newtype Circuit a b = Circuit { runCircuit :: CircuitT a b }
 type CircuitT a b = (Fwd a :-> Bwd b) -> (Bwd a :-> Fwd b)
 
+
+type TagCircuitT a b = (BusTag a (Fwd a) :-> BusTag b (Bwd b)) -> (BusTag a (Bwd a) :-> BusTag b (Fwd b))
+
+newtype BusTag t b = BusTag {unBusTag :: b}
+
+mkTagCircuit :: TagCircuitT a b -> Circuit a b
+mkTagCircuit f = Circuit $ \ (aFwd :-> bBwd) -> let
+    (BusTag aBwd :-> BusTag bFwd) = f (BusTag aFwd :-> BusTag bBwd)
+  in (aBwd :-> bFwd)
+
+runTagCircuit :: Circuit a b -> TagCircuitT a b
+runTagCircuit (Circuit c) (aFwd :-> bBwd) = let
+    (aBwd :-> bFwd) = c (unBusTag aFwd :-> unBusTag bBwd)
+  in (BusTag aBwd :-> BusTag bFwd)
+
+pattern TagCircuit :: TagCircuitT a b -> Circuit a b
+pattern TagCircuit f <- (runTagCircuit -> f) where
+  TagCircuit f = mkTagCircuit f
+
+
 class TrivialBwd a where
   unitBwd :: a
 
@@ -96,3 +119,83 @@ instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e)
 
 instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f) => TrivialBwd (a,b,c,d,e,f) where
   unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)
+
+instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g) => TrivialBwd (a,b,c,d,e,f,g) where
+  unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)
+
+instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h) => TrivialBwd (a,b,c,d,e,f,g,h) where
+  unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)
+
+instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h, TrivialBwd i) => TrivialBwd (a,b,c,d,e,f,g,h,i) where
+  unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)
+
+instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h, TrivialBwd i, TrivialBwd j) => TrivialBwd (a,b,c,d,e,f,g,h,i,j) where
+  unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)
+
+instance TrivialBwd a => TrivialBwd (BusTag t a) where
+  unitBwd = BusTag unitBwd
+
+class BusTagBundle t a where
+  type BusTagUnbundled t a = res | res -> t a
+  taggedBundle :: BusTagUnbundled t a -> BusTag t a
+  taggedUnbundle :: BusTag t a -> BusTagUnbundled t a
+
+instance BusTagBundle () () where
+  type BusTagUnbundled () () = ()
+  taggedBundle = BusTag
+  taggedUnbundle = unBusTag
+
+instance BusTagBundle (ta, tb) (a, b) where
+  type BusTagUnbundled (ta, tb) (a, b) = (BusTag ta a, BusTag tb b)
+  taggedBundle (BusTag a, BusTag b) = BusTag (a, b)
+  taggedUnbundle (BusTag (a, b)) =  (BusTag a, BusTag b)
+
+instance BusTagBundle (ta, tb, tc) (a, b, c) where
+  type BusTagUnbundled (ta, tb, tc) (a, b, c) = (BusTag ta a, BusTag tb b, BusTag tc c)
+  taggedBundle (BusTag a, BusTag b, BusTag c) = BusTag (a, b, c)
+  taggedUnbundle (BusTag (a, b, c)) =  (BusTag a, BusTag b, BusTag c)
+
+instance BusTagBundle (ta, tb, tc, td) (a, b, c, d) where
+  type BusTagUnbundled (ta, tb, tc, td) (a, b, c, d) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d)
+  taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d) = BusTag (a, b, c, d)
+  taggedUnbundle (BusTag (a, b, c, d)) =  (BusTag a, BusTag b, BusTag c, BusTag d)
+
+instance BusTagBundle (ta, tb, tc, td, te) (a, b, c, d, e) where
+  type BusTagUnbundled (ta, tb, tc, td, te) (a, b, c, d, e) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e)
+  taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e) = BusTag (a, b, c, d, e)
+  taggedUnbundle (BusTag (a, b, c, d, e)) =  (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e)
+
+instance BusTagBundle (ta, tb, tc, td, te, tf) (a, b, c, d, e, f) where
+  type BusTagUnbundled (ta, tb, tc, td, te, tf) (a, b, c, d, e, f) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f)
+  taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f) = BusTag (a, b, c, d, e, f)
+  taggedUnbundle (BusTag (a, b, c, d, e, f)) =  (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f)
+
+instance BusTagBundle (ta, tb, tc, td, te, tf, tg) (a, b, c, d, e, f, g) where
+  type BusTagUnbundled (ta, tb, tc, td, te, tf, tg) (a, b, c, d, e, f, g) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g)
+  taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g) = BusTag (a, b, c, d, e, f, g)
+  taggedUnbundle (BusTag (a, b, c, d, e, f, g)) =  (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g)
+
+instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th) (a, b, c, d, e, f, g, h) where
+  type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th) (a, b, c, d, e, f, g, h) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h)
+  taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h) = BusTag (a, b, c, d, e, f, g, h)
+  taggedUnbundle (BusTag (a, b, c, d, e, f, g, h)) =  (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h)
+
+instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th, ti) (a, b, c, d, e, f, g, h, i) where
+  type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti) (a, b, c, d, e, f, g, h, i) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h, BusTag ti i)
+  taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i) = BusTag (a, b, c, d, e, f, g, h, i)
+  taggedUnbundle (BusTag (a, b, c, d, e, f, g, h, i)) =  (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i)
+
+instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th, ti, tj) (a, b, c, d, e, f, g, h, i, j) where
+  type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti, tj) (a, b, c, d, e, f, g, h, i, j) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h, BusTag ti i, BusTag tj j)
+  taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j) = BusTag (a, b, c, d, e, f, g, h, i, j)
+  taggedUnbundle (BusTag (a, b, c, d, e, f, g, h, i, j)) =  (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j)
+
+instance BusTagBundle (Vec n t) (Vec n a) where
+  type BusTagUnbundled (Vec n t) (Vec n a) = Vec n (BusTag t a)
+  taggedBundle = BusTag . fmap unBusTag
+  taggedUnbundle = fmap BusTag . unBusTag
+
+pattern BusTagBundle :: BusTagBundle t a => BusTagUnbundled t a -> BusTag t a
+pattern BusTagBundle a <- (taggedUnbundle -> a) where
+  BusTagBundle a = taggedBundle a
+{-# COMPLETE BusTagBundle #-}