diff --git a/cabal.project b/cabal.project index 84dac24c..50fdb6ad 100644 --- a/cabal.project +++ b/cabal.project @@ -13,4 +13,4 @@ package clash-prelude source-repository-package type: git location: https://github.com/cchalmers/circuit-notation.git - tag: 618e37578e699df235f2e7150108b6401731919b \ No newline at end of file + tag: 565d4811cff6a597ee577dabd81b460e941fcb14 diff --git a/clash-protocols.cabal b/clash-protocols.cabal index a4bd703a..77264c2c 100644 --- a/clash-protocols.cabal +++ b/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 diff --git a/src/Protocols.hs b/src/Protocols.hs index 672f46b3..4a0f8e05 100644 --- a/src/Protocols.hs +++ b/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 diff --git a/src/Protocols/Df.hs b/src/Protocols/Df.hs index dbfdc458..22c112c2 100644 --- a/src/Protocols/Df.hs +++ b/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(..) diff --git a/src/Protocols/Hedgehog/Internal.hs b/src/Protocols/Hedgehog/Internal.hs index 486bcfb5..2344d529 100644 --- a/src/Protocols/Hedgehog/Internal.hs +++ b/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 diff --git a/src/Protocols/Internal.hs b/src/Protocols/Internal.hs index bb68b996..7d07085c 100644 --- a/src/Protocols/Internal.hs +++ b/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) diff --git a/src/Protocols/Internal/TaggedBundle.hs b/src/Protocols/Internal/TaggedBundle.hs new file mode 100644 index 00000000..d1b7b872 --- /dev/null +++ b/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 diff --git a/src/Protocols/Internal/TaggedBundle/TH.hs b/src/Protocols/Internal/TaggedBundle/TH.hs new file mode 100644 index 00000000..fa004412 --- /dev/null +++ b/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] diff --git a/src/Protocols/Internal/Units.hs b/src/Protocols/Internal/Units.hs new file mode 100644 index 00000000..d7bcf937 --- /dev/null +++ b/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 diff --git a/src/Protocols/Internal/Units/TH.hs b/src/Protocols/Internal/Units/TH.hs new file mode 100644 index 00000000..6668712b --- /dev/null +++ b/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] diff --git a/src/Protocols/Plugin.hs b/src/Protocols/Plugin.hs index 3204048e..ebc6e871 100644 --- a/src/Protocols/Plugin.hs +++ b/src/Protocols/Plugin.hs @@ -2,8 +2,9 @@ A GHC source plugin providing a DSL for writing Circuit components. Credits to @circuit-notation@ at . -} -{-# 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 } diff --git a/tests/Tests/Protocols/Plugin.hs b/tests/Tests/Protocols/Plugin.hs index 27fcb160..bf279f09 100644 --- a/tests/Tests/Protocols/Plugin.hs +++ b/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