circuit-notation (empty) → 0.1.0.0
raw patch · 8 files changed
+2150/−0 lines, 8 filesdep +basedep +circuit-notationdep +clash-prelude
Dependencies added: base, circuit-notation, clash-prelude, containers, data-default, ghc, lens, mtl, parsec, pretty, pretty-show, syb, template-haskell, unordered-containers
Files
- LICENSE +30/−0
- circuit-notation.cabal +51/−0
- example/Example.hs +270/−0
- src/Circuit.hs +212/−0
- src/CircuitNotation.hs +1344/−0
- src/GHC/Types/Unique/Map.hs +213/−0
- src/GHC/Types/Unique/Map/Extra.hs +19/−0
- tests/unittests.hs +11/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Christopher Chalmers++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Christopher Chalmers nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++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.
+ circuit-notation.cabal view
@@ -0,0 +1,51 @@+-- cabal-version: 2.2+name: circuit-notation+version: 0.1.0.0+synopsis: A source plugin for manipulating circuits in clash with a arrow notation+-- description:+license: BSD3+license-file: LICENSE+author: Christopher Chalmers+maintainer: c.chalmers@me.com+copyright: 2024 Christopher Chalmers+category: Hardware+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: CircuitNotation Circuit++ if impl(ghc < 9.2)+ other-modules:+ GHC.Types.Unique.Map++ if impl(ghc < 9.10)+ other-modules:+ GHC.Types.Unique.Map.Extra++ -- other-extensions:+ build-depends:+ base >=4.12 && <5+ , clash-prelude >= 1.0+ , containers+ , data-default+ , ghc (>=8.6 && <8.8) || (>=8.10 && < 9.10)+ , lens+ , mtl+ , parsec+ , pretty+ , pretty-show+ , syb+ , template-haskell+ , unordered-containers+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++Test-Suite library-testsuite+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: unittests.hs+ other-modules: Example+ hs-source-dirs: tests, example+ build-depends: base, circuit-notation, clash-prelude >= 1.0
+ example/Example.hs view
@@ -0,0 +1,270 @@+{-+ ██████╗██╗██████╗ ██████╗██╗ ██╗██╗████████╗███████╗+██╔════╝██║██╔══██╗██╔════╝██║ ██║██║╚══██╔══╝██╔════╝+██║ ██║██████╔╝██║ ██║ ██║██║ ██║ ███████╗+██║ ██║██╔══██╗██║ ██║ ██║██║ ██║ ╚════██║+╚██████╗██║██║ ██║╚██████╗╚██████╔╝██║ ██║ ███████║+ ╚═════╝╚═╝╚═╝ ╚═╝ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝ ╚══════╝+ (C) 2020, Christopher Chalmers++This file contains examples of using the Circuit Notation.+-}++{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ < 810+{-# LANGUAGE Arrows #-}+#endif++{-# OPTIONS -fplugin=CircuitNotation #-}+{-# OPTIONS -fplugin-opt=CircuitNotation:debug #-}+{-# OPTIONS -Wall #-}+++---- | Hack idiom-brackets using Source Plugin.+----+---- As nobody (?) writes their lists as `([1, 2, 3])`,+---- we can steal that syntax!+---- module Main (main) where++module Example where++import Circuit++import Clash.Prelude++idCircuit :: Circuit a a+idCircuit = idC++#if __GLASGOW_HASKELL__ < 810+swapC0 :: Circuit (a,b) (b,a)+swapC0 = id $ circuit $ \ ~(a,b) -> ~(b,a)+#endif++swapC1 :: Circuit (a,b) (b,a)+swapC1 = id $ circuit $ \ ~(a,b) -> (b,a)++swapC2 :: Circuit (a,b) (b,a)+swapC2 = id $ circuit $ \ (a,b) -> (b,a)++circuitA :: Circuit () (DF domain Int)+circuitA = Circuit (\_ -> () :-> pure (DFM2S True 3))++circuitB :: Circuit () (Signal domain Int)+circuitB = Circuit (\_ -> () :-> pure 3)++circuitC :: Circuit (Signal domain Int) (DF domain Int)+circuitC = Circuit (\(as :-> _) -> () :-> DFM2S True <$> as)++noLambda :: Circuit () (DF domain Int)+noLambda = circuit $ do+ i <- circuitA+ idC -< i++-- noLambda =+-- let+-- inferenceHelper ::+-- () =>+-- ((Circuit () iTy -> CircuitT () iTy) -> CircuitT () iTy)+-- -> Circuit () iTy+-- inferenceHelper = \ f -> Circuit (f runCircuit)+-- in+-- inferenceHelper+-- (\ run0 (~() :-> i_Bwd)+-- -> let () :-> i_Fwd = run0 circuitA (() :-> i_Bwd)+-- in () :-> i_Fwd)+++sigExpr :: Signal domain Int -> Circuit () (DF domain Int)+sigExpr sig = circuit do+ i <- circuitC -< Signal sig+ idC -< i++-- sigPat :: (( Signal Int -> Signal Int ))+sigPat :: Circuit (Signal domain Int) (Signal domain Int)+sigPat = circuit $ \(Signal a) -> do+ i <- idC -< Signal a+ idC -< i++sigPat2 :: Circuit (Signal dom Int) (Signal dom Int)+sigPat2 = circuit $ \(Signal a) -> do+ i <- (idC :: Circuit (Signal dom Int) (Signal dom Int)) -< Signal a+ idC -< i++fwdCircuit :: Circuit (Vec 3 (Signal dom Int)) (Vec 3 (Signal dom Int))+fwdCircuit = circuit $ \(Fwd x) -> do+ i <- idC -< Fwd (fmap (+1) x)+ idC -< i++fwdWithLetCircuit :: KnownNat n => Circuit (Vec n (Signal dom Int)) (Vec n (Signal dom Int))+fwdWithLetCircuit = circuit $ \(Fwd x) -> do+ let y = fmap (+1) x+ i <- idC -< Fwd y+ idC -< i++fstC :: Circuit (Signal domain a, Signal domain b) (Signal domain a)+fstC = circuit $ \(a, _b) -> do idC -< a++fstC2 :: Circuit (Signal domain a, Signal domain b) (Signal domain a)+fstC2 = circuit $ \ab -> do+ (a, _b) <- idC -< ab+ idC -< a++fstC3 :: Circuit (Signal domain a, Signal domain b) (Signal domain a)+fstC3 = circuit \(a, _b) -> a++unfstC :: Circuit (DF domain a) (DF domain a, DF domain b)+unfstC = circuit $ \a -> do+ idC -< (a, _b)++unfstC2 :: Circuit (DF domain a) (DF domain a, DF domain b)+unfstC2 = circuit $ \a -> do+ ab <- circuit (\(aa,bb) -> (bb,aa)) -< (_b, a)+ idC -< ab++unfstC3 :: Circuit (DF dom a) (DF dom a, DF dom b)+unfstC3 = circuit $ \a -> do+ ab <- idC -< (a, _b)+ ab' <- idC -< ab+ idC -< ab'++-- a version of `idC` on `Signal domain Int` which has bad type inference.+idCHard+ :: (Fwd a ~ Signal domain Int, Bwd a ~ (), Fwd b ~ Signal domain Int, Bwd b ~ ())+ => Circuit a b+idCHard = Circuit $ \ (aFwd :-> ()) -> () :-> aFwd++typedBus1 :: forall domain . Circuit (Signal domain Int) (Signal domain Int)+typedBus1 = circuit $ \a -> do+ (b :: Signal domain Int) <- idCHard -< a+ idCHard -< b++typedBus2 :: forall domain . Circuit (Signal domain Int) (Signal domain Int)+typedBus2 = circuit $ \a -> do+ b <- idCHard -< a+ idCHard -< (b :: Signal domain Int)++swapTest :: forall a b. Circuit (a,b) (b,a)+-- swapTest = circuit $ \(a,b) -> (idCircuit :: Circuit (b, a) (b, a)) -< (b, a)+swapTest = circuit $ \(a,b) -> do idC -< (b, a)++unvecC :: Circuit (Vec 2 a) (a, a)+unvecC = circuit \ ~[x,y] -> (x, y)++vecC :: Circuit (a, a) (Vec 2 a)+vecC = circuit \(x, y) -> [x,y]++vec0 :: Circuit (Vec 0 a) ()+vec0 = circuit \[] -> ()++vec00 :: Circuit (Vec 0 a) (Vec 0 a)+vec00 = circuit \[] -> []++fanout :: forall dom. Circuit (DF dom Int) (DF dom Int)+fanout = circuit $ \a -> do+ [x] <- go -< a+ idC -< x+ where+ go :: Circuit (DF dom Int) (Vec n (DF dom Int))+ go = error "Not implemented"++-- test that signals can be duplicated+dupSignalC0 :: Circuit (Signal dom Bool) (Signal dom Bool, Signal dom Bool)+dupSignalC0 = circuit $ \x -> (x, x)++dupSignalC1 :: Circuit (Signal dom Bool) (Signal dom Bool, Signal dom Bool, Signal dom Bool)+dupSignalC1 = circuit $ \x -> do+ y <- idC -< x+ idC -< (y, y, x)++-- -- myDesire :: Circuit Int Char+-- -- myDesire = Circuit (\(aM2S,bS2M) -> let+-- -- (aM2S', bS2M') = runCircuit myCircuit (aM2S, bS2M)+-- -- in (aM2S', bS2M'))+--+-- -- var :: (Int, Int)+-- -- var = (3, 5)+--+-- -- myLet :: Int+-- -- myLet = let (yo, yo') = var in yo+--+-- -- ah :: (Int,Int)+-- -- ah = (7,11)+--+-- -- tupCir1 :: Circuit (Int, Char) (Char, Int)+-- -- tupCir1 = circuit \ input -> do+-- -- (c,i) <- swapC @Int -< input+-- -- i' <- myCircuit -< [i]+-- -- let myIdCircuit = circuit \port -> port+-- -- c' <- myCircuitRev -< c+-- -- c'' <- myIdCircuit -< c'+-- -- idC -< (i', c'')+--+-- tupleCircuit :: Circuit Int Char+-- tupleCircuit = id $ circuit \a -> do+-- let b = 3+-- b <- (circuit \a -> do b <- myCircuit -< a;idC -< b) -< a+-- a' <- myCircuitRev -< b+-- b' <- myCircuit -< a'+-- b'' <- (circuit \aa -> do idC -< aa) -< b'+-- idC -< b''+--+-- -- simpleCircuit :: Circuit Int Char+-- -- simpleCircuit = id $ circuit \a -> do+-- -- b <- (circuit \a -> do b <- myCircuit -< a;idC -< b) -< a+-- -- a' <- myCircuitRev -< b+-- -- b' <- myCircuit -< a'+-- -- b'' <- (circuit \aa -> do idC -< aa) -< b'+-- -- idC -< b''+--+-- myCircuit :: Int+-- myCircuit = circuit \(v1 :: DF d a) (v3 :: blah) -> do+-- v1' <- total -< (v3 :: DF domain Int) -< (v4 :: DF domain Int)+-- v2 <- total -< v1+-- let a = b+-- -- v2' <- total2 -< v2+-- -- v3 <- zipC -< (v1', v2')+-- v1 <- idC -< v3+--+-- -- type RunCircuit a b = (Circuit a b -> (M2S a, S2M b) -> (M2S b, S2M a))+-- -- type CircuitId a b = Circuit a b -> Circuit a b+--+-- -- myCircuit = let+-- -- _circuits :: (RunCircuit a b, RunCircuit c d, RunCircuit (b,d) e, CircuitId (a,c) e)+-- -- _circuits@(runC1, runC2, runC2, cId) = (runCircuit, runCircuit, runCircuit, id)+--+-- -- in cId $ Circuit $ \((v1M2S, v2M2S),outputS2M) -> let+--+-- -- (v1'M2S, v1S2M) = runC1 total (v1M2s, v1'S2M)+-- -- (v2'M2S, v2S2M) = runC2 total2 (v2M2s, v2'S2M)+-- -- (v3M2S, (v1'S2M, v2'S2M)) = runC3 zipC ((v1'M2S, v2'M2S), v3S2M)+--+-- -- in (v3M2S, (v1S2M, v2S2M))+--+--+--+--+-- -- circuitHelper+-- -- :: Circuit a b+-- -- -> Circuit c d+-- -- -> Circuit (b,d) e+--+--+-- -- myCircuit :: Int+-- -- myCircuit = circuit (\(v1,v2) -> (v2,v1))+--+-- -- myCircuit :: Int+-- -- myCircuit = circuit do+-- -- (v2,v1) <- yeah+-- -- idC -< (v1, v2)+--+-- -- myCircuit = proc v1 -> do+-- -- x <- total -< value+-- -- fin -< a+-- -- idC -< (t / n)
+ src/Circuit.hs view
@@ -0,0 +1,212 @@+{-+ ██████╗██╗██████╗ ██████╗██╗ ██╗██╗████████╗███████╗+██╔════╝██║██╔══██╗██╔════╝██║ ██║██║╚══██╔══╝██╔════╝+██║ ██║██████╔╝██║ ██║ ██║██║ ██║ ███████╗+██║ ██║██╔══██╗██║ ██║ ██║██║ ██║ ╚════██║+╚██████╗██║██║ ██║╚██████╗╚██████╔╝██║ ██║ ███████║+ ╚═════╝╚═╝╚═╝ ╚═╝ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝ ╚══════╝+ (C) 2020, Christopher Chalmers++This file contains the 'Circuit' type, that the notation describes.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Circuit where++import Clash.Prelude++#if __GLASGOW_HASKELL__ > 900+-- | Unsafe version of ':>'. Will fail if applied to empty vectors. This is used to+-- workaround 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 :>!+#endif++type family Fwd a+type family Bwd a++infixr 0 :->+-- | A type to symbolise arguments going to results of a circuit.+data (a :-> b) = a :-> b+ deriving (Show, Eq)++-- | The identity circuit.+idC :: Circuit a a+idC = Circuit $ \(aFwd :-> aBwd) -> aBwd :-> aFwd++data DF (dom :: Domain) a+data DFM2S a = DFM2S Bool a+newtype DFS2M = DFS2M Bool++instance Default (DFM2S a) where+ def = DFM2S False (error "error default")+instance Default DFS2M where+ def = DFS2M True++type instance Fwd (DF dom a) = Signal dom (DFM2S a)+type instance Bwd (DF dom a) = Signal dom DFS2M++type instance Fwd (Vec n a) = Vec n (Fwd a)+type instance Bwd (Vec n a) = Vec n (Bwd a)++type instance Fwd [a] = [Fwd a]+type instance Bwd [a] = [Bwd a]++type instance Fwd () = ()+type instance Bwd () = ()++type instance Fwd (a,b) = (Fwd a, Fwd b)+type instance Bwd (a,b) = (Bwd a, Bwd b)++type instance Fwd (a,b,c) = (Fwd a, Fwd b, Fwd c)+type instance Bwd (a,b,c) = (Bwd a, Bwd b, Bwd c)++type instance Fwd (Signal dom a) = Signal dom a+type instance Bwd (Signal dom a) = ()++-- | Circuit type.+newtype Circuit a b = Circuit { runCircuit :: CircuitT a b }+type CircuitT a b = (Fwd a :-> Bwd b) -> (Bwd a :-> Fwd b)+++type TagCircuitT a b = (BusTag a (Fwd a) :-> BusTag b (Bwd b)) -> (BusTag a (Bwd a) :-> BusTag b (Fwd b))++newtype BusTag t b = BusTag {unBusTag :: b}++mkTagCircuit :: TagCircuitT a b -> Circuit a b+mkTagCircuit f = Circuit $ \ (aFwd :-> bBwd) -> let+ (BusTag aBwd :-> BusTag bFwd) = f (BusTag aFwd :-> BusTag bBwd)+ in (aBwd :-> bFwd)++runTagCircuit :: Circuit a b -> TagCircuitT a b+runTagCircuit (Circuit c) (aFwd :-> bBwd) = let+ (aBwd :-> bFwd) = c (unBusTag aFwd :-> unBusTag bBwd)+ in (BusTag aBwd :-> BusTag bFwd)++pattern TagCircuit :: TagCircuitT a b -> Circuit a b+pattern TagCircuit f <- (runTagCircuit -> f) where+ TagCircuit f = mkTagCircuit f+++class TrivialBwd a where+ unitBwd :: a++instance TrivialBwd () where+ unitBwd = ()++instance (TrivialBwd a) => TrivialBwd (Signal dom a) where+ unitBwd = pure unitBwd++instance (TrivialBwd a, KnownNat n) => TrivialBwd (Vec n a) where+ unitBwd = repeat unitBwd++instance (TrivialBwd a, TrivialBwd b) => TrivialBwd (a,b) where+ unitBwd = (unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c) => TrivialBwd (a,b,c) where+ unitBwd = (unitBwd, unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d) => TrivialBwd (a,b,c,d) where+ unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e) => TrivialBwd (a,b,c,d,e) where+ unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f) => TrivialBwd (a,b,c,d,e,f) where+ unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g) => TrivialBwd (a,b,c,d,e,f,g) where+ unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h) => TrivialBwd (a,b,c,d,e,f,g,h) where+ unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h, TrivialBwd i) => TrivialBwd (a,b,c,d,e,f,g,h,i) where+ unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)++instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e, TrivialBwd f, TrivialBwd g, TrivialBwd h, TrivialBwd i, TrivialBwd j) => TrivialBwd (a,b,c,d,e,f,g,h,i,j) where+ unitBwd = (unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd, unitBwd)++instance TrivialBwd a => TrivialBwd (BusTag t a) where+ unitBwd = BusTag unitBwd++class BusTagBundle t a where+ type BusTagUnbundled t a = res | res -> t a+ taggedBundle :: BusTagUnbundled t a -> BusTag t a+ taggedUnbundle :: BusTag t a -> BusTagUnbundled t a++instance BusTagBundle () () where+ type BusTagUnbundled () () = ()+ taggedBundle = BusTag+ taggedUnbundle = unBusTag++instance BusTagBundle (ta, tb) (a, b) where+ type BusTagUnbundled (ta, tb) (a, b) = (BusTag ta a, BusTag tb b)+ taggedBundle (BusTag a, BusTag b) = BusTag (a, b)+ taggedUnbundle (BusTag (a, b)) = (BusTag a, BusTag b)++instance BusTagBundle (ta, tb, tc) (a, b, c) where+ type BusTagUnbundled (ta, tb, tc) (a, b, c) = (BusTag ta a, BusTag tb b, BusTag tc c)+ taggedBundle (BusTag a, BusTag b, BusTag c) = BusTag (a, b, c)+ taggedUnbundle (BusTag (a, b, c)) = (BusTag a, BusTag b, BusTag c)++instance BusTagBundle (ta, tb, tc, td) (a, b, c, d) where+ type BusTagUnbundled (ta, tb, tc, td) (a, b, c, d) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d)+ taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d) = BusTag (a, b, c, d)+ taggedUnbundle (BusTag (a, b, c, d)) = (BusTag a, BusTag b, BusTag c, BusTag d)++instance BusTagBundle (ta, tb, tc, td, te) (a, b, c, d, e) where+ type BusTagUnbundled (ta, tb, tc, td, te) (a, b, c, d, e) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e)+ taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e) = BusTag (a, b, c, d, e)+ taggedUnbundle (BusTag (a, b, c, d, e)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e)++instance BusTagBundle (ta, tb, tc, td, te, tf) (a, b, c, d, e, f) where+ type BusTagUnbundled (ta, tb, tc, td, te, tf) (a, b, c, d, e, f) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f)+ taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f) = BusTag (a, b, c, d, e, f)+ taggedUnbundle (BusTag (a, b, c, d, e, f)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f)++instance BusTagBundle (ta, tb, tc, td, te, tf, tg) (a, b, c, d, e, f, g) where+ type BusTagUnbundled (ta, tb, tc, td, te, tf, tg) (a, b, c, d, e, f, g) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g)+ taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g) = BusTag (a, b, c, d, e, f, g)+ taggedUnbundle (BusTag (a, b, c, d, e, f, g)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g)++instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th) (a, b, c, d, e, f, g, h) where+ type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th) (a, b, c, d, e, f, g, h) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h)+ taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h) = BusTag (a, b, c, d, e, f, g, h)+ taggedUnbundle (BusTag (a, b, c, d, e, f, g, h)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h)++instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th, ti) (a, b, c, d, e, f, g, h, i) where+ type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti) (a, b, c, d, e, f, g, h, i) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h, BusTag ti i)+ taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i) = BusTag (a, b, c, d, e, f, g, h, i)+ taggedUnbundle (BusTag (a, b, c, d, e, f, g, h, i)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i)++instance BusTagBundle (ta, tb, tc, td, te, tf, tg, th, ti, tj) (a, b, c, d, e, f, g, h, i, j) where+ type BusTagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti, tj) (a, b, c, d, e, f, g, h, i, j) = (BusTag ta a, BusTag tb b, BusTag tc c, BusTag td d, BusTag te e, BusTag tf f, BusTag tg g, BusTag th h, BusTag ti i, BusTag tj j)+ taggedBundle (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j) = BusTag (a, b, c, d, e, f, g, h, i, j)+ taggedUnbundle (BusTag (a, b, c, d, e, f, g, h, i, j)) = (BusTag a, BusTag b, BusTag c, BusTag d, BusTag e, BusTag f, BusTag g, BusTag h, BusTag i, BusTag j)++instance BusTagBundle (Vec n t) (Vec n a) where+ type BusTagUnbundled (Vec n t) (Vec n a) = Vec n (BusTag t a)+ taggedBundle = BusTag . fmap unBusTag+ taggedUnbundle = fmap BusTag . unBusTag++pattern BusTagBundle :: BusTagBundle t a => BusTagUnbundled t a -> BusTag t a+pattern BusTagBundle a <- (taggedUnbundle -> a) where+ BusTagBundle a = taggedBundle a+{-# COMPLETE BusTagBundle #-}
+ src/CircuitNotation.hs view
@@ -0,0 +1,1344 @@+{-+ ██████╗██╗██████╗ ██████╗██╗ ██╗██╗████████╗███████╗+██╔════╝██║██╔══██╗██╔════╝██║ ██║██║╚══██╔══╝██╔════╝+██║ ██║██████╔╝██║ ██║ ██║██║ ██║ ███████╗+██║ ██║██╔══██╗██║ ██║ ██║██║ ██║ ╚════██║+╚██████╗██║██║ ██║╚██████╗╚██████╔╝██║ ██║ ███████║+ ╚═════╝╚═╝╚═╝ ╚═╝ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝ ╚══════╝+ (C) 2020, Christopher Chalmers++Notation for describing the 'Circuit' type.+-}++{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- TODO: Fix warnings introduced by GHC 9.2+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module CircuitNotation+ ( plugin+ , mkPlugin+ , thName+ , ExternalNames (..)+ , Direction(..)+ ) where++-- base+import Control.Exception+import qualified Data.Data as Data+import Data.Default+import Data.Maybe (fromMaybe)+#if __GLASGOW_HASKELL__ >= 900+#else+import SrcLoc hiding (noLoc)+#endif+import System.IO.Unsafe+import Data.Typeable++-- ghc+import qualified Language.Haskell.TH as TH+import qualified GHC++#if __GLASGOW_HASKELL__ >= 902+import GHC.Types.SourceError (throwOneError)+import qualified GHC.Driver.Env as GHC+import qualified GHC.Types.SourceText as GHC+import qualified GHC.Types.SourceError as GHC+import qualified GHC.Driver.Ppr as GHC+#elif __GLASGOW_HASKELL__ >= 900+import GHC.Driver.Types (throwOneError)+import qualified GHC.Driver.Types as GHC+#else+import HscTypes (throwOneError)+#endif++#if __GLASGOW_HASKELL__ == 900+import qualified GHC.Parser.Annotation as GHC+#endif++#if __GLASGOW_HASKELL__ >= 900+import GHC.Data.Bag+import GHC.Data.FastString (mkFastString, unpackFS)+#if __GLASGOW_HASKELL__ < 906+import GHC.Plugins (PromotionFlag(NotPromoted))+#endif+import GHC.Types.SrcLoc hiding (noLoc)+import qualified GHC.Data.FastString as GHC+import qualified GHC.Driver.Plugins as GHC+import qualified GHC.Driver.Session as GHC+import qualified GHC.Types.Basic as GHC+import qualified GHC.Types.Name.Occurrence as OccName+import qualified GHC.Types.Name.Reader as GHC+import qualified GHC.Utils.Error as Err+import qualified GHC.Utils.Outputable as GHC+import qualified GHC.Utils.Outputable as Outputable+#else+import Bag+import qualified ErrUtils as Err+import FastString (mkFastString, unpackFS)+import qualified GhcPlugins as GHC+import qualified OccName+import qualified Outputable+#endif++#if __GLASGOW_HASKELL__ >= 904+import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage++import qualified GHC.Driver.Config.Diagnostic as GHC+import qualified GHC.Driver.Errors.Types as GHC+import qualified GHC.Utils.Logger as GHC+import qualified GHC.Parser.PostProcess as GHC+#endif++#if __GLASGOW_HASKELL__ > 808+import qualified GHC.ThToHs as Convert+import GHC.Hs+#if __GLASGOW_HASKELL__ >= 902+ hiding (locA)+#endif+#else+import qualified Convert+import HsSyn hiding (noExt)+import HsExtension (GhcPs, NoExt (..))+#endif++#if __GLASGOW_HASKELL__ <= 806+import PrelNames (eqTyCon_RDR)+#elif __GLASGOW_HASKELL__ <= 810+import TysWiredIn (eqTyCon_RDR)+import BasicTypes (PromotionFlag( NotPromoted ))+#else+import GHC.Builtin.Types (eqTyCon_RDR)+#endif++#if __GLASGOW_HASKELL__ >= 902+import "ghc" GHC.Types.Unique.Map+#else+import GHC.Types.Unique.Map+#endif++#if __GLASGOW_HASKELL__ < 908+import GHC.Types.Unique.Map.Extra+#endif++-- clash-prelude+import Clash.Prelude (Vec((:>), Nil))++-- lens+import qualified Control.Lens as L+import Control.Lens.Operators++-- mtl+import Control.Monad.State++#if __GLASGOW_HASKELL__ >= 906+import Control.Monad+#endif++-- pretty-show+-- import qualified Text.Show.Pretty as SP++-- syb+import qualified Data.Generics as SYB++-- The stages of this plugin+--+-- 1. Go through the parsed module source and find usages of the circuit keyword (`transform`).+-- 2. Parse the circuit, either do notation or a one liner, go through each statement and convert it+-- to a CircuitQQ.+-- 3. Go through the CircuitQQ and check that everything is consistent (every master has a matching+-- slave).+-- 4. Convert the Bindings to let statements, at the same time build up a description of the types+-- to make the type descriptor helper.+++-- Utils ---------------------------------------------------------------+isSomeVar :: (p ~ GhcPs) => GHC.FastString -> HsExpr p -> Bool+isSomeVar s = \case+ HsVar _ (L _ v) -> v == GHC.mkVarUnqual s+ _ -> False++isCircuitVar :: p ~ GhcPs => HsExpr p -> Bool+isCircuitVar = isSomeVar "circuit"++isDollar :: p ~ GhcPs => HsExpr p -> Bool+isDollar = isSomeVar "$"++-- | Is (-<)?+isFletching :: p ~ GhcPs => HsExpr p -> Bool+isFletching = isSomeVar "-<"++imap :: (Int -> a -> b) -> [a] -> [b]+imap f = zipWith f [0 ..]++-- Utils for backwards compat ------------------------------------------+#if __GLASGOW_HASKELL__ < 902+type MsgDoc = Err.MsgDoc+type SrcSpanAnnA = SrcSpan+type SrcSpanAnnL = SrcSpan++noSrcSpanA :: SrcSpan+noSrcSpanA = noSrcSpan++noAnnSortKey :: NoExtField+noAnnSortKey = noExtField++emptyComments :: NoExtField+emptyComments = noExtField++locA :: a -> a+locA = id+#else+type MsgDoc = Outputable.SDoc++locA :: SrcSpanAnn' a -> SrcSpan+locA = GHC.locA++noAnnSortKey :: AnnSortKey+noAnnSortKey = NoAnnSortKey+#endif++#if __GLASGOW_HASKELL__ < 902+type ErrMsg = Err.ErrMsg+#elif __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904+type ErrMsg = Err.MsgEnvelope Err.DecoratedSDoc+#else+type ErrMsg = Err.MsgEnvelope GHC.GhcMessage+#endif++#if __GLASGOW_HASKELL__ < 904+sevFatal :: Err.Severity+sevFatal = Err.SevFatal+#else+sevFatal :: Err.MessageClass+sevFatal = Err.MCFatal+#endif++#if __GLASGOW_HASKELL__ > 900+noExt :: EpAnn ann+noExt = EpAnnNotUsed+#elif __GLASGOW_HASKELL__ > 808+noExt :: NoExtField+noExt = noExtField+#else+noExt :: NoExt+noExt = NoExt++noExtField :: NoExt+noExtField = NoExt++type NoExtField = NoExt+#endif++#if __GLASGOW_HASKELL__ < 904+pattern HsParP :: LHsExpr p -> HsExpr p+pattern HsParP e <- HsPar _ e++pattern ParPatP :: LPat p -> Pat p+pattern ParPatP p <- ParPat _ p+#else+pattern HsParP :: LHsExpr p -> HsExpr p+pattern HsParP e <- HsPar _ _ e _++pattern ParPatP :: LPat p -> Pat p+pattern ParPatP p <- ParPat _ _ p _+#endif++#if __GLASGOW_HASKELL__ < 906+type PrintUnqualified = Outputable.PrintUnqualified+#else+type PrintUnqualified = Outputable.NamePprCtx+#endif++mkErrMsg :: GHC.DynFlags -> SrcSpan -> PrintUnqualified -> Outputable.SDoc -> ErrMsg+#if __GLASGOW_HASKELL__ < 902+mkErrMsg = Err.mkErrMsg+#elif __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904+mkErrMsg _ = Err.mkMsgEnvelope+#else+-- Check the documentation of+-- `GHC.Driver.Errors.Types.ghcUnkownMessage` for some background on+-- why plugins should use this generic message constructor.+mkErrMsg _ locn unqual =+ Err.mkErrorMsgEnvelope locn unqual+ . GHC.ghcUnknownMessage+ . Err.mkPlainError Err.noHints+#endif++mkLongErrMsg :: GHC.DynFlags -> SrcSpan -> PrintUnqualified -> Outputable.SDoc -> Outputable.SDoc -> ErrMsg+#if __GLASGOW_HASKELL__ < 902+mkLongErrMsg = Err.mkLongErrMsg+#elif __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904+mkLongErrMsg _ = Err.mkLongMsgEnvelope+#else+mkLongErrMsg _ locn unqual msg extra =+ Err.mkErrorMsgEnvelope locn unqual+ $ GHC.ghcUnknownMessage+ $ Err.mkDecoratedError Err.noHints [msg, extra]+#endif++-- Types ---------------------------------------------------------------++-- | The name given to a 'port', i.e. the name of a variable either to the left of a '<-' or to the+-- right of a '-<'.+data PortName = PortName SrcSpanAnnA GHC.FastString+ deriving (Eq)++instance Show PortName where+ show (PortName _ fs) = GHC.unpackFS fs++data PortDescription a+ = Tuple [PortDescription a]+ | Vec SrcSpanAnnA [PortDescription a]+ | Ref a+ | RefMulticast a+ | Lazy SrcSpanAnnA (PortDescription a)+ | FwdExpr (LHsExpr GhcPs)+ | FwdPat (LPat GhcPs)+ | PortType (LHsType GhcPs) (PortDescription a)+ | PortErr SrcSpanAnnA MsgDoc+ deriving (Foldable, Functor, Traversable)++_Ref :: L.Prism' (PortDescription a) a+_Ref = L.prism' Ref (\case Ref a -> Just a; _ -> Nothing)++instance L.Plated (PortDescription a) where+ plate f = \case+ Tuple ps -> Tuple <$> traverse f ps+ Vec s ps -> Vec s <$> traverse f ps+ Lazy s p -> Lazy s <$> f p+ PortType t p -> PortType t <$> f p+ p -> pure p++-- | A single circuit binding. These are generated from parsing statements.+-- @+-- bOut <- bCircuit -< bIn+-- @+data Binding exp l = Binding+ { bCircuit :: exp+ , bOut :: PortDescription l+ , bIn :: PortDescription l+ }+ deriving (Functor)++data CircuitState dec exp nm = CircuitState+ { _cErrors :: Bag ErrMsg+ , _counter :: Int+ -- ^ unique counter for generated variables+ , _circuitSlaves :: PortDescription nm+ -- ^ the final statement in a circuit+ , _circuitTypes :: [LSig GhcPs]+ -- ^ type signatures in let bindings+ , _circuitLets :: [dec]+ -- ^ user defined let expression inside the circuit+ , _circuitBinds :: [Binding exp nm]+ -- ^ @out <- circuit <- in@ statements+ , _circuitMasters :: PortDescription nm+ -- ^ ports bound at the first lambda of a circuit+ , _portVarTypes :: UniqMap GHC.FastString (SrcSpanAnnA, LHsType GhcPs)+ -- ^ types of single variable ports+ , _portTypes :: [(LHsType GhcPs, PortDescription nm)]+ -- ^ type of more 'complicated' things (very far from vigorous)+ , _uniqueCounter :: Int+ -- ^ counter to keep internal variables "unique"+ , _circuitLoc :: SrcSpanAnnA+ -- ^ span of the circuit expression+ }++L.makeLenses 'CircuitState++-- | The monad used when running a single circuit.+newtype CircuitM a = CircuitM (StateT (CircuitState (LHsBind GhcPs) (LHsExpr GhcPs) PortName) GHC.Hsc a)+ deriving (Functor, Applicative, Monad, MonadIO, MonadState (CircuitState (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)) (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName))++-- , MonadState (CircuitState (LHsBind GhcPs) (LHsExpr GhcPs) PortName)++instance GHC.HasDynFlags CircuitM where+ getDynFlags = (CircuitM . lift) GHC.getDynFlags++runCircuitM :: CircuitM a -> GHC.Hsc a+runCircuitM (CircuitM m) = do+ let emptyCircuitState = CircuitState+ { _cErrors = emptyBag+ , _counter = 0+ , _circuitSlaves = Tuple []+ , _circuitTypes = []+ , _circuitLets = []+ , _circuitBinds = []+ , _circuitMasters = Tuple []+ , _portVarTypes = emptyUniqMap+ , _portTypes = []+ , _uniqueCounter = 1+ , _circuitLoc = noSrcSpanA+ }+ (a, s) <- runStateT m emptyCircuitState+ let errs = _cErrors s+#if __GLASGOW_HASKELL__ < 904+ unless (isEmptyBag errs) $ liftIO . throwIO $ GHC.mkSrcErr errs+#else+ unless (isEmptyBag errs) $ liftIO . throwIO $ GHC.mkSrcErr $ Err.mkMessages errs+#endif+ pure a++#if __GLASGOW_HASKELL__ < 904+mkLocMessage :: Err.Severity -> SrcSpan -> Outputable.SDoc -> Outputable.SDoc+#else+mkLocMessage :: Err.MessageClass -> SrcSpan -> Outputable.SDoc -> Outputable.SDoc+#endif++#if __GLASGOW_HASKELL__ < 906+mkLocMessage = Err.mkLocMessageAnn Nothing+#else+mkLocMessage = Err.mkLocMessage+#endif++errM :: SrcSpan -> String -> CircuitM ()+errM loc msg = do+ dflags <- GHC.getDynFlags+ let errMsg = mkLocMessage sevFatal loc (Outputable.text msg)+ cErrors %= consBag (mkErrMsg dflags loc Outputable.alwaysQualify errMsg)++-- ghc helpers ---------------------------------------------------------++-- It's very possible that most of these are already in the ghc library in some form. It's not the+-- easiest library to discover these kind of functions.++#if __GLASGOW_HASKELL__ >= 902+conPatIn :: GenLocated SrcSpanAnnN GHC.RdrName -> HsConPatDetails GhcPs -> Pat GhcPs+#else+conPatIn :: Located GHC.RdrName -> HsConPatDetails GhcPs -> Pat GhcPs+#endif+#if __GLASGOW_HASKELL__ >= 900+conPatIn loc con = ConPat noExt loc con+#else+conPatIn loc con = ConPatIn loc con+#endif++#if __GLASGOW_HASKELL__ >= 902+noEpAnn :: GenLocated SrcSpan e -> GenLocated (SrcAnn ann) e+noEpAnn (L l e) = L (SrcSpanAnn EpAnnNotUsed l) e++noLoc :: e -> GenLocated (SrcAnn ann) e+noLoc = noEpAnn . GHC.noLoc+#else+noLoc :: e -> Located e+noLoc = GHC.noLoc+#endif++tupP :: p ~ GhcPs => [LPat p] -> LPat p+tupP [pat] = pat+tupP pats = noLoc $ TuplePat noExt pats GHC.Boxed++vecP :: (?nms :: ExternalNames) => SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs+vecP srcLoc = \case+ [] -> go []+#if __GLASGOW_HASKELL__ < 904+ as -> L srcLoc $ ParPat noExt $ go as+ where+#else+ as -> L srcLoc $ ParPat noExt pL (go as) pR+ where+ pL = L (GHC.mkTokenLocation $ locA srcLoc) HsTok+ pR = L (GHC.mkTokenLocation $ locA srcLoc) HsTok+#endif+ go :: [LPat GhcPs] -> LPat GhcPs+ go (p@(L l0 _):pats) =+ let+#if __GLASGOW_HASKELL__ >= 902+ l1 = l0 `seq` noSrcSpanA+#else+ l1 = l0+#endif+ in+ L srcLoc $ conPatIn (L l1 (consPat ?nms)) (InfixCon p (go pats))+ go [] = L srcLoc $ WildPat noExtField++varP :: SrcSpanAnnA -> String -> LPat GhcPs+varP loc nm = L loc $ VarPat noExtField (noLoc $ var nm)++tildeP :: SrcSpanAnnA -> LPat GhcPs -> LPat GhcPs+tildeP loc lpat = L loc (LazyPat noExt lpat)++hsBoxedTuple :: GHC.HsTupleSort+#if __GLASGOW_HASKELL__ >= 902+hsBoxedTuple = HsBoxedOrConstraintTuple+#else+hsBoxedTuple = HsBoxedTuple+#endif++tupT :: [LHsType GhcPs] -> LHsType GhcPs+tupT [ty] = ty+tupT tys = noLoc $ HsTupleTy noExt hsBoxedTuple tys++vecT :: SrcSpanAnnA -> [LHsType GhcPs] -> LHsType GhcPs+vecT s [] = L s $ HsParTy noExt (conT s (thName ''Vec) `appTy` tyNum s 0 `appTy` (varT s (genLocName s "vec")))+vecT s tys@(ty:_) = L s $ HsParTy noExt (conT s (thName ''Vec) `appTy` tyNum s (length tys) `appTy` ty)++tyNum :: SrcSpanAnnA -> Int -> LHsType GhcPs+tyNum s i = L s (HsTyLit noExtField (HsNumTy GHC.NoSourceText (fromIntegral i)))++appTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs+appTy a b = noLoc (HsAppTy noExtField a (parenthesizeHsType GHC.appPrec b))++appE :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+appE fun arg = L noSrcSpanA $ HsApp noExt fun (parenthesizeHsExpr GHC.appPrec arg)++varE :: SrcSpanAnnA -> GHC.RdrName -> LHsExpr GhcPs+varE loc rdr = L loc (HsVar noExtField (noLoc rdr))++parenE :: LHsExpr GhcPs -> LHsExpr GhcPs+#if __GLASGOW_HASKELL__ < 904+parenE e@(L l _) = L l (HsPar noExt e)+#else+parenE e@(L l _) = L l (HsPar noExt pL e pR)+ where+ pL = L (GHC.mkTokenLocation $ locA l) HsTok+ pR = L (GHC.mkTokenLocation $ locA l) HsTok+#endif++var :: String -> GHC.RdrName+var = GHC.Unqual . OccName.mkVarOcc++tyVar :: String -> GHC.RdrName+tyVar = GHC.Unqual . OccName.mkTyVarOcc++tyCon :: String -> GHC.RdrName+tyCon = GHC.Unqual . OccName.mkTcOcc++vecE :: SrcSpanAnnA -> [LHsExpr GhcPs] -> LHsExpr GhcPs+vecE srcLoc = \case+ [] -> go srcLoc []+ as -> parenE $ go srcLoc as+ where+ go loc (e@(L l _):es) = L loc $ OpApp noExt e (varE l (thName '(:>))) (go loc es)+ go loc [] = varE loc (thName 'Nil)++tupE :: p ~ GhcPs => SrcSpanAnnA -> [LHsExpr p] -> LHsExpr p+tupE _ [ele] = ele+tupE loc elems = L loc $ ExplicitTuple noExt tupArgs GHC.Boxed+ where+#if __GLASGOW_HASKELL__ >= 902+ tupArgs = map (Present noExt) elems+#else+ tupArgs = map (\arg@(L l _) -> L l (Present noExt arg)) elems+#endif++unL :: Located a -> a+unL (L _ a) = a++-- | Get a ghc name from a TH name that's known to be unique.+thName :: TH.Name -> GHC.RdrName+thName nm =+ case Convert.thRdrNameGuesses nm of+ [name] -> name+ _ -> error "thName called on a non NameG Name"++-- | Generate a "unique" name by appending the location as a string.+genLocName :: SrcSpanAnnA -> String -> String+#if __GLASGOW_HASKELL__ >= 902+genLocName (locA -> GHC.RealSrcSpan rss _) prefix =+#elif __GLASGOW_HASKELL__ >= 900+genLocName (GHC.RealSrcSpan rss _) prefix =+#else+genLocName (GHC.RealSrcSpan rss) prefix =+#endif+ prefix <> "_" <>+ foldMap (\f -> show (f rss)) [srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol]+genLocName _ prefix = prefix++-- | Extract a simple lambda into inputs and body.+simpleLambda :: HsExpr GhcPs -> Maybe ([LPat GhcPs], LHsExpr GhcPs)+simpleLambda expr = do+#if __GLASGOW_HASKELL__ < 906+ HsLam _ (MG _x alts _origin) <- Just expr+#else+ HsLam _ (MG _x alts) <- Just expr+#endif+ L _ [L _ (Match _matchX _matchContext matchPats matchGr)] <- Just alts+ GRHSs _grX grHss _grLocalBinds <- Just matchGr+ [L _ (GRHS _ _ body)] <- Just grHss+ Just (matchPats, body)++-- | Create a simple let binding.+letE+ :: p ~ GhcPs+ => SrcSpanAnnA+ -- ^ location for top level let bindings+ -> [LSig p]+ -- ^ type signatures+ -> [LHsBind p]+ -- ^ let bindings+ -> LHsExpr p+ -- ^ final `in` expressions+ -> LHsExpr p+letE loc sigs binds expr =+#if __GLASGOW_HASKELL__ < 904+ L loc (HsLet noExt localBinds expr)+#else+ L loc (HsLet noExt tkLet localBinds tkIn expr)+#endif+ where+#if __GLASGOW_HASKELL__ >= 902+ localBinds :: HsLocalBinds GhcPs+ localBinds = HsValBinds noExt valBinds+#else+ localBinds :: LHsLocalBindsLR GhcPs GhcPs+ localBinds = L loc $ HsValBinds noExt valBinds+#endif++#if __GLASGOW_HASKELL__ >= 904+ tkLet = L (GHC.mkTokenLocation $ locA loc) HsTok+ tkIn = L (GHC.mkTokenLocation $ locA loc) HsTok+#endif++ valBinds :: HsValBindsLR GhcPs GhcPs+ valBinds = ValBinds noAnnSortKey hsBinds sigs++ hsBinds :: LHsBindsLR GhcPs GhcPs+ hsBinds = listToBag binds++-- | Simple construction of a lambda expression+lamE :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs+lamE pats expr = noLoc $ HsLam noExtField mg+ where+ mg :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))+#if __GLASGOW_HASKELL__ < 906+ mg = MG noExtField matches GHC.Generated+#elif __GLASGOW_HASKELL__ < 908+ mg = MG GHC.Generated matches+#else+ mg = MG (GHC.Generated GHC.DoPmc) matches+#endif++ matches :: GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]+ matches = noLoc $ [singleMatch]++ singleMatch :: GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))+ singleMatch = noLoc $ Match noExt LambdaExpr pats grHss++ grHss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))+ grHss = GRHSs emptyComments [grHs] $+#if __GLASGOW_HASKELL__ >= 902+ (EmptyLocalBinds noExtField)+#else+ (noLoc (EmptyLocalBinds noExtField))+#endif++#if __GLASGOW_HASKELL__ < 904+ grHs :: GenLocated SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))+ grHs = L noSrcSpan $ GRHS noExt [] expr+#else+ grHs :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))+ grHs = L noSrcSpanA $ GRHS noExt [] expr+#endif++-- | Kinda hacky function to get a string name for named ports.+fromRdrName :: GHC.RdrName -> GHC.FastString+fromRdrName = \case+ GHC.Unqual occName -> mkFastString (OccName.occNameString occName)+ GHC.Orig _ occName -> mkFastString (OccName.occNameString occName)+ nm -> mkFastString (deepShowD nm)++-- Parsing -------------------------------------------------------------++-- | "parse" a circuit, i.e. convert it from ghc's ast to our representation of a circuit. This is+-- the expression following the 'circuit' keyword.+parseCircuit+ :: p ~ GhcPs+ => LHsExpr p+ -> CircuitM ()+parseCircuit = \case+ -- strip out parenthesis+ L _ (HsParP lexp) -> parseCircuit lexp++ -- a lambda to match the slave ports+ L _ (simpleLambda -> Just ([matchPats], body)) -> do+ circuitSlaves .= bindSlave matchPats+ circuitBody body++ -- a version without a lambda (i.e. no slaves)+ e -> circuitBody e++-- | The main part of a circuit expression. Either a do block or simple rearranging case.+circuitBody :: LHsExpr GhcPs -> CircuitM ()+circuitBody = \case+ -- strip out parenthesis+ L _ (HsParP lexp) -> circuitBody lexp++ L loc (HsDo _x _stmtContext (L _ (unsnoc -> Just (stmts, L finLoc finStmt)))) -> do+ circuitLoc .= loc+ mapM_ handleStmtM stmts++ case finStmt of+ BodyStmt _bodyX bod _idr _idr' ->+ case bod of+ -- special case for idC as the final statement, gives better type inferences and generates nicer+ -- code+#if __GLASGOW_HASKELL__ < 810+ L _ (HsArrApp _xapp (L _ (HsVar _ (L _ (GHC.Unqual occ)))) arg _ _)+ | OccName.occNameString occ == "idC" -> circuitMasters .= bindMaster arg+#else+ L _ (OpApp _ (L _ (HsVar _ (L _ (GHC.Unqual occ)))) (L _ op) port)+ | isFletching op+ , OccName.occNameString occ == "idC" -> do+ circuitMasters .= bindMaster port+#endif++ -- Otherwise create a binding and use that as the master. This is equivalent to changing+ -- c -< x+ -- into+ -- finalStmt <- c -< x+ -- idC -< finalStmt+ _ -> do+ let ref = Ref (PortName finLoc "final:stmt")+ bodyBinding (Just ref) (bod)+ circuitMasters .= ref++ stmt -> errM (locA finLoc) ("Unhandled final stmt " <> show (Data.toConstr stmt))++ -- the simple case without do notation+ L loc master -> do+ circuitLoc .= loc+ circuitMasters .= bindMaster (L loc master)++-- | Handle a single statement.+handleStmtM+ :: GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LHsExpr GhcPs))+ -> CircuitM ()+handleStmtM (L loc stmt) = case stmt of+#if __GLASGOW_HASKELL__ >= 902+ LetStmt _xlet letBind ->+#else+ LetStmt _xlet (L _ letBind) ->+#endif+ -- a regular let bindings+ case letBind of+ HsValBinds _ (ValBinds _ valBinds sigs) -> do+ circuitLets <>= bagToList valBinds+ circuitTypes <>= sigs+ _ -> errM (locA loc) ("Unhandled let statement" <> show (Data.toConstr letBind))+ BodyStmt _xbody body _idr _idr' ->+ bodyBinding Nothing body+#if __GLASGOW_HASKELL__ >= 900+ BindStmt _ bind body ->+#else+ BindStmt _xbody bind body _idr _idr' ->+#endif+ bodyBinding (Just $ bindSlave bind) body+ _ -> errM (locA loc) "Unhandled stmt"++-- | Turn patterns to the left of a @<-@ into a PortDescription.+bindSlave :: p ~ GhcPs => LPat p -> PortDescription PortName+bindSlave (L loc expr) = case expr of+ VarPat _ (L _ rdrName) -> Ref (PortName loc (fromRdrName rdrName))+ TuplePat _ lpat _ -> Tuple $ fmap bindSlave lpat+ ParPatP lpat -> bindSlave lpat+#if __GLASGOW_HASKELL__ >= 902+ ConPat _ (L _ (GHC.Unqual occ)) (PrefixCon [] [lpat])+#elif __GLASGOW_HASKELL__ >= 900+ ConPat _ (L _ (GHC.Unqual occ)) (PrefixCon [lpat])+#else+ ConPatIn (L _ (GHC.Unqual occ)) (PrefixCon [lpat])+#endif+ | OccName.occNameString occ `elem` fwdNames -> FwdPat lpat+ -- empty list is done as the constructor+#if __GLASGOW_HASKELL__ >= 900+ ConPat _ (L _ rdr) _+#else+ ConPatIn (L _ rdr) _+#endif+ | rdr == thName '[] -> Vec loc []+ | rdr == thName '() -> Tuple []+#if __GLASGOW_HASKELL__ < 810+ SigPat ty port -> PortType (hsSigWcType ty) (bindSlave port)+#elif __GLASGOW_HASKELL__ < 900+ SigPat _ port ty -> PortType (hsSigWcType ty) (bindSlave port)+#else+ SigPat _ port ty -> PortType (hsps_body ty) (bindSlave port)+#endif+ LazyPat _ lpat -> Lazy loc (bindSlave lpat)+ ListPat _ pats -> Vec loc (map bindSlave pats)+ pat ->+ PortErr loc+ (mkLocMessage+ sevFatal+ (locA loc)+ (Outputable.text $ "Unhandled pattern " <> show (Data.toConstr pat))+ )++-- | Turn expressions to the right of a @-<@ into a PortDescription.+bindMaster :: LHsExpr GhcPs -> PortDescription PortName+bindMaster (L loc expr) = case expr of+ HsVar _xvar (L _vloc rdrName)+ | rdrName == thName '() -> Tuple []+ | rdrName == thName '[] -> Vec loc [] -- XXX: vloc?+ | otherwise -> Ref (PortName loc (fromRdrName rdrName)) -- XXX: vloc?+ HsApp _xapp (L _ (HsVar _ (L _ (GHC.Unqual occ)))) sig+ | OccName.occNameString occ `elem` fwdNames -> FwdExpr sig+ ExplicitTuple _ tups _ -> let+#if __GLASGOW_HASKELL__ >= 902+ vals = fmap (\(Present _ e) -> e) tups+#else+ vals = fmap (\(L _ (Present _ e)) -> e) tups+#endif+ in Tuple $ fmap bindMaster vals+#if __GLASGOW_HASKELL__ >= 902+ ExplicitList _ exprs ->+#else+ ExplicitList _ _syntaxExpr exprs ->+#endif+ Vec loc $ fmap bindMaster exprs+#if __GLASGOW_HASKELL__ < 810+ HsArrApp _xapp (L _ (HsVar _ (L _ (GHC.Unqual occ)))) sig _ _+ | OccName.occNameString occ `elem` fwdNames -> FwdExpr sig+ ExprWithTySig ty expr' -> PortType (hsSigWcType ty) (bindMaster expr')+ ELazyPat _ expr' -> Lazy loc (bindMaster expr')+#else+ -- XXX: Untested?+ HsProc _ _ (L _ (HsCmdTop _ (L _ (HsCmdArrApp _xapp (L _ (HsVar _ (L _ (GHC.Unqual occ)))) sig _ _))))+ | OccName.occNameString occ `elem` fwdNames -> FwdExpr sig+ ExprWithTySig _ expr' ty -> PortType (hsSigWcType ty) (bindMaster expr')+#endif++ HsParP expr' -> bindMaster expr'++ -- OpApp _xapp (L _ circuitVar) (L _ infixVar) appR -> k++ _ -> PortErr loc+ (mkLocMessage+ sevFatal+ (locA loc)+ (Outputable.text $ "Unhandled expression " <> show (Data.toConstr expr))+ )++-- | Create a binding expression+bodyBinding+ :: Maybe (PortDescription PortName)+ -- ^ the bound variable, this can be Nothing if there is no @<-@ (a circuit with no slaves)+ -> GenLocated SrcSpanAnnA (HsExpr GhcPs)+ -- ^ the statement with an optional @-<@+ -> CircuitM ()+bodyBinding mInput lexpr@(L loc expr) = do+ case expr of+#if __GLASGOW_HASKELL__ < 810+ HsArrApp _xhsArrApp circuit port HsFirstOrderApp True ->+ circuitBinds <>= [Binding+ { bCircuit = circuit+ , bOut = bindMaster port+ , bIn = fromMaybe (Tuple []) mInput+ }]+#else+ OpApp _ circuit (L _ op) port | isFletching op -> do+ circuitBinds <>= [Binding+ { bCircuit = circuit+ , bOut = bindMaster port+ , bIn = fromMaybe (Tuple []) mInput+ }]+#endif++ _ -> case mInput of+ Nothing -> errM (locA loc) "standalone expressions are not allowed (are Arrows enabled?)"+ Just input -> circuitBinds <>= [Binding+ { bCircuit = lexpr+ , bOut = Tuple []+ , bIn = input+ }]++-- Checking ------------------------------------------------------------++data Dir = Slave | Master++checkCircuit :: p ~ GhcPs => CircuitM ()+checkCircuit = do+ slaves <- L.use circuitSlaves+ masters <- L.use circuitMasters+ binds <- L.use circuitBinds++ let portNames d = L.toListOf (L.cosmos . _Ref . L.to (f d))+ f :: Dir -> PortName -> (GHC.FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))+ f Slave (PortName srcLoc portName) = (portName, ([srcLoc], []))+ f Master (PortName srcLoc portName) = (portName, ([], [srcLoc]))+ bindingNames = \b -> portNames Master (bOut b) <> portNames Slave (bIn b)+ topNames = portNames Slave slaves <> portNames Master masters+ nameMap = listToUniqMap_C mappend $ topNames <> concatMap bindingNames binds++ duplicateMasters <- concat <$> forM (nonDetUniqMapToList nameMap) \(name, occ) -> do+ let isIgnored = case unpackFS name of {('_':_) -> True; _ -> False}++ case occ of+ ([], []) -> pure []+ ([_], [_]) -> pure []+ (s:_, []) | not isIgnored -> errM (locA s) ("Slave port " <> show name <> " has no associated master") >> pure []+ ([], m:_) | not isIgnored -> errM (locA m) ("Master port " <> show name <> " has no associated slave") >> pure []+ (ss@(s:_:_), _) ->+ -- would be nice to show locations of all occurrences here, not sure how to do that while+ -- keeping ghc api+ errM (locA s) ("Slave port " <> show name <> " defined " <> show (length ss) <> " times") >> pure []+ (_ss, ms) -> do+ -- if master is defined multiple times, we broadcast it+ if length ms > 1+ then pure [name]+ else pure []++ let+ modifyMulticast = \case+ Ref p@(PortName _ a) | a `elem` duplicateMasters -> RefMulticast p+ p -> p++ -- update relevant master ports to be multicast+ circuitSlaves %= L.transform modifyMulticast+ circuitMasters %= L.transform modifyMulticast+ circuitBinds . L.mapped %= \b -> b+ { bIn = L.transform modifyMulticast (bIn b),+ bOut = L.transform modifyMulticast (bOut b)+ }++-- Creating ------------------------------------------------------------++data Direction = Fwd | Bwd deriving Show++bindWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => GHC.DynFlags -> Direction -> PortDescription PortName -> LPat p+bindWithSuffix dflags dir = \case+ Tuple ps -> tildeP noSrcSpanA $ taggedBundleP $ tupP $ fmap (bindWithSuffix dflags dir) ps+ Vec s ps -> taggedBundleP $ vecP s $ fmap (bindWithSuffix dflags dir) ps+ Ref (PortName loc fs) -> varP loc (GHC.unpackFS fs <> "_" <> show dir)+ RefMulticast (PortName loc fs) -> case dir of+ Bwd -> L loc (WildPat noExtField)+ Fwd -> varP loc (GHC.unpackFS fs <> "_" <> show dir)+ PortErr loc msgdoc -> unsafePerformIO . throwOneError $+ mkLongErrMsg dflags (locA loc) Outputable.alwaysQualify (Outputable.text "Unhandled bind") msgdoc+ Lazy loc p -> tildeP loc $ bindWithSuffix dflags dir p+#if __GLASGOW_HASKELL__ >= 902+ -- XXX: propagate location+ FwdExpr (L _ _) -> nlWildPat+#else+ FwdExpr (L l _) -> L l (WildPat noExt)+#endif+ FwdPat lpat -> tagP lpat+ PortType ty p -> tagTypeP dir ty $ bindWithSuffix dflags dir p++revDirec :: Direction -> Direction+revDirec = \case+ Fwd -> Bwd+ Bwd -> Fwd++bindOutputs+ :: (p ~ GhcPs, ?nms :: ExternalNames)+ => GHC.DynFlags+ -> Direction+ -> PortDescription PortName+ -- ^ slave ports+ -> PortDescription PortName+ -- ^ master ports+ -> LPat p+bindOutputs dflags direc slaves masters = noLoc $ conPatIn (noLoc (fwdBwdCon ?nms)) (InfixCon m2s s2m)+ where+ m2s = bindWithSuffix dflags direc masters+ s2m = bindWithSuffix dflags (revDirec direc) slaves++expWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> PortDescription PortName -> LHsExpr p+expWithSuffix dir = \case+ Tuple ps -> taggedBundleE $ tupE noSrcSpanA $ fmap (expWithSuffix dir) ps+ Vec s ps -> taggedBundleE $ vecE s $ fmap (expWithSuffix dir) ps+ Ref (PortName loc fs) -> varE loc (var $ GHC.unpackFS fs <> "_" <> show dir)+ RefMulticast (PortName loc fs) -> case dir of+ Bwd -> varE noSrcSpanA (trivialBwd ?nms)+ Fwd -> varE loc (var $ GHC.unpackFS fs <> "_" <> show dir)+ -- laziness only affects the pattern side+ Lazy _ p -> expWithSuffix dir p+ PortErr _ _ -> error "expWithSuffix PortErr!"+ FwdExpr lexpr -> tagE lexpr+ FwdPat (L l _) -> tagE $ varE l (trivialBwd ?nms)+ PortType ty p -> tagTypeE dir ty (expWithSuffix dir p)++createInputs+ :: (p ~ GhcPs, ?nms :: ExternalNames)+ => Direction+ -> PortDescription PortName+ -- ^ slave ports+ -> PortDescription PortName+ -- ^ master ports+ -> LHsExpr p+createInputs dir slaves masters = noLoc $ OpApp noExt s2m (varE noSrcSpanA (fwdBwdCon ?nms)) m2s+ where+ m2s = expWithSuffix (revDirec dir) masters+ s2m = expWithSuffix dir slaves++decFromBinding :: (p ~ GhcPs, ?nms :: ExternalNames) => GHC.DynFlags -> Binding (LHsExpr p) PortName -> HsBind p+decFromBinding dflags Binding {..} = do+ let bindPat = bindOutputs dflags Bwd bIn bOut+ inputExp = createInputs Fwd bOut bIn+ bod = runCircuitFun noSrcSpanA `appE` bCircuit `appE` inputExp+ in patBind bindPat bod++patBind :: LPat GhcPs -> LHsExpr GhcPs -> HsBind GhcPs+patBind lhs expr = PatBind noExt lhs rhs+#if __GLASGOW_HASKELL__ < 906+ ([], [])+#endif+ where+ rhs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))+ rhs = GRHSs emptyComments [gr] $+#if __GLASGOW_HASKELL__ >= 902+ EmptyLocalBinds noExtField+#else+ noLoc (EmptyLocalBinds noExtField)+#endif++#if __GLASGOW_HASKELL__ < 904+ gr :: GenLocated SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))+ gr = L (locA (getLoc expr)) (GRHS noExt [] expr)+#else+ gr :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))+ gr = L (noAnnSrcSpan (getLocA expr)) (GRHS noExt [] expr)+#endif++circuitConstructor :: (?nms :: ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs+circuitConstructor loc = varE loc (circuitCon ?nms)++runCircuitFun :: (?nms :: ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs+runCircuitFun loc = varE loc (runCircuitName ?nms)+++#if __GLASGOW_HASKELL__ < 902+prefixCon :: [arg] -> HsConDetails arg rec+prefixCon a = PrefixCon a+#else+prefixCon :: [arg] -> HsConDetails tyarg arg rec+prefixCon a = PrefixCon [] a+#endif++taggedBundleP :: (p ~ GhcPs, ?nms :: ExternalNames) => LPat p -> LPat p+taggedBundleP a = noLoc (conPatIn (noLoc (tagBundlePat ?nms)) (prefixCon [a]))++taggedBundleE :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsExpr p -> LHsExpr p+taggedBundleE a = varE noSrcSpanA (tagBundlePat ?nms) `appE` a++tagP :: (p ~ GhcPs, ?nms :: ExternalNames) => LPat p -> LPat p+tagP a = noLoc (conPatIn (noLoc (tagName ?nms)) (prefixCon [a]))++tagE :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsExpr p -> LHsExpr p+tagE a = varE noSrcSpanA (tagName ?nms) `appE` a++tagTypeCon :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsType GhcPs+tagTypeCon = noLoc (HsTyVar noExt NotPromoted (noLoc (tagTName ?nms)))++sigPat :: (p ~ GhcPs) => SrcSpanAnnA -> LHsType GhcPs -> LPat p -> LPat p+sigPat loc ty a = L loc $+#if __GLASGOW_HASKELL__ < 810+ SigPat (HsWC noExt (HsIB noExt ty)) a+#elif __GLASGOW_HASKELL__ < 900+ SigPat noExt a (HsWC noExt (HsIB noExt ty))+#else+ SigPat noExt a (HsPS noExt ty)+#endif++sigE :: (?nms :: ExternalNames) => SrcSpanAnnA -> LHsType GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+sigE loc ty a = L loc $+#if __GLASGOW_HASKELL__ < 810+ ExprWithTySig (HsWC noExt (HsIB noExt ty)) a+#elif __GLASGOW_HASKELL__ < 902+ ExprWithTySig noExt a (HsWC noExt (HsIB noExt ty))+#else+ ExprWithTySig noExt a (HsWC noExtField (L loc $ HsSig noExtField (HsOuterImplicit noExtField) ty))+#endif++tagTypeP :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> LHsType GhcPs -> LPat p -> LPat p+tagTypeP dir ty+ = sigPat noSrcSpanA (tagTypeCon `appTy` ty `appTy` busType)+ where+ busType = conT noSrcSpanA (fwdAndBwdTypes ?nms dir) `appTy` ty++tagTypeE :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> LHsType GhcPs -> LHsExpr p -> LHsExpr p+tagTypeE dir ty a+ = sigE noSrcSpanA (tagTypeCon `appTy` ty `appTy` busType) a+ where+ busType = conT noSrcSpanA (fwdAndBwdTypes ?nms dir) `appTy` ty++constVar :: SrcSpanAnnA -> LHsExpr GhcPs+constVar loc = varE loc (thName 'const)++deepShowD :: Data.Data a => a -> String+deepShowD a = show (Data.toConstr a) <>+ -- " (" <> (unwords . fst) (SYB.gmapM (\x -> ([show $ Data.toConstr x], x)) a) <> ")"+ " (" <> (unwords . fst) (SYB.gmapM (\x -> ([deepShowD x], x)) a) <> ")"++unsnoc :: [a] -> Maybe ([a], a)+unsnoc [] = Nothing+unsnoc [x] = Just ([], x)+unsnoc (x:xs) = Just (x:a, b)+ where Just (a,b) = unsnoc xs++hsFunTy :: (p ~ GhcPs) => LHsType p -> LHsType p -> HsType p+hsFunTy =+ HsFunTy noExt+#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 904+ (HsUnrestrictedArrow GHC.NormalSyntax)+#elif __GLASGOW_HASKELL__ >= 904+ (HsUnrestrictedArrow $ L NoTokenLoc HsNormalTok)+#endif++arrTy :: p ~ GhcPs => LHsType p -> LHsType p -> LHsType p+arrTy a b = noLoc $ hsFunTy (parenthesizeHsType GHC.funPrec a) (parenthesizeHsType GHC.funPrec b)++varT :: SrcSpanAnnA -> String -> LHsType GhcPs+varT loc nm = L loc (HsTyVar noExt NotPromoted (noLoc (tyVar nm)))++conT :: SrcSpanAnnA -> GHC.RdrName -> LHsType GhcPs+conT loc nm = L loc (HsTyVar noExt NotPromoted (noLoc nm))++-- perhaps this should happen on construction+gatherTypes+ :: p ~ GhcPs+ => PortDescription PortName+ -> CircuitM ()+gatherTypes = L.traverseOf_ L.cosmos addTypes+ where+ addTypes = \case+ PortType ty (Ref (PortName loc fs)) ->+ portVarTypes %= \pvt -> alterUniqMap (const (Just (loc, ty))) pvt fs+ PortType ty p -> portTypes <>= [(ty, p)]+ _ -> pure ()++tyEq :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs+tyEq a b =+#if __GLASGOW_HASKELL__ < 904+ noLoc $ HsOpTy noExtField a (noLoc eqTyCon_RDR) b+#else+ noLoc $ HsOpTy noAnn NotPromoted a (noLoc eqTyCon_RDR) b+#endif+-- eqTyCon is a special name that has to be exactly correct for ghc to recognise it. In 8.6 this+-- lives in PrelNames and is called eqTyCon_RDR, in later ghcs it's from TysWiredIn.++-- Final construction --------------------------------------------------++circuitQQExpM+ :: (p ~ GhcPs, ?nms :: ExternalNames)+ => CircuitM (LHsExpr p)+circuitQQExpM = do+ checkCircuit++ dflags <- GHC.getDynFlags+ binds <- L.use circuitBinds+ lets <- L.use circuitLets+ letTypes <- L.use circuitTypes+ slaves <- L.use circuitSlaves+ masters <- L.use circuitMasters++ -- Construction of the circuit expression+ let decs = lets <> map (noLoc . decFromBinding dflags) binds++ let pats = bindOutputs dflags Fwd masters slaves+ res = createInputs Bwd slaves masters++ body :: LHsExpr GhcPs+ body = letE noSrcSpanA letTypes decs res++ -- see [inference-helper]+ mapM_+ (\(Binding _ outs ins) -> gatherTypes outs >> gatherTypes ins)+ binds+ mapM_ gatherTypes [masters, slaves]++ pure $ circuitConstructor noSrcSpanA `appE` lamE [pats] body++grr :: MonadIO m => OccName.NameSpace -> m ()+grr nm+ | nm == OccName.tcName = liftIO $ putStrLn "tcName"+ | nm == OccName.clsName = liftIO $ putStrLn "clsName"+ | nm == OccName.tcClsName = liftIO $ putStrLn "tcClsName"+ | nm == OccName.dataName = liftIO $ putStrLn "dataName"+ | nm == OccName.varName = liftIO $ putStrLn "varName"+ | nm == OccName.tvName = liftIO $ putStrLn "tvName"+ | otherwise = liftIO $ putStrLn "I dunno"++completeUnderscores :: (?nms :: ExternalNames) => CircuitM ()+completeUnderscores = do+ binds <- L.use circuitBinds+ masters <- L.use circuitMasters+ slaves <- L.use circuitSlaves+ let addDef :: String -> PortDescription PortName -> CircuitM ()+ addDef suffix = \case+ Ref (PortName loc (unpackFS -> name@('_':_))) -> do+ let bind = patBind (varP loc (name <> suffix)) (tagE $ varE loc (thName 'def))+ circuitLets <>= [L loc bind]++ _ -> pure ()+ addBind :: Binding exp PortName -> CircuitM ()+ addBind (Binding _ bOut bIn) = do+ L.traverseOf_ L.cosmos (addDef "_Fwd") bOut+ L.traverseOf_ L.cosmos (addDef "_Bwd") bIn+ mapM_ addBind binds+ addBind (Binding undefined masters slaves)+++-- | Transform declarations in the module by converting circuit blocks.+transform+ :: (?nms :: ExternalNames)+ => Bool+#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 906+ -> GHC.Located HsModule+ -> GHC.Hsc (GHC.Located HsModule)+#else+ -> GHC.Located (HsModule GhcPs)+ -> GHC.Hsc (GHC.Located (HsModule GhcPs))+#endif+transform debug = SYB.everywhereM (SYB.mkM transform') where+ transform' :: LHsExpr GhcPs -> GHC.Hsc (LHsExpr GhcPs)++ -- the circuit keyword directly applied (either with parenthesis or with BlockArguments)+ transform' (L _ (HsApp _xapp (L _ circuitVar) lappB))+ | isCircuitVar circuitVar = runCircuitM $ do+ x <- parseCircuit lappB >> completeUnderscores >> circuitQQExpM+ when debug $ ppr x+ pure x++ -- `circuit $` application+ transform' (L _ (OpApp _xapp c@(L _ circuitVar) (L _ infixVar) appR))+ | isDollar infixVar && dollarChainIsCircuit circuitVar = do+ runCircuitM $ do+ x <- parseCircuit appR >> completeUnderscores >> circuitQQExpM+ when debug $ ppr x+ pure (dollarChainReplaceCircuit x c)++ transform' e = pure e++-- | check if circuit is applied via `a $ chain $ of $ dollars`.+dollarChainIsCircuit :: HsExpr GhcPs -> Bool+dollarChainIsCircuit = \case+ HsVar _ (L _ v) -> v == GHC.mkVarUnqual "circuit"+ OpApp _xapp _appL (L _ infixVar) (L _ appR) -> isDollar infixVar && dollarChainIsCircuit appR+ _ -> False++-- | Replace the circuit if it's part of a chain of `$`.+dollarChainReplaceCircuit :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+dollarChainReplaceCircuit circuitExpr (L loc app) = case app of+ HsVar _ (L _loc v)+ -> if v == GHC.mkVarUnqual "circuit"+ then circuitExpr+ else error "dollarChainAddCircuit: not a circuit"+ OpApp xapp appL (L infixLoc infixVar) appR+ -> L loc $ OpApp xapp appL (L infixLoc infixVar) (dollarChainReplaceCircuit circuitExpr appR)+ t -> error $ "dollarChainAddCircuit unhandled case " <> showC t++-- | The plugin for circuit notation.+plugin :: GHC.Plugin+plugin = mkPlugin defExternalNames++-- | Make a plugin with custom external names+mkPlugin :: ExternalNames -> GHC.Plugin+mkPlugin nms = GHC.defaultPlugin+ { GHC.parsedResultAction = let ?nms = nms in pluginImpl+ -- Mark plugin as 'pure' to prevent recompilations.+ , GHC.pluginRecompile = \_cliOptions -> pure GHC.NoForceRecompile+ }++warningMsg :: Outputable.SDoc -> GHC.Hsc ()+warningMsg sdoc = do+ dflags <- GHC.getDynFlags+#if __GLASGOW_HASKELL__ < 902+ liftIO $ Err.warningMsg dflags sdoc+#elif __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904+ logger <- GHC.getLogger+ liftIO $ Err.warningMsg logger dflags sdoc+#else+ logger <- GHC.getLogger+ let+ diagOpts = GHC.initDiagOpts dflags+ mc = Err.mkMCDiagnostic diagOpts GHC.WarningWithoutFlag+#if __GLASGOW_HASKELL__ >= 906+ Nothing+#endif+ liftIO $ GHC.logMsg logger mc noSrcSpan sdoc+#endif++-- | The actual implementation.+pluginImpl ::+ (?nms :: ExternalNames) => [GHC.CommandLineOption] -> GHC.ModSummary ->+#if __GLASGOW_HASKELL__ < 904+ GHC.HsParsedModule -> GHC.Hsc GHC.HsParsedModule+#else+ GHC.ParsedResult -> GHC.Hsc GHC.ParsedResult+#endif+pluginImpl cliOptions _modSummary m = do+ -- cli options are activated by -fplugin-opt=CircuitNotation:debug+ debug <- case cliOptions of+ [] -> pure False+ ["debug"] -> pure True+ _ -> do+ warningMsg $ Outputable.text $ "CircuitNotation: unknown cli options " <> show cliOptions+ pure False+ hpm_module' <- do+#if __GLASGOW_HASKELL__ < 904+ transform debug (GHC.hpm_module m)+ let module' = m { GHC.hpm_module = hpm_module' }+#else+ transform debug $ GHC.hpm_module $ GHC.parsedResultModule m+ let parsedResultModule' = (GHC.parsedResultModule m)+ { GHC.hpm_module = hpm_module' }+ module' = m { GHC.parsedResultModule = parsedResultModule' }+#endif+ return module'++-- Debugging functions -------------------------------------------------++ppr :: GHC.Outputable a => a -> CircuitM ()+ppr a = do+ dflags <- GHC.getDynFlags+ liftIO $ putStrLn (GHC.showPpr dflags a)++showC :: Data.Data a => a -> String+showC a = show (typeOf a) <> " " <> show (Data.toConstr a)++-- Names ---------------------------------------------------------------++fwdNames :: [String]+fwdNames = ["Fwd", "Signal"]++-- | Collection of names external to circuit-notation.+data ExternalNames = ExternalNames+ { circuitCon :: GHC.RdrName+ , runCircuitName :: GHC.RdrName+ , tagBundlePat :: GHC.RdrName+ , tagName :: GHC.RdrName+ , tagTName :: GHC.RdrName+ , fwdBwdCon :: GHC.RdrName+ , fwdAndBwdTypes :: Direction -> GHC.RdrName+ , trivialBwd :: GHC.RdrName+ , consPat :: GHC.RdrName+ }++defExternalNames :: ExternalNames+defExternalNames = ExternalNames+ { circuitCon = GHC.Unqual (OccName.mkDataOcc "TagCircuit")+ , runCircuitName = GHC.Unqual (OccName.mkVarOcc "runTagCircuit")+ , tagBundlePat = GHC.Unqual (OccName.mkDataOcc "BusTagBundle")+ , tagName = GHC.Unqual (OccName.mkDataOcc "BusTag")+ , tagTName = GHC.Unqual (OccName.mkTcOcc "BusTag")+ , fwdBwdCon = GHC.Unqual (OccName.mkDataOcc ":->")+ , fwdAndBwdTypes = \case+ Fwd -> GHC.Unqual (OccName.mkTcOcc "Fwd")+ Bwd -> GHC.Unqual (OccName.mkTcOcc "Bwd")+ , trivialBwd = GHC.Unqual (OccName.mkVarOcc "unitBwd")+#if __GLASGOW_HASKELL__ > 900+ , consPat = GHC.Unqual (OccName.mkDataOcc ":>!")+#else+ , consPat = GHC.Unqual (OccName.mkDataOcc ":>")+#endif+ }
+ src/GHC/Types/Unique/Map.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}++-- Like 'UniqFM', these are maps for keys which are Uniquable.+-- Unlike 'UniqFM', these maps also remember their keys, which+-- makes them a much better drop in replacement for 'Data.Map.Map'.+--+-- Key preservation is right-biased.+module GHC.Types.Unique.Map (+ UniqMap(..),+ emptyUniqMap,+ isNullUniqMap,+ unitUniqMap,+ listToUniqMap,+ listToUniqMap_C,+ addToUniqMap,+ addListToUniqMap,+ addToUniqMap_C,+ addToUniqMap_Acc,+ alterUniqMap,+ addListToUniqMap_C,+ adjustUniqMap,+ delFromUniqMap,+ delListFromUniqMap,+ plusUniqMap,+ plusUniqMap_C,+ plusMaybeUniqMap_C,+ plusUniqMapList,+ minusUniqMap,+ intersectUniqMap,+ disjointUniqMap,+ mapUniqMap,+ filterUniqMap,+ partitionUniqMap,+ sizeUniqMap,+ elemUniqMap,+ lookupUniqMap,+ lookupWithDefaultUniqMap,+ anyUniqMap,+ allUniqMap+) where++#if __GLASGOW_HASKELL__ < 900+import Unique+import UniqFM+import Outputable+#else+import GHC.Types.Unique.FM+import GHC.Types.Unique+import GHC.Utils.Outputable+#endif++import Data.Semigroup as Semi ( Semigroup(..) )+import Data.Coerce+import Data.Maybe+import Data.Data++-- | Maps indexed by 'Uniquable' keys+#if __GLASGOW_HASKELL__ < 900+newtype UniqMap k a = UniqMap (UniqFM (k, a))+#else+newtype UniqMap k a = UniqMap (UniqFM k (k, a))+#endif+ deriving (Data, Eq, Functor)+type role UniqMap nominal representational++instance Semigroup (UniqMap k a) where+ (<>) = plusUniqMap++instance Monoid (UniqMap k a) where+ mempty = emptyUniqMap+ mappend = (Semi.<>)++instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where+ ppr (UniqMap m) =+ brackets $ fsep $ punctuate comma $+ [ ppr k <+> text "->" <+> ppr v+ | (k, v) <- eltsUFM m ]++liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)+liftC f (_, v) (k', v') = (k', f v v')++emptyUniqMap :: UniqMap k a+emptyUniqMap = UniqMap emptyUFM++isNullUniqMap :: UniqMap k a -> Bool+isNullUniqMap (UniqMap m) = isNullUFM m++unitUniqMap :: Uniquable k => k -> a -> UniqMap k a+unitUniqMap k v = UniqMap (unitUFM k (k, v))++listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a+listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs])++listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a+listToUniqMap_C f kvs = UniqMap $+ listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs]++addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a+addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v)++addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a+addListToUniqMap (UniqMap m) kvs = UniqMap $+ addListToUFM m [(k,(k,v)) | (k,v) <- kvs]++addToUniqMap_C :: Uniquable k+ => (a -> a -> a)+ -> UniqMap k a+ -> k+ -> a+ -> UniqMap k a+addToUniqMap_C f (UniqMap m) k v = UniqMap $+ addToUFM_C (liftC f) m k (k, v)++addToUniqMap_Acc :: Uniquable k+ => (b -> a -> a)+ -> (b -> a)+ -> UniqMap k a+ -> k+ -> b+ -> UniqMap k a+addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $+ addToUFM_Acc (\b (k, v) -> (k, exi b v))+ (\b -> (k0, new b))+ m k0 v0++alterUniqMap :: Uniquable k+ => (Maybe a -> Maybe a)+ -> UniqMap k a+ -> k+ -> UniqMap k a+alterUniqMap f (UniqMap m) k = UniqMap $+ alterUFM (fmap (k,) . f . fmap snd) m k++addListToUniqMap_C+ :: Uniquable k+ => (a -> a -> a)+ -> UniqMap k a+ -> [(k, a)]+ -> UniqMap k a+addListToUniqMap_C f (UniqMap m) kvs = UniqMap $+ addListToUFM_C (liftC f) m+ [(k,(k,v)) | (k,v) <- kvs]++adjustUniqMap+ :: Uniquable k+ => (a -> a)+ -> UniqMap k a+ -> k+ -> UniqMap k a+adjustUniqMap f (UniqMap m) k = UniqMap $+ adjustUFM (\(_,v) -> (k,f v)) m k++delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a+delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k++delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a+delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks++plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a+plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2++plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a+plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $+ plusUFM_C (liftC f) m1 m2++plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a+plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $+ plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2++plusUniqMapList :: [UniqMap k a] -> UniqMap k a+plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)++minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a+minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2++intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a+intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2++disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool+disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2++mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b+mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance++filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a+filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m++partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)+partitionUniqMap f (UniqMap m) =+ coerce $ partitionUFM (f . snd) m++sizeUniqMap :: UniqMap k a -> Int+sizeUniqMap (UniqMap m) = sizeUFM m++elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool+elemUniqMap k (UniqMap m) = elemUFM k m++lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a+lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k)++lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a+lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k))++anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool+anyUniqMap f (UniqMap m) = anyUFM (f . snd) m++allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool+allUniqMap f (UniqMap m) = allUFM (f . snd) m
+ src/GHC/Types/Unique/Map/Extra.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}++module GHC.Types.Unique.Map.Extra where++#if __GLASGOW_HASKELL__ >= 902+import "ghc" GHC.Types.Unique.Map+#else+import GHC.Types.Unique.Map+#endif++#if __GLASGOW_HASKELL__ >= 900+import GHC.Types.Unique.FM (nonDetEltsUFM)+#elif __GLASGOW_HASKELL__ <= 810+import UniqFM (nonDetEltsUFM)+#endif++nonDetUniqMapToList :: UniqMap key a -> [(key, a)]+nonDetUniqMapToList (UniqMap u) = nonDetEltsUFM u
+ tests/unittests.hs view
@@ -0,0 +1,11 @@+-- This option is a test by itself: if we were to export a plugin with the+-- wrong type or name, GHC would refuse to compile this file.+{-# OPTIONS -fplugin=CircuitNotation #-}++module Main where++import Circuit+import Example++main :: IO ()+main = pure ()