packages feed

clash-protocols-base (empty) → 0.1

raw patch · 13 files changed

+734/−0 lines, 13 filesdep +Cabaldep +basedep +circuit-notationsetup-changed

Dependencies added: Cabal, base, circuit-notation, clash-prelude, deepseq, extra, ghc, hashable, tagged, template-haskell

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for `clash-protocols`++## 0.1 -- 28-04-2026++* First release
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) 2024, Martijn Bastiaan+              2024-2026, QBayLogic B.V.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,5 @@+import Distribution.Simple+import Prelude++main :: IO ()+main = defaultMain
+ clash-protocols-base.cabal view
@@ -0,0 +1,92 @@+cabal-version: 2.4+name: clash-protocols-base+synopsis: Internal support package for clash-protocols; use clash-protocols instead.+homepage: https://github.com/clash-lang/clash-protocols+bug-reports: https://github.com/clash-lang/clash-protocols/issues+version: 0.1+category: Hardware+license: BSD-2-Clause+license-file: LICENSE+author: Martijn Bastiaan, QBayLogic B.V.+maintainer: QBayLogic B.V. <devops@qbaylogic.com>+extra-doc-files:+  CHANGELOG.md+description:+  Internal core plugin and protocol support types for the clash-protocols+  package family. Users should depend on @clash-protocols@ instead.++source-repository head+  type: git+  location: https://github.com/clash-lang/clash-protocols.git++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-base`.++  default: False+  manual: True++common common-options+  default-extensions:+    -- TemplateHaskell is used to support convenience functions such as+    -- 'listToVecTH' and 'bLit'.+    CPP+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DerivingStrategies+    LambdaCase+    NoStarIsType+    OverloadedRecordDot+    QuasiQuotes+    TemplateHaskell+    TupleSections+    TypeFamilies+    ViewPatterns++  -- Prelude isn't imported by default as Clash offers Clash.Prelude+  -- NoImplicitPrelude+  ghc-options:+    -- `-fexpose-all-unfoldings` is required because clash needs access to the+    -- source code in compiled modules+    -Wall+    -Wcompat+    -fexpose-all-unfoldings++  default-language: GHC2021+  build-depends:+    Cabal >=3.12 && <3.17,+    base >=4.18 && <5,+    clash-prelude >=1.10 && <1.12,++library+  import: common-options+  hs-source-dirs: src++  if flag(large-tuples)+    cpp-options: -DLARGE_TUPLES+  build-depends:+    circuit-notation >=0.2 && <0.3,+    deepseq >=1.4.1 && <1.6,+    extra >=1.6.17 && <1.9,+    ghc >=9.6 && <9.13,+    hashable >=1.4.1 && <1.6,+    tagged >=0.8 && <0.9,+    template-haskell >=2.20 && <2.24,++  exposed-modules:+    Protocols.Plugin+    Protocols.Plugin.Cpp+    Protocols.Plugin.Internal+    Protocols.Plugin.TH+    Protocols.Plugin.TaggedBundle+    Protocols.Plugin.TaggedBundle.TH+    Protocols.Plugin.Units+    Protocols.Plugin.Units.TH++  other-modules:+    Protocols.Plugin.Types++  default-language: GHC2021
+ src/Protocols/Plugin.hs view
@@ -0,0 +1,123 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+A GHC source plugin providing a DSL for writing Circuit components. Credits to+@circuit-notation@ at <https://github.com/cchalmers/circuit-notation>.+-}+module Protocols.Plugin (+  -- * Circuit types+  Circuit (..),+  Protocol (..),+  ToConst,+  ToConstBwd,++  -- * clash-prelude related types+  CSignal,++  -- * plugin functions+  plugin,+  circuit,+  (-<),+) where++-- base++import Data.Kind (Type)+import Prelude++-- clash-prelude+import Clash.Explicit.Prelude qualified as C++-- clash-protocols+import Protocols.Plugin.Cpp+import Protocols.Plugin.Internal+import Protocols.Plugin.TH+import Protocols.Plugin.TaggedBundle+import Protocols.Plugin.Types+import Protocols.Plugin.Units++-- circuit-notation+import CircuitNotation qualified as CN++-- tagged+import Data.Tagged++-- ghc+import GHC.Plugins qualified as GHC++instance Protocol () where+  type Fwd () = ()+  type Bwd () = ()++{- | __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.+-}+instance Protocol (a, b) where+  type Fwd (a, b) = (Fwd a, Fwd b)+  type Bwd (a, b) = (Bwd a, Bwd b)++-- Generate n-tuple instances, where n > 2+protocolTupleInstances 3 maxTupleSize++{- | A protocol that carries a constant value in the forward direction and no+information in the backward direction.+-}+data ToConst (a :: Type)++instance Protocol (ToConst a) where+  type Fwd (ToConst a) = a+  type Bwd (ToConst a) = ()++{- | A protocol that carries no information in the forward direction and a+constant value in the backward direction.+-}+data ToConstBwd (a :: Type)++instance Protocol (ToConstBwd a) where+  type Fwd (ToConstBwd a) = ()+  type Bwd (ToConstBwd a) = a++instance (C.KnownNat n) => Protocol (C.Vec n a) where+  type Fwd (C.Vec n a) = C.Vec n (Fwd a)+  type Bwd (C.Vec n a) = C.Vec n (Bwd a)++-- XXX: Type families with Signals on LHS are currently broken on Clash:+instance Protocol (CSignal dom a) where+  type Fwd (CSignal dom a) = C.Signal dom a+  type Bwd (CSignal dom a) = ()++instance Protocol (C.Clock dom) where+  type Fwd (C.Clock dom) = C.Clock dom+  type Bwd (C.Clock dom) = ()++instance Protocol (C.DiffClock dom) where+  type Fwd (C.DiffClock dom) = C.DiffClock dom+  type Bwd (C.DiffClock dom) = ()++instance Protocol (C.Reset dom) where+  type Fwd (C.Reset dom) = C.Reset dom+  type Bwd (C.Reset dom) = ()++instance Protocol (C.Enable dom) where+  type Fwd (C.Enable dom) = C.Enable dom+  type Bwd (C.Enable dom) = ()++-- | @circuit-notation@ plugin repurposed for "Protocols".+plugin :: GHC.Plugin+plugin =+  CN.mkPlugin $+    CN.ExternalNames+      { 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 'taggedCircuit+      , CN.tagBundlePat = CN.thName 'TaggedBundle+      , CN.tagName = CN.thName 'Tagged+      , CN.tagTName = CN.thName ''Tagged+      , CN.trivialBwd = CN.thName 'units+      , CN.consPat = CN.thName '(:>!)+      }
+ src/Protocols/Plugin/Cpp.hs view
@@ -0,0 +1,43 @@+{-|+Copyright  :  (C) 2019     , Myrtle Software Ltd,+                  2023     , QBayLogic B.V.,+                  2024     , Google LLC+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Compile-time dependent constants. Inspired by @clash-prelude@'s @Clash.CPP@.+-}+++{-# OPTIONS_HADDOCK hide #-}++module Protocols.Plugin.Cpp+ ( maxTupleSize+ , haddockOnly+ ) where++#ifndef MAX_TUPLE_SIZE+#ifdef LARGE_TUPLES++import GHC.Settings.Constants (mAX_TUPLE_SIZE)++#define MAX_TUPLE_SIZE (fromIntegral mAX_TUPLE_SIZE)++#else+#ifdef HADDOCK_ONLY+#define MAX_TUPLE_SIZE 3+#else+#define MAX_TUPLE_SIZE 12+#endif+#endif+#endif++maxTupleSize :: Num a => a+maxTupleSize = MAX_TUPLE_SIZE++haddockOnly :: Bool+#ifdef HADDOCK_ONLY+haddockOnly = True+#else+haddockOnly = False+#endif
+ src/Protocols/Plugin/Internal.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++module Protocols.Plugin.Internal where++import Clash.Explicit.Prelude++import Data.Tagged+import GHC.Base (Any)+import Protocols.Plugin.Types++{- | Picked up by "Protocols.Plugin" to process protocol DSL. See+"Protocols.Plugin" for more information.+-}+circuit :: Any+circuit =+  error "'circuit' called: did you forget to enable \"Protocols.Plugin\"?"++{- | Picked up by "Protocols.Plugin" to tie circuits together. See+"Protocols.Plugin" for more information.+-}+(-<) :: Any+(-<) =+  error "(-<) called: did you forget to enable \"Protocols.Plugin\"?"++{- | Convenience type alias. A circuit where all parts are decorated with a+tag, referring to the @a@ and @b@ in its main signature. This is (indirectly)+used by the plugin to help GHC's type inference.+-}+type TaggedCircuitT a b =+  (Tagged a (Fwd a), Tagged b (Bwd b)) ->+  (Tagged a (Bwd a), Tagged b (Fwd b))++-- | Remove tags from a tagged "Circuit", leaving just a "Circuit".+unTaggedCircuit :: TaggedCircuitT a b -> Circuit a b+unTaggedCircuit f = Circuit $ \(aFwd, bBwd) ->+  let (Tagged aBwd, Tagged bFwd) = f (Tagged aFwd, Tagged bBwd)+   in (aBwd, bFwd)++-- | Add tags to a "Circuit", making a "TaggedCircuitT".+taggedCircuit :: Circuit a b -> TaggedCircuitT a b+taggedCircuit (Circuit c) (aFwd, bBwd) =+  let (aBwd, bFwd) = c (unTagged aFwd, unTagged bBwd)+   in (Tagged aBwd, Tagged bFwd)++-- | Convenience pattern for 'unTaggedCircuit' and 'taggedCircuit'.+pattern TaggedCircuit :: TaggedCircuitT a b -> Circuit a b+pattern TaggedCircuit f <- (taggedCircuit -> f)+  where+    TaggedCircuit f = unTaggedCircuit f++{- | Unsafe version of ':>'. Will fail if applied to empty vectors. This is used to+work around spurious incomplete pattern match warnings generated in newer GHC+versions.+-}+pattern (:>!) :: a -> Vec n a -> Vec (n + 1) a+pattern (:>!) x xs <- (\ys -> (head ys, tail ys) -> (x, xs))++{-# COMPLETE (:>!) #-}+infixr 5 :>!
+ src/Protocols/Plugin/TH.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_HADDOCK hide #-}++module Protocols.Plugin.TH where++import Language.Haskell.TH++appTs :: Q Type -> [Q Type] -> Q Type+appTs = foldl appT++-- | Generate @Protocol@ instances for n-tuples+protocolTupleInstances :: Int -> Int -> Q [Dec]+protocolTupleInstances n m = mapM protocolTupleInstance [n .. m]++protocolTupleInstance :: Int -> Q Dec+protocolTupleInstance n =+  instanceD+    (pure []) -- context+    (protocolConT `appT` tup) -- head+    [mkTyInst fwdConName, mkTyInst bwdConName] -- body+ where+  fwdConName = mkName "Fwd"+  bwdConName = mkName "Bwd"+  protocolConT = conT (mkName "Protocol")++  tyVars :: [TypeQ]+  tyVars = map (varT . mkName . ('a' :) . show) [1 .. n]++  tup = tupleT n `appTs` tyVars++  mkTyInst :: Name -> DecQ+  mkTyInst con =+    tySynInstD $ tySynEqn Nothing lhs rhs+   where+    lhs, rhs :: TypeQ+    lhs = conT con `appT` tup+    rhs = tupleT n `appTs` map (conT con `appT`) tyVars
+ src/Protocols/Plugin/TaggedBundle.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# OPTIONS_HADDOCK hide #-}++-- For debugging TH:+-- {-# OPTIONS_GHC -ddump-splices #-}++module Protocols.Plugin.TaggedBundle where++import Clash.Explicit.Prelude++import Protocols.Plugin.Cpp (maxTupleSize)+import Protocols.Plugin.TaggedBundle.TH (taggedBundleTupleInstances)++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+  -- | Unbundled representation that preserves the phantom tag @t@.+  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 #-}++{- | __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.+-}+instance TaggedBundle (t1, t2) (a1, a2) where+  type TaggedUnbundled (t1, t2) (a1, a2) = (Tagged t1 a1, Tagged t2 a2)+  taggedBundle (Tagged a1, Tagged a2) = Tagged (a1, a2)+  taggedUnbundle (Tagged (a1, a2)) = (Tagged a1, Tagged a2)++-- Generate n-tuple instances, where n > 2+taggedBundleTupleInstances maxTupleSize
+ src/Protocols/Plugin/TaggedBundle/TH.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_HADDOCK hide #-}++module Protocols.Plugin.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 [3 .. 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/Plugin/Types.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE RoleAnnotations #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+These class definitions are needed to be able to write Template Haskell quotes+for instances. They are defined separately to avoid import loops.++This module is not exported; the classes and their (orphan) instances are+exported elsewhere.+-}+module Protocols.Plugin.Types where++import Clash.Signal+import Data.Kind (Type)++-- | A protocol describes the in- and outputs of one side of a t'Circuit'.+class Protocol a where+  {- | Sender to receiver type family. See t'Circuit' for an explanation on the+  existence of 'Fwd'.+  -}+  type Fwd (a :: Type)++  type Fwd a = a++  {- | Receiver to sender type family. See t'Circuit' for an explanation on the+  existence of 'Bwd'.+  -}+  type Bwd (a :: Type)++  type Bwd a = ()++{- | A /Circuit/, in its most general form, corresponds to a component with two+pairs of an input and output. As a diagram:++@+            Circuit a b++           +-----------++    Fwd a  |           |  Fwd b+  +------->+           +-------->+           |           |+           |           |+    Bwd a  |           |  Bwd b+  <--------+           +<-------++           |           |+           +-----------++@++The first pair, @(Fwd a, Bwd a)@ can be thought of the data sent to and from+the component on the left hand side of this circuit. For this pair, @Fwd a@+is the data sent from the circuit on the left hand side (not pictured), while+@Bwd a@ is the data sent to the left hand side from the current circuit.++Similarly, the second pair, @(Fwd b, Bwd)@, can be thought of as the data+sent to and from the right hand side of this circuit. In this case, @Fwd b@+is the data sent from the current circuit to the one on the right hand side,+while @Bwd b@ is the data received from the right hand side.++In Haskell terms, we would say this is simply a function taking two inputs,+@Fwd a@ and @Bwd b@, yielding a pair of outputs @Fwd b@ and @Bwd a@. This is+in fact exactly its definition:++@+  newtype Circuit a b =+    Circuit ( (Fwd a, Bwd b) -> (Bwd a, Fwd b) )+@++Note that the type parameters /a/ and /b/ don't directly correspond to the+types of the inputs and outputs of this function. Instead, the type families+'Fwd' and 'Bwd' decide this. The type parameters can be thought of as+deciders for what /protocol/ the left hand side and right hand side must+speak.++Let's make it a bit more concrete by building such a protocol. For this+example, we'd like to build a protocol that sends data to a circuit, while+allowing the circuit to signal whether it processed the sent data or not. Similarly,+we'd like the sender to be able to indicate that it doesn't have any data to+send. These kind of protocols fall under the umbrella of "dataflow" protocols,+so lets call it /DataFlowSimple/ or /Df/ for short:++@+  data Df (dom :: Domain) (a :: Type)+@++We're only going to use it on the type level, so we won't need any+constructors for this datatype. The first type parameter indicates the+synthesis domain the protocol will use. This is the same /dom/ as used in+/Signal dom a/. The second type indicates what data the protocol needs to+send. Again, this is similar to the /a/ in /Signal dom a/.++As said previously, we'd like the sender to either send /no data/ or+/some data/. We can capture this in a /Maybe/.++On the way back, we'd like to either acknowledge or not acknowledge sent+data. Similar to /Bool/ we define:++@+  newtype Ack = Ack Bool+@++With these three definitions we're ready to make an instance for /Fwd/ and+/Bwd/:++@+instance Protocol (Df dom a) where+  type Fwd (Df dom a) = Signal dom (Maybe a)+  type Bwd (Df dom a) = Signal dom Ack+@++Having defined all this, we can take a look at /Circuit/ once more: now+instantiated with our types. The following:++@+  f :: Circuit (Df dom a) (Df dom b)+@++..now corresponds to the following protocol:++@+                           +-----------++      Signal dom (Maybe a)  |           |  Signal dom (Maybe b)+ +------------------------>+           +------------------------->+                           |           |+                           |           |+      Signal dom Ack       |           |  Signal dom Ack+ <-------------------------+           +<------------------------++                           |           |+                           +-----------++@++There's a number of advantages over manually writing out these function+types:++  1. It reduces syntactical noise in type signatures++  2. It eliminates the need for manually routing acknowledgement lines+-}+newtype Circuit a b+  = Circuit ((Fwd a, Bwd b) -> (Bwd a, Fwd b))++{- | Circuit protocol with /Signal dom a/ in its forward direction, and+/()/ in its backward direction. Convenient for exposing protocol+internals, or simply for undirectional streams.+Note: 'CSignal' exists to work around [issue 760](https://github.com/clash-lang/clash-compiler/issues/760)+      in Clash, where type families with 'Signal' on the LHS are broken.+-}+data CSignal (dom :: Domain) (a :: Type)++type role CSignal nominal representational
+ src/Protocols/Plugin/Units.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++-- For debugging TH:+-- {-# OPTIONS_GHC -ddump-splices #-}++module Protocols.Plugin.Units where++import Clash.Explicit.Prelude++import Protocols.Plugin.Cpp (maxTupleSize)+import Protocols.Plugin.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 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.+-}+instance (Units a1, Units a2) => Units (a1, a2) where+  units = (units, units)++-- Generate n-tuple instances, where n > 2+unitsTupleInstances maxTupleSize
+ src/Protocols/Plugin/Units/TH.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_HADDOCK hide #-}++module Protocols.Plugin.Units.TH (unitsTupleInstances) where++import Language.Haskell.TH++appTs :: Q Type -> [Q Type] -> Q Type+appTs = foldl appT++unitsTupleInstances :: Int -> Q [Dec]+unitsTupleInstances n = mapM unitsTupleInstance [3 .. 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]