Bump circuit-notation version

cabal.project

@@ -13,4 +13,14 @@ package clash-prelude
 source-repository-package
   type: git
   location: https://github.com/cchalmers/circuit-notation.git
-  tag: 618e37578e699df235f2e7150108b6401731919b
+  tag: 565d4811cff6a597ee577dabd81b460e941fcb14
+
+package clash-protocols
+  -- Reduces compile times by ~20%
+  ghc-options: +RTS -qn4 -A128M -RTS -j4
+
+  -- Workaround for Haddock/CPP #if issues https://github.com/haskell/haddock/issues/1382
+  haddock-options: --optghc="-optP -P"
+
+  -- Don't pollute docs with large tuple instances
+  haddock-options: --optghc=-DHADDOCK_ONLY

clash-protocols.cabal

@@ -25,6 +25,14 @@ flag ci
     Manual: True
     Default: False
 
+flag large-tuples
+  description:
+    Generate instances for classes such as `Units` and `TaggedBundle` for tuples
+    up to and including 62 elements - the GHC imposed maximum. Note that this
+    greatly increases compile times for `clash-protocols`.
+  default: False
+  manual: True
+
 common common-options
   default-extensions:
     BangPatterns
@@ -122,6 +130,10 @@ custom-setup
 library
   import: common-options
   hs-source-dirs: src
+
+  if flag(large-tuples)
+    CPP-Options: -DLARGE_TUPLES
+
   build-depends:
       -- inline-circuit-notation
       circuit-notation
@@ -131,10 +143,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
@@ -160,11 +173,16 @@ library
     Protocols.Wishbone.Standard
     Protocols.Wishbone.Standard.Hedgehog
 
+    Protocols.Cpp
     Protocols.Df
     Protocols.DfConv
     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/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,58 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+
+{-# OPTIONS_HADDOCK hide #-}
+
+-- For debugging TH:
+-- {-# OPTIONS_GHC -ddump-splices #-}
+
+module Protocols.Internal.TaggedBundle where
+
+import Clash.Explicit.Prelude
+
+import Protocols.Internal.TaggedBundle.TH (taggedBundleTupleInstances)
+import Protocols.Cpp (maxTupleSize)
+
+import Data.Tagged
+
+-- | A bundle class that retains an attached phantom type @t@. I.e., a crossing
+-- between "Tagged" and "Bundle".
+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
+
+-- | A convenience pattern that bundles and unbundles. Can be used as an alternative
+-- to using @ViewPatterns@. I.e., the following:
+--
+-- > myFunction (taggedUnbundle -> ..)
+--
+-- can be written as:
+--
+-- > myFunction (TaggedBundle ..)
+--
+-- Is mostly used by "Protocols.Plugin".
+pattern TaggedBundle :: TaggedBundle t a => TaggedUnbundled t a -> Tagged t a
+pattern TaggedBundle a <- (taggedUnbundle -> a) where
+  TaggedBundle a = taggedBundle a
+{-# COMPLETE TaggedBundle #-}
+
+-- XXX: The following comment trick does not seem to work for TaggedBundle, but
+--      it does for Units. Weird!
+
+-- | __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.
+taggedBundleTupleInstances maxTupleSize

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,50 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# OPTIONS_HADDOCK hide #-}
+
+-- For debugging TH:
+-- {-# OPTIONS_GHC -ddump-splices #-}
+
+module Protocols.Internal.Units where
+
+import Clash.Explicit.Prelude
+
+import Protocols.Internal.Units.TH (unitsTupleInstances)
+import Protocols.Cpp (maxTupleSize)
+
+-- | Utilities for zero-width types. Is used by "Protocols.Plugin" to drive \"trivial\"
+-- backwards channels.
+class Units a where
+  -- | Only inhabitant of type @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
+
+-- | __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.
+unitsTupleInstances maxTupleSize

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,10 +2,15 @@
 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
+module Protocols.Plugin
+  ( plugin
+  , circuit
+  , (-<)
+  ) where
 
 -- base
 import           Prelude
@@ -16,6 +21,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
@@ -24,14 +32,35 @@ import qualified GhcPlugins as GHC
 #endif
 
 -- | 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'.
+-- | @circuit-notation@ plugin repurposed for "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
   }

stack.yaml

@@ -5,7 +5,7 @@ packages:
 
 extra-deps:
 - git: https://github.com/cchalmers/circuit-notation.git
-  commit: 618e37578e699df235f2e7150108b6401731919b
+  commit: 565d4811cff6a597ee577dabd81b460e941fcb14
 - tasty-hedgehog-1.2.0.0
 - clash-prelude-1.6.3
 - clash-prelude-hedgehog-1.6.3

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