Strongly separate clash-protocols-base and clash-protocols

.github/workflows/ci.yml

@@ -118,7 +118,7 @@ jobs:
           version: "0.14.0.0"
           pattern: |
             **/*.hs
-            !clash-protocols-base/src/Protocols/Cpp.hs
+            !clash-protocols-base/src/Protocols/Plugin/Cpp.hs
 
   linting:
     name: Source code linting

clash-protocols-base/clash-protocols-base.cabal

@@ -111,15 +111,16 @@ library
     , template-haskell
 
   exposed-modules:
-    Protocols.Cpp
-    Protocols.Internal
-    Protocols.Internal.Classes
-    Protocols.Internal.TaggedBundle
-    Protocols.Internal.TaggedBundle.TH
-    Protocols.Internal.TH
-    Protocols.Internal.Units
-    Protocols.Internal.Units.TH
     Protocols.Plugin
+    Protocols.Plugin.Cpp
     Protocols.Plugin.Internal
+    Protocols.Plugin.TaggedBundle
+    Protocols.Plugin.TaggedBundle.TH
+    Protocols.Plugin.TH
+    Protocols.Plugin.Units
+    Protocols.Plugin.Units.TH
+
+  other-modules:
+    Protocols.Plugin.Types
 
   default-language: Haskell2010

clash-protocols-base/src/Protocols/Plugin.hs

@@ -1,11 +1,18 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
+{-# 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 (..),
+
+  -- * clash-prelude related types
+  CSignal,
+
+  -- * plugin functions
   plugin,
   circuit,
   (-<),
@@ -14,11 +21,16 @@ module Protocols.Plugin (
 -- base
 import Prelude
 
+-- clash-prelude
+import qualified Clash.Explicit.Prelude as C
+
 -- clash-protocols
-import Protocols.Internal
-import Protocols.Internal.TaggedBundle
-import Protocols.Internal.Units
+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 qualified CircuitNotation as CN
@@ -29,6 +41,31 @@ import Data.Tagged
 -- ghc
 import qualified GHC.Plugins 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
+
+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) = C.Signal dom ()
+
 -- | @circuit-notation@ plugin repurposed for "Protocols".
 plugin :: GHC.Plugin
 plugin =

clash-protocols-base/src/Protocols/Cpp.hs → clash-protocols-base/src/Protocols/Plugin/Cpp.hs

@@ -12,7 +12,7 @@ Compile-time dependent constants. Inspired by @clash-prelude@'s @Clash.CPP@.
 
 {-# OPTIONS_HADDOCK hide #-}
 
-module Protocols.Cpp
+module Protocols.Plugin.Cpp
  ( maxTupleSize
  , haddockOnly
  ) where

clash-protocols-base/src/Protocols/Plugin/Internal.hs

@@ -7,7 +7,22 @@ module Protocols.Plugin.Internal where
 import Clash.Explicit.Prelude
 
 import Data.Tagged
-import Protocols.Internal
+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)

clash-protocols-base/src/Protocols/Plugin/TH.hs

@@ -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

clash-protocols-base/src/Protocols/Internal/TaggedBundle.hs → clash-protocols-base/src/Protocols/Plugin/TaggedBundle.hs

@@ -6,12 +6,12 @@
 -- For debugging TH:
 -- {-# OPTIONS_GHC -ddump-splices #-}
 
-module Protocols.Internal.TaggedBundle where
+module Protocols.Plugin.TaggedBundle where
 
 import Clash.Explicit.Prelude
 
-import Protocols.Cpp (maxTupleSize)
-import Protocols.Internal.TaggedBundle.TH (taggedBundleTupleInstances)
+import Protocols.Plugin.Cpp (maxTupleSize)
+import Protocols.Plugin.TaggedBundle.TH (taggedBundleTupleInstances)
 
 import Data.Tagged
 

clash-protocols-base/src/Protocols/Internal/TaggedBundle/TH.hs → clash-protocols-base/src/Protocols/Plugin/TaggedBundle/TH.hs

@@ -1,6 +1,6 @@
 {-# OPTIONS_HADDOCK hide #-}
 
-module Protocols.Internal.TaggedBundle.TH where
+module Protocols.Plugin.TaggedBundle.TH where
 
 import Data.Tagged
 import Language.Haskell.TH

clash-protocols-base/src/Protocols/Internal/Classes.hs → clash-protocols-base/src/Protocols/Plugin/Types.hs

@@ -1,15 +1,17 @@
+{-# 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.Internal.Classes where
+module Protocols.Plugin.Types where
 
 import Clash.Signal
 import Data.Kind (Type)
-import Data.Proxy
 
 -- | A protocol describes the in- and outputs of one side of a 'Circuit'.
 class Protocol a where
@@ -134,36 +136,12 @@ types:
 newtype Circuit a b
   = Circuit ((Fwd a, Bwd b) -> (Bwd a, Fwd b))
 
-{- | Idle state of a Circuit. Aims to provide no data for both the forward and
-backward direction. Transactions are not acknowledged.
+{- | 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.
 -}
-class (Protocol p) => IdleCircuit p where
-  idleFwd :: Proxy p -> Fwd (p :: Type)
-  idleBwd :: Proxy p -> Bwd (p :: Type)
+data CSignal (dom :: Domain) (a :: Type)
 
-{- | Force a /nack/ on the backward channel and /no data/ on the forward
-channel if reset is asserted.
--}
-forceResetSanityGeneric ::
-  forall dom a fwd bwd.
-  ( KnownDomain dom
-  , HiddenReset dom
-  , IdleCircuit a
-  , Fwd a ~ Signal dom fwd
-  , Bwd a ~ Signal dom bwd
-  ) =>
-  Circuit a a
-forceResetSanityGeneric = Circuit go
- where
-  go (fwd, bwd) =
-    unbundle $
-      mux
-        rstAsserted
-        (bundle (idleBwd $ Proxy @a, idleFwd $ Proxy @a))
-        (bundle (bwd, fwd))
-
-#if MIN_VERSION_clash_prelude(1,8,0)
-  rstAsserted = unsafeToActiveHigh hasReset
-#else
-  rstAsserted = unsafeToHighPolarity hasReset
-#endif
+type role CSignal nominal representational

clash-protocols-base/src/Protocols/Internal/Units.hs → clash-protocols-base/src/Protocols/Plugin/Units.hs

@@ -5,12 +5,12 @@
 -- For debugging TH:
 -- {-# OPTIONS_GHC -ddump-splices #-}
 
-module Protocols.Internal.Units where
+module Protocols.Plugin.Units where
 
 import Clash.Explicit.Prelude
 
-import Protocols.Cpp (maxTupleSize)
-import Protocols.Internal.Units.TH (unitsTupleInstances)
+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.

clash-protocols-base/src/Protocols/Internal/Units/TH.hs → clash-protocols-base/src/Protocols/Plugin/Units/TH.hs

@@ -1,6 +1,6 @@
 {-# OPTIONS_HADDOCK hide #-}
 
-module Protocols.Internal.Units.TH (unitsTupleInstances) where
+module Protocols.Plugin.Units.TH (unitsTupleInstances) where
 
 import Language.Haskell.TH
 

clash-protocols/clash-protocols.cabal

@@ -145,10 +145,12 @@ library
     Protocols.Axi4.WriteData
     Protocols.Axi4.WriteResponse
     Protocols.Df
+    Protocols.Internal
     Protocols.DfConv
     Protocols.Hedgehog
     Protocols.Hedgehog.Internal
     Protocols.Idle
+    Protocols.Internal.TH
     Protocols.Wishbone
     Protocols.Wishbone.Standard
     Protocols.Wishbone.Standard.Hedgehog
@@ -163,6 +165,7 @@ library
   autogen-modules:    Paths_clash_protocols
 
   other-modules:
+    Protocols.Internal.Types
     Paths_clash_protocols
 
   default-language: Haskell2010

clash-protocols/src/Protocols.hs

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

clash-protocols/src/Protocols/Axi4/ReadAddress.hs

@@ -49,6 +49,7 @@
 
 -- me
 import Protocols.Axi4.Common
+import Protocols.Idle
 import Protocols.Internal
 
 -- | Configuration options for 'Axi4ReadAddress'.
@@ -188,7 +189,7 @@
 -- | See Table A2-5 "Read address channel signals"
 newtype S2M_ReadAddress = S2M_ReadAddress
   {_arready :: Bool}
   deriving (Show, Generic, C.NFDataX)
 
 {- | Shorthand for a "well-behaved" read address config,
 so that we don't need to write out a bunch of type constraints later.

clash-protocols/src/Protocols/Axi4/Stream.hs

@@ -27,6 +27,7 @@
 import qualified Protocols.Df as Df
 import qualified Protocols.DfConv as DfConv
 import Protocols.Hedgehog.Internal
+import Protocols.Idle
 import Protocols.Internal
 
 instance (KnownNat n) => Hashable (Unsigned n)
@@ -102,7 +103,7 @@
 the '_tready' signal.
 -}
 newtype Axi4StreamS2M = Axi4StreamS2M {_tready :: Bool}
   deriving (Generic, C.NFDataX, C.ShowX, Eq, NFData, Show, Bundle)
 
 -- | Type for AXI4 Stream protocol.
 data Axi4Stream (dom :: Domain) (conf :: Axi4StreamConfig) (userType :: Type)

clash-protocols/src/Protocols/Axi4/WriteAddress.hs

@@ -47,6 +47,7 @@
 
 -- me
 import Protocols.Axi4.Common
+import Protocols.Idle
 import Protocols.Internal
 
 -- | Configuration options for 'Axi4WriteAddress'.
@@ -185,7 +186,7 @@
 
 -- | See Table A2-2 "Write address channel signals"
 newtype S2M_WriteAddress = S2M_WriteAddress {_awready :: Bool}
   deriving (Show, Generic, C.NFDataX)
 
 {- | Shorthand for a "well-behaved" write address config,
 so that we don't need to write out a bunch of type constraints later.

clash-protocols/src/Protocols/Df.hs

@@ -129,6 +129,7 @@ import qualified Clash.Prelude as C
 import Clash.Signal.Internal (Signal (..))
 
 -- me
+import Protocols.Idle
 import Protocols.Internal
 
 {-# ANN module "HLint: ignore Use const" #-}