Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Tagged implementation #14

Merged
merged 9 commits into from
Dec 1, 2023
Merged
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
rename to BusTag
jonfowler committed Dec 1, 2023
commit a8bdfbe2ecf2975c53a4d3180c396703c1f4b22f
146 changes: 73 additions & 73 deletions src/Circuit.hs
Original file line number Diff line number Diff line change
@@ -74,22 +74,22 @@ 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 = (TagFwd a :-> TagBwd b) -> (TagBwd a :-> TagFwd b)
type TagCircuitT a b = (BusTagFwd a :-> BusTagBwd b) -> (BusTagBwd a :-> BusTagFwd b)

newtype Tag t b = Tag {unTag :: b}
newtype BusTag t b = BusTag {unBusTag :: b}

type TagFwd a = Tag a (Fwd a)
type TagBwd a = Tag a (Bwd a)
type BusTagFwd a = BusTag a (Fwd a)
type BusTagBwd a = BusTag a (Bwd a)

mkTagCircuit :: TagCircuitT a b -> Circuit a b
mkTagCircuit f = Circuit $ \ (aFwd :-> bBwd) -> let
(Tag aBwd :-> Tag bFwd) = f (Tag aFwd :-> Tag bBwd)
(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 (unTag aFwd :-> unTag bBwd)
in (Tag aBwd :-> Tag bFwd)
(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
@@ -135,69 +135,69 @@ instance (TrivialBwd a, TrivialBwd b, TrivialBwd c, TrivialBwd d, TrivialBwd e,
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 (Tag t a) where
unitBwd = Tag unitBwd

class TagBundle t a where
type TagUnbundled t a = res | res -> t a
taggedBundle :: TagUnbundled t a -> Tag t a
taggedUnbundle :: Tag t a -> TagUnbundled t a

instance TagBundle () () where
type TagUnbundled () () = ()
taggedBundle = Tag
taggedUnbundle = unTag

instance TagBundle (ta, tb) (a, b) where
type TagUnbundled (ta, tb) (a, b) = (Tag ta a, Tag tb b)
taggedBundle (Tag a, Tag b) = Tag (a, b)
taggedUnbundle (Tag (a, b)) = (Tag a, Tag b)

instance TagBundle (ta, tb, tc) (a, b, c) where
type TagUnbundled (ta, tb, tc) (a, b, c) = (Tag ta a, Tag tb b, Tag tc c)
taggedBundle (Tag a, Tag b, Tag c) = Tag (a, b, c)
taggedUnbundle (Tag (a, b, c)) = (Tag a, Tag b, Tag c)

instance TagBundle (ta, tb, tc, td) (a, b, c, d) where
type TagUnbundled (ta, tb, tc, td) (a, b, c, d) = (Tag ta a, Tag tb b, Tag tc c, Tag td d)
taggedBundle (Tag a, Tag b, Tag c, Tag d) = Tag (a, b, c, d)
taggedUnbundle (Tag (a, b, c, d)) = (Tag a, Tag b, Tag c, Tag d)

instance TagBundle (ta, tb, tc, td, te) (a, b, c, d, e) where
type TagUnbundled (ta, tb, tc, td, te) (a, b, c, d, e) = (Tag ta a, Tag tb b, Tag tc c, Tag td d, Tag te e)
taggedBundle (Tag a, Tag b, Tag c, Tag d, Tag e) = Tag (a, b, c, d, e)
taggedUnbundle (Tag (a, b, c, d, e)) = (Tag a, Tag b, Tag c, Tag d, Tag e)

instance TagBundle (ta, tb, tc, td, te, tf) (a, b, c, d, e, f) where
type TagUnbundled (ta, tb, tc, td, te, tf) (a, b, c, d, e, f) = (Tag ta a, Tag tb b, Tag tc c, Tag td d, Tag te e, Tag tf f)
taggedBundle (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f) = Tag (a, b, c, d, e, f)
taggedUnbundle (Tag (a, b, c, d, e, f)) = (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f)

instance TagBundle (ta, tb, tc, td, te, tf, tg) (a, b, c, d, e, f, g) where
type TagUnbundled (ta, tb, tc, td, te, tf, tg) (a, b, c, d, e, f, g) = (Tag ta a, Tag tb b, Tag tc c, Tag td d, Tag te e, Tag tf f, Tag tg g)
taggedBundle (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g) = Tag (a, b, c, d, e, f, g)
taggedUnbundle (Tag (a, b, c, d, e, f, g)) = (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g)

instance TagBundle (ta, tb, tc, td, te, tf, tg, th) (a, b, c, d, e, f, g, h) where
type TagUnbundled (ta, tb, tc, td, te, tf, tg, th) (a, b, c, d, e, f, g, h) = (Tag ta a, Tag tb b, Tag tc c, Tag td d, Tag te e, Tag tf f, Tag tg g, Tag th h)
taggedBundle (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g, Tag h) = Tag (a, b, c, d, e, f, g, h)
taggedUnbundle (Tag (a, b, c, d, e, f, g, h)) = (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g, Tag h)

instance TagBundle (ta, tb, tc, td, te, tf, tg, th, ti) (a, b, c, d, e, f, g, h, i) where
type TagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti) (a, b, c, d, e, f, g, h, i) = (Tag ta a, Tag tb b, Tag tc c, Tag td d, Tag te e, Tag tf f, Tag tg g, Tag th h, Tag ti i)
taggedBundle (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g, Tag h, Tag i) = Tag (a, b, c, d, e, f, g, h, i)
taggedUnbundle (Tag (a, b, c, d, e, f, g, h, i)) = (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g, Tag h, Tag i)

instance TagBundle (ta, tb, tc, td, te, tf, tg, th, ti, tj) (a, b, c, d, e, f, g, h, i, j) where
type TagUnbundled (ta, tb, tc, td, te, tf, tg, th, ti, tj) (a, b, c, d, e, f, g, h, i, j) = (Tag ta a, Tag tb b, Tag tc c, Tag td d, Tag te e, Tag tf f, Tag tg g, Tag th h, Tag ti i, Tag tj j)
taggedBundle (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g, Tag h, Tag i, Tag j) = Tag (a, b, c, d, e, f, g, h, i, j)
taggedUnbundle (Tag (a, b, c, d, e, f, g, h, i, j)) = (Tag a, Tag b, Tag c, Tag d, Tag e, Tag f, Tag g, Tag h, Tag i, Tag j)

instance TagBundle (Vec n t) (Vec n a) where
type TagUnbundled (Vec n t) (Vec n a) = Vec n (Tag t a)
taggedBundle = Tag . fmap unTag
taggedUnbundle = fmap Tag . unTag

pattern TagBundle :: TagBundle t a => TagUnbundled t a -> Tag t a
pattern TagBundle a <- (taggedUnbundle -> a) where
TagBundle a = taggedBundle a
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
4 changes: 2 additions & 2 deletions src/CircuitNotation.hs
Original file line number Diff line number Diff line change
@@ -1122,8 +1122,8 @@ defExternalNames :: ExternalNames
defExternalNames = ExternalNames
{ circuitCon = GHC.Unqual (OccName.mkDataOcc "TagCircuit")
, runCircuitName = GHC.Unqual (OccName.mkVarOcc "runTagCircuit")
, tagBundlePat = GHC.Unqual (OccName.mkDataOcc "TagBundle")
, tagName = GHC.Unqual (OccName.mkDataOcc "Tag")
, tagBundlePat = GHC.Unqual (OccName.mkDataOcc "BusTagBundle")
, tagName = GHC.Unqual (OccName.mkDataOcc "BusTag")
, fwdBwdCon = GHC.Unqual (OccName.mkDataOcc ":->")
, trivialBwd = GHC.Unqual (OccName.mkVarOcc "unitBwd")
}