add back support for port type signatures

example/Example.hs

@@ -133,6 +133,21 @@ unfstC3 = circuit $ \a -> do
   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)

src/CircuitNotation.hs

@@ -559,6 +559,8 @@ bindMaster (L loc expr) = case expr of
   ExprWithTySig _ expr' ty -> PortType (hsSigWcType ty) (bindMaster expr')
 #endif
 
+  HsPar _ expr' -> bindMaster expr'
+
   -- OpApp _xapp (L _ circuitVar) (L _ infixVar) appR -> k
 
   _ -> PortErr loc
@@ -653,9 +655,9 @@ checkCircuit = do
 
 -- Creating ------------------------------------------------------------
 
-data Direc = Fwd | Bwd deriving Show
+data Direction = Fwd | Bwd deriving Show
 
-bindWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => GHC.DynFlags -> Direc -> PortDescription PortName -> LPat p
+bindWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => GHC.DynFlags -> Direction -> PortDescription PortName -> LPat p
 bindWithSuffix dflags dir = \case
   Tuple ps -> tildeP noSrcSpan $ taggedBundleP $ tupP $ fmap (bindWithSuffix dflags dir) ps
   Vec s ps -> taggedBundleP $ vecP s $ fmap (bindWithSuffix dflags dir) ps
@@ -668,17 +670,17 @@ bindWithSuffix dflags dir = \case
   Lazy loc p -> tildeP loc $ bindWithSuffix dflags dir p
   FwdExpr (L l _) -> L l (WildPat noExt)
   FwdPat lpat -> tagP lpat
-  PortType _ p -> bindWithSuffix dflags dir p
+  PortType ty p -> tagTypeP dir ty $ bindWithSuffix dflags dir p
 
-revDirec :: Direc -> Direc
+revDirec :: Direction -> Direction
 revDirec = \case
   Fwd -> Bwd
   Bwd -> Fwd
 
 bindOutputs
   :: (p ~ GhcPs, ?nms :: ExternalNames)
   => GHC.DynFlags
-  -> Direc
+  -> Direction
   -> PortDescription PortName
   -- ^ slave ports
   -> PortDescription PortName
@@ -689,7 +691,7 @@ bindOutputs dflags direc slaves masters = noLoc $ conPatIn (noLoc (fwdBwdCon ?nm
   m2s = bindWithSuffix dflags direc masters
   s2m = bindWithSuffix dflags (revDirec direc) slaves
 
-expWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => Direc -> PortDescription PortName -> LHsExpr p
+expWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> PortDescription PortName -> LHsExpr p
 expWithSuffix dir = \case
   Tuple ps -> taggedBundleE $ tupE noSrcSpan $ fmap (expWithSuffix dir) ps
   Vec s ps -> taggedBundleE $ vecE s $ fmap (expWithSuffix dir) ps
@@ -702,11 +704,11 @@ expWithSuffix dir = \case
   PortErr _ _ -> error "expWithSuffix PortErr!"
   FwdExpr lexpr -> tagE lexpr
   FwdPat (L l _) -> tagE $ varE l (trivialBwd ?nms)
-  PortType _ p -> expWithSuffix dir p
+  PortType ty p -> tagTypeE dir ty (expWithSuffix dir p)
 
 createInputs
   :: (p ~ GhcPs, ?nms :: ExternalNames)
-  => Direc
+  => Direction
   -> PortDescription PortName
   -- ^ slave ports
   -> PortDescription PortName
@@ -748,6 +750,23 @@ tagP a = noLoc (conPatIn (noLoc (tagName ?nms)) (PrefixCon [a]))
 tagE :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsExpr p -> LHsExpr p
 tagE a = varE noSrcSpan (tagName ?nms) `appE` a
 
+-- L loc (HsTyVar noExt NotPromoted (L loc (tyVar nm)))
+
+tagTypeCon :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsType GhcPs
+tagTypeCon = noLoc (HsTyVar noExt NotPromoted (noLoc (tagTName ?nms)))
+
+tagTypeP :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> LHsType GhcPs -> LPat p -> LPat p
+tagTypeP dir ty a
+  = noLoc (SigPat (HsWC noExt (HsIB noExt (tagTypeCon `appTy` ty `appTy` busType))) a)
+  where
+    busType = conT noSrcSpan (fwdAndBwdTypes ?nms dir) `appTy` ty
+
+tagTypeE :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> LHsType GhcPs -> LHsExpr p -> LHsExpr p
+tagTypeE dir ty a
+  = noLoc (ExprWithTySig (HsWC noExt (HsIB noExt (tagTypeCon `appTy` ty `appTy` busType))) a)
+  where
+    busType = conT noSrcSpan (fwdAndBwdTypes ?nms dir) `appTy` ty
+
 constVar :: p ~ GhcPs => SrcSpan -> LHsExpr p
 constVar loc = varE loc (thName 'const)
 
@@ -955,7 +974,9 @@ data ExternalNames = ExternalNames
   , runCircuitName :: GHC.RdrName
   , tagBundlePat :: GHC.RdrName
   , tagName :: GHC.RdrName
+  , tagTName :: GHC.RdrName
   , fwdBwdCon :: GHC.RdrName
+  , fwdAndBwdTypes :: Direction -> GHC.RdrName
   , trivialBwd :: GHC.RdrName
   }
 
@@ -965,6 +986,10 @@ defExternalNames = ExternalNames
   , 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")
   }