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/Cpp.hs

@@ -0,0 +1,47 @@
+{-|
+Copyright  :  (C) 2019     , Myrtle Software Ltd,
+                  2023     , QBayLogic B.V.,
+                  2024     , Google LLC
+License    :  BSD2 (see the file LICENSE)
+Maintainer :  QBayLogic B.V. <[email protected]>
+
+Compile-time dependent constants. Inspired by @clash-prelude@'s @Clash.CPP@.
+-}
+
+{-# LANGUAGE CPP #-}
+
+{-# OPTIONS_HADDOCK hide #-}
+
+module Protocols.Cpp
+ ( maxTupleSize
+ , haddockOnly
+ ) where
+
+#ifndef MAX_TUPLE_SIZE
+#ifdef LARGE_TUPLES
+
+#if MIN_VERSION_ghc(9,0,0)
+import GHC.Settings.Constants (mAX_TUPLE_SIZE)
+#else
+import Constants (mAX_TUPLE_SIZE)
+#endif
+#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/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,9 @@ Internal module to prevent hs-boot files (breaks Haddock)
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- NFDataX and ShowX for Identity and Proxy
 
+-- TODO: Hide internal documentation
+-- {-# OPTIONS_HADDOCK hide #-}
+
 module Protocols.Internal where
 
 import           Control.DeepSeq (NFData)

src/Protocols/Internal/TaggedBundle.hs

@@ -0,0 +1,61 @@
+{-# 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 #-}
+
+-- | __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/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 [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/Internal/Units.hs

@@ -0,0 +1,54 @@
+{-# 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.
+instance (Units a1, Units a2) => Units (a1, a2) where
+  units = (units, units)
+
+-- Generate n-tuple instances, where n > 2
+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 [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]