Bump CircuitNotation version

cabal.project

@@ -13,4 +13,4 @@ package clash-prelude
 source-repository-package
   type: git
   location: https://github.com/cchalmers/circuit-notation.git
-  tag: 618e37578e699df235f2e7150108b6401731919b
+  tag: 565d4811cff6a597ee577dabd81b460e941fcb14

clash-protocols.cabal

@@ -131,10 +131,11 @@ library
     , ghc >= 8.7
     , hashable
     , hedgehog >= 1.0.2
+    , mtl
     , pretty-show
     , strict-tuple
-    , mtl
-    , hashable
+    , tagged
+    , template-haskell
 
       -- To be removed; we need 'Test.Tasty.Hedgehog.Extra' to fix upstream issues
     , tasty >= 1.2 && < 1.5
@@ -165,6 +166,10 @@ library
     Protocols.Hedgehog
     Protocols.Hedgehog.Internal
     Protocols.Internal
+    Protocols.Internal.TaggedBundle
+    Protocols.Internal.TaggedBundle.TH
+    Protocols.Internal.Units
+    Protocols.Internal.Units.TH
 
     Protocols.Plugin
 

src/Protocols.hs

@@ -55,8 +55,13 @@ module Protocols
 
     -- * Circuit notation plugin
   , circuit, (-<)
+  , module Protocols.Internal.Units
+  , module Protocols.Internal.TaggedBundle
   ) where
 
 import Data.Default (def)
 import Protocols.Internal
 import Protocols.Df (Df)
+
+import Protocols.Internal.Units
+import Protocols.Internal.TaggedBundle

src/Protocols/Df.hs

@@ -15,6 +15,8 @@ carries data, no metadata. For documentation see:
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
 module Protocols.Df
   ( -- * Types
     Df, Data(..)

src/Protocols/Hedgehog/Internal.hs

@@ -1,10 +1,13 @@
 {-|
 Internals for "Protocols.Hedgehog".
 -}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+{-# OPTIONS_HADDOCK hide #-}
 
 module Protocols.Hedgehog.Internal where
 

src/Protocols/Internal.hs

@@ -9,6 +9,8 @@ Internal module to prevent hs-boot files (breaks Haddock)
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- NFDataX and ShowX for Identity and Proxy
 
+{-# OPTIONS_HADDOCK hide #-}
+
 module Protocols.Internal where
 
 import           Control.DeepSeq (NFData)

src/Protocols/Internal/TaggedBundle.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+
+{-# OPTIONS_HADDOCK hide #-}
+
+-- {-# OPTIONS_GHC -ddump-splices #-}
+
+module Protocols.Internal.TaggedBundle where
+
+import Clash.Explicit.Prelude
+
+import Protocols.Internal.TaggedBundle.TH (taggedBundleTupleInstances)
+
+import Data.Tagged
+
+pattern TaggedBundle :: TaggedBundle t a => TaggedUnbundled t a -> Tagged t a
+pattern TaggedBundle a <- (taggedUnbundle -> a) where
+  TaggedBundle a = taggedBundle a
+{-# COMPLETE TaggedBundle #-}
+
+class TaggedBundle t a where
+  type TaggedUnbundled t a = res | res -> t a
+  taggedBundle :: TaggedUnbundled t a -> Tagged t a
+  taggedUnbundle :: Tagged t a -> TaggedUnbundled t a
+
+instance TaggedBundle () () where
+  type TaggedUnbundled () () = ()
+  taggedBundle = Tagged
+  taggedUnbundle = unTagged
+
+instance TaggedBundle (Vec n t) (Vec n a) where
+  type TaggedUnbundled (Vec n t) (Vec n a) = Vec n (Tagged t a)
+  taggedBundle = Tagged . fmap unTagged
+  taggedUnbundle = fmap Tagged . unTagged
+
+taggedBundleTupleInstances 10

src/Protocols/Internal/TaggedBundle/TH.hs

@@ -0,0 +1,56 @@
+{-# OPTIONS_HADDOCK hide #-}
+
+module Protocols.Internal.TaggedBundle.TH where
+
+import Data.Tagged
+import Language.Haskell.TH
+
+appTs :: Q Type -> [Q Type] -> Q Type
+appTs = foldl appT
+
+tupT :: [Q Type] -> Q Type
+tupT tyArgs = tupleT (length tyArgs) `appTs` tyArgs
+
+taggedBundleTupleInstances :: Int -> Q [Dec]
+taggedBundleTupleInstances n = mapM taggedBundleTupleInstance [2..n]
+
+taggedBundleTupleInstance :: Int -> Q Dec
+taggedBundleTupleInstance n =
+  instanceD
+    -- No superclasses
+    (pure [])
+
+    -- Head
+    (        taggedBundleCon
+      `appT` (tupleT n `appTs` tagTyVars)
+      `appT` (tupleT n `appTs` tyVars) )
+
+    -- Implementation
+    [ tySynInstD (tySynEqn Nothing aTypeLhs aTypeRhs)
+    , funD taggedBundleFunName [clause [bundlePat] (normalB bundleImpl) []]
+    , funD taggedUnbundleFunName [clause [unbundlePat] (normalB unbundleImpl) []]
+    ]
+
+ where
+  -- associated type
+  taggedUnbundledCon = conT (mkName "TaggedUnbundled")
+  taggedBundleCon = conT (mkName "TaggedBundle")
+  aTypeLhs = taggedUnbundledCon `appT` tupT tagTyVars `appT` tupT tyVars
+  aTypeRhs = tupT (zipWith mkTaggedTy tagTyVars tyVars)
+  mkTaggedTy ta a = conT ''Tagged `appT` ta `appT` a
+
+  -- bundle
+  taggedBundleFunName = mkName "taggedBundle"
+  bundlePat = tupP (map (conP 'Tagged . pure . varP) varNames)
+  bundleImpl = conE 'Tagged `appE` tupE vars
+
+  -- unbundle
+  taggedUnbundleFunName = mkName "taggedUnbundle"
+  unbundlePat = conP 'Tagged [tupP (map varP varNames)]
+  unbundleImpl = tupE [conE 'Tagged `appE` v | v <- vars]
+
+  -- shared
+  tagTyVars = map (varT . mkName . ('t':) . show) [1..n]
+  tyVars = map varT varNames
+  vars = map varE varNames
+  varNames = map (mkName . ('a':) . show) [1..n]

src/Protocols/Internal/Units.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# OPTIONS_HADDOCK hide #-}
+
+module Protocols.Internal.Units where
+
+import Clash.Explicit.Prelude
+
+import Protocols.Internal.Units.TH (unitsTupleInstances)
+
+-- | Utilities for zero-width types. Is used by "Protocols.Plugin" to drive \"trivial\"
+-- backwards channels.
+class Units a where
+  -- | Only inhabitant of @a@
+  units :: a
+
+instance Units () where
+  units = ()
+
+instance Units (Signed 0) where
+  units = 0
+
+instance Units (Unsigned 0) where
+  units = 0
+
+instance Units (BitVector 0) where
+  units = 0
+
+instance Units (Index 0) where
+  units = 0
+
+instance Units (Index 1) where
+  units = 0
+
+instance (Units a) => Units (Signal dom a) where
+  units = pure units
+
+instance (Units a, KnownNat n) => Units (Vec n a) where
+  units = repeat units
+
+-- TODO: Integrate with clash-prelude's Clash.CPP
+unitsTupleInstances 10

src/Protocols/Internal/Units/TH.hs

@@ -0,0 +1,24 @@
+{-# OPTIONS_HADDOCK hide #-}
+
+module Protocols.Internal.Units.TH where
+
+import Language.Haskell.TH
+
+appTs :: Q Type -> [Q Type] -> Q Type
+appTs = foldl appT
+
+unitsTupleInstances :: Int -> Q [Dec]
+unitsTupleInstances n = mapM unitsTupleInstance [2..n]
+
+unitsTupleInstance :: Int -> Q Dec
+unitsTupleInstance n =
+  instanceD
+    (mapM (\v -> unitsConT `appT` v) tyVars) -- context
+    (unitsConT `appT` (tupleT n `appTs` tyVars)) -- head
+    [funD unitsFunName [clause [] (normalB (tupE [unitsFun | _ <- tyVars])) []]] -- impl
+
+ where
+  unitsFun = varE unitsFunName
+  unitsFunName = mkName "units"
+  unitsConT = conT (mkName "Units")
+  tyVars = map (varT . mkName . ('a':) . show) [1..n]

src/Protocols/Plugin.hs

@@ -2,8 +2,9 @@
 A GHC source plugin providing a DSL for writing Circuit components. Credits to
 @circuit-notation@ at <https://github.com/cchalmers/circuit-notation>.
 -}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module Protocols.Plugin where
 
@@ -16,6 +17,9 @@ import           Protocols
 -- circuit-notation
 import qualified CircuitNotation as CN
 
+-- tagged
+import Data.Tagged
+
 -- ghc
 #if __GLASGOW_HASKELL__ >= 900
 import qualified GHC.Plugins as GHC
@@ -26,12 +30,35 @@ import qualified GhcPlugins as GHC
 -- | Type inference helper used by circuit-notation plugin
 type CircuitT a b = (Fwd a, Bwd b) -> (Bwd a, Fwd b)
 
+type TaggedCircuitT a b =
+  (Tagged a (Fwd a), Tagged b (Bwd b)) ->
+  (Tagged a (Bwd a), Tagged b (Fwd b))
+
+mkTagCircuit :: TaggedCircuitT a b -> Circuit a b
+mkTagCircuit f = Circuit $ \ (aFwd, bBwd) -> let
+    (Tagged aBwd, Tagged bFwd) = f (Tagged aFwd, Tagged bBwd)
+  in (aBwd, bFwd)
+
+runTagCircuit :: Circuit a b -> TaggedCircuitT a b
+runTagCircuit (Circuit c) (aFwd, bBwd) = let
+    (aBwd, bFwd) = c (unTagged aFwd, unTagged bBwd)
+  in (Tagged aBwd, Tagged bFwd)
+
+pattern TaggedCircuit :: TaggedCircuitT a b -> Circuit a b
+pattern TaggedCircuit f <- (runTagCircuit -> f) where
+  TaggedCircuit f = mkTagCircuit f
+
 -- | 'circuit-notation' plugin repurposed for 'Protocols.protocols'.
 plugin :: GHC.Plugin
 plugin = CN.mkPlugin $ CN.ExternalNames
-  { CN.circuitCon = CN.thName 'Circuit
-  , CN.circuitTyCon = CN.thName ''Circuit
-  , CN.circuitTTyCon = CN.thName ''CircuitT
-  , CN.runCircuitName = CN.thName 'toSignals
+  { CN.circuitCon = CN.thName 'TaggedCircuit
+  , CN.fwdAndBwdTypes = \case
+      CN.Fwd -> CN.thName ''Fwd
+      CN.Bwd -> CN.thName ''Bwd
   , CN.fwdBwdCon = CN.thName '(,)
+  , CN.runCircuitName = CN.thName 'runTagCircuit
+  , CN.tagBundlePat = CN.thName 'TaggedBundle
+  , CN.tagName = CN.thName 'Tagged
+  , CN.tagTName = CN.thName ''Tagged
+  , CN.trivialBwd = CN.thName 'units
   }

tests/Tests/Protocols/Plugin.hs

@@ -4,6 +4,9 @@
 -- want to add this to 'ghc-options' in your cabal file.
 {-# OPTIONS -fplugin=Protocols.Plugin #-}
 
+-- For debugging purposes:
+-- {-# OPTIONS -fplugin-opt=Protocols.Plugin:debug #-}
+
 module Tests.Protocols.Plugin where
 
 import qualified Clash.Prelude as C