{-
 ██████╗██╗██████╗  ██████╗██╗   ██╗██╗████████╗███████╗
██╔════╝██║██╔══██╗██╔════╝██║   ██║██║╚══██╔══╝██╔════╝
██║     ██║██████╔╝██║     ██║   ██║██║   ██║   ███████╗
██║     ██║██╔══██╗██║     ██║   ██║██║   ██║   ╚════██║
╚██████╗██║██║  ██║╚██████╗╚██████╔╝██║   ██║   ███████║
 ╚═════╝╚═╝╚═╝  ╚═╝ ╚═════╝ ╚═════╝ ╚═╝   ╚═╝   ╚══════╝
  (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 :: forall p. (p ~ GhcPs) => FastString -> HsExpr p -> Bool
isSomeVar FastString
s = \case
  HsVar XVar p
_ (L SrcSpanAnnN
_ RdrName
v) -> RdrName
v RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> RdrName
GHC.mkVarUnqual FastString
s
  HsExpr p
_               -> Bool
False

isCircuitVar :: p ~ GhcPs => HsExpr p -> Bool
isCircuitVar :: forall p. (p ~ GhcPs) => HsExpr p -> Bool
isCircuitVar = FastString -> HsExpr p -> Bool
forall p. (p ~ GhcPs) => FastString -> HsExpr p -> Bool
isSomeVar FastString
"circuit"

isDollar :: p ~ GhcPs => HsExpr p -> Bool
isDollar :: forall p. (p ~ GhcPs) => HsExpr p -> Bool
isDollar = FastString -> HsExpr p -> Bool
forall p. (p ~ GhcPs) => FastString -> HsExpr p -> Bool
isSomeVar FastString
"$"

-- | Is (-<)?
isFletching :: p ~ GhcPs => HsExpr p -> Bool
isFletching :: forall p. (p ~ GhcPs) => HsExpr p -> Bool
isFletching = FastString -> HsExpr p -> Bool
forall p. (p ~ GhcPs) => FastString -> HsExpr p -> Bool
isSomeVar FastString
"-<"

imap :: (Int -> a -> b) -> [a] -> [b]
imap :: forall a b. (Int -> a -> b) -> [a] -> [b]
imap Int -> a -> b
f = (Int -> a -> b) -> [Int] -> [a] -> [b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> a -> b
f [Int
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 :: forall a. SrcSpanAnn' a -> SrcSpan
locA = SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
GHC.locA

noAnnSortKey :: AnnSortKey
noAnnSortKey :: AnnSortKey
noAnnSortKey = AnnSortKey
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 :: MessageClass
sevFatal = MessageClass
Err.MCFatal
#endif

#if __GLASGOW_HASKELL__ > 900
noExt :: EpAnn ann
noExt :: forall ann. EpAnn ann
noExt = EpAnn ann
forall ann. EpAnn ann
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 $mHsParP :: forall {r} {p}. HsExpr p -> (LHsExpr p -> r) -> ((# #) -> r) -> r
HsParP e <- HsPar _ _ e _

pattern ParPatP :: LPat p -> Pat p
pattern $mParPatP :: forall {r} {p}. Pat p -> (LPat p -> r) -> ((# #) -> r) -> r
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 :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
_ SrcSpan
locn PrintUnqualified
unqual =
    SrcSpan -> PrintUnqualified -> GhcMessage -> ErrMsg
forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
Err.mkErrorMsgEnvelope SrcSpan
locn PrintUnqualified
unqual
  (GhcMessage -> ErrMsg) -> (SDoc -> GhcMessage) -> SDoc -> ErrMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticMessage -> GhcMessage
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> GhcMessage
GHC.ghcUnknownMessage
  (DiagnosticMessage -> GhcMessage)
-> (SDoc -> DiagnosticMessage) -> SDoc -> GhcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcHint] -> SDoc -> DiagnosticMessage
Err.mkPlainError [GhcHint]
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 :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> ErrMsg
mkLongErrMsg DynFlags
_ SrcSpan
locn PrintUnqualified
unqual SDoc
msg SDoc
extra =
    SrcSpan -> PrintUnqualified -> GhcMessage -> ErrMsg
forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
Err.mkErrorMsgEnvelope SrcSpan
locn PrintUnqualified
unqual
  (GhcMessage -> ErrMsg) -> GhcMessage -> ErrMsg
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> GhcMessage
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> GhcMessage
GHC.ghcUnknownMessage
  (DiagnosticMessage -> GhcMessage)
-> DiagnosticMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> [SDoc] -> DiagnosticMessage
Err.mkDecoratedError [GhcHint]
Err.noHints [SDoc
msg, SDoc
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 (PortName -> PortName -> Bool
(PortName -> PortName -> Bool)
-> (PortName -> PortName -> Bool) -> Eq PortName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PortName -> PortName -> Bool
== :: PortName -> PortName -> Bool
$c/= :: PortName -> PortName -> Bool
/= :: PortName -> PortName -> Bool
Eq)

instance Show PortName where
  show :: PortName -> [Char]
show (PortName SrcSpanAnnA
_ FastString
fs) = FastString -> [Char]
GHC.unpackFS FastString
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 ((forall m. Monoid m => PortDescription m -> m)
-> (forall m a. Monoid m => (a -> m) -> PortDescription a -> m)
-> (forall m a. Monoid m => (a -> m) -> PortDescription a -> m)
-> (forall a b. (a -> b -> b) -> b -> PortDescription a -> b)
-> (forall a b. (a -> b -> b) -> b -> PortDescription a -> b)
-> (forall b a. (b -> a -> b) -> b -> PortDescription a -> b)
-> (forall b a. (b -> a -> b) -> b -> PortDescription a -> b)
-> (forall a. (a -> a -> a) -> PortDescription a -> a)
-> (forall a. (a -> a -> a) -> PortDescription a -> a)
-> (forall a. PortDescription a -> [a])
-> (forall a. PortDescription a -> Bool)
-> (forall a. PortDescription a -> Int)
-> (forall a. Eq a => a -> PortDescription a -> Bool)
-> (forall a. Ord a => PortDescription a -> a)
-> (forall a. Ord a => PortDescription a -> a)
-> (forall a. Num a => PortDescription a -> a)
-> (forall a. Num a => PortDescription a -> a)
-> Foldable PortDescription
forall a. Eq a => a -> PortDescription a -> Bool
forall a. Num a => PortDescription a -> a
forall a. Ord a => PortDescription a -> a
forall m. Monoid m => PortDescription m -> m
forall a. PortDescription a -> Bool
forall a. PortDescription a -> Int
forall a. PortDescription a -> [a]
forall a. (a -> a -> a) -> PortDescription a -> a
forall m a. Monoid m => (a -> m) -> PortDescription a -> m
forall b a. (b -> a -> b) -> b -> PortDescription a -> b
forall a b. (a -> b -> b) -> b -> PortDescription a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => PortDescription m -> m
fold :: forall m. Monoid m => PortDescription m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> PortDescription a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> PortDescription a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> PortDescription a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> PortDescription a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> PortDescription a -> b
foldr :: forall a b. (a -> b -> b) -> b -> PortDescription a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> PortDescription a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> PortDescription a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> PortDescription a -> b
foldl :: forall b a. (b -> a -> b) -> b -> PortDescription a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> PortDescription a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> PortDescription a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> PortDescription a -> a
foldr1 :: forall a. (a -> a -> a) -> PortDescription a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PortDescription a -> a
foldl1 :: forall a. (a -> a -> a) -> PortDescription a -> a
$ctoList :: forall a. PortDescription a -> [a]
toList :: forall a. PortDescription a -> [a]
$cnull :: forall a. PortDescription a -> Bool
null :: forall a. PortDescription a -> Bool
$clength :: forall a. PortDescription a -> Int
length :: forall a. PortDescription a -> Int
$celem :: forall a. Eq a => a -> PortDescription a -> Bool
elem :: forall a. Eq a => a -> PortDescription a -> Bool
$cmaximum :: forall a. Ord a => PortDescription a -> a
maximum :: forall a. Ord a => PortDescription a -> a
$cminimum :: forall a. Ord a => PortDescription a -> a
minimum :: forall a. Ord a => PortDescription a -> a
$csum :: forall a. Num a => PortDescription a -> a
sum :: forall a. Num a => PortDescription a -> a
$cproduct :: forall a. Num a => PortDescription a -> a
product :: forall a. Num a => PortDescription a -> a
Foldable, (forall a b. (a -> b) -> PortDescription a -> PortDescription b)
-> (forall a b. a -> PortDescription b -> PortDescription a)
-> Functor PortDescription
forall a b. a -> PortDescription b -> PortDescription a
forall a b. (a -> b) -> PortDescription a -> PortDescription b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PortDescription a -> PortDescription b
fmap :: forall a b. (a -> b) -> PortDescription a -> PortDescription b
$c<$ :: forall a b. a -> PortDescription b -> PortDescription a
<$ :: forall a b. a -> PortDescription b -> PortDescription a
Functor, Functor PortDescription
Foldable PortDescription
(Functor PortDescription, Foldable PortDescription) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> PortDescription a -> f (PortDescription b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    PortDescription (f a) -> f (PortDescription a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> PortDescription a -> m (PortDescription b))
-> (forall (m :: * -> *) a.
    Monad m =>
    PortDescription (m a) -> m (PortDescription a))
-> Traversable PortDescription
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
PortDescription (m a) -> m (PortDescription a)
forall (f :: * -> *) a.
Applicative f =>
PortDescription (f a) -> f (PortDescription a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PortDescription a -> m (PortDescription b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PortDescription a -> f (PortDescription b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PortDescription a -> f (PortDescription b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PortDescription a -> f (PortDescription b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PortDescription (f a) -> f (PortDescription a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
PortDescription (f a) -> f (PortDescription a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PortDescription a -> m (PortDescription b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PortDescription a -> m (PortDescription b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PortDescription (m a) -> m (PortDescription a)
sequence :: forall (m :: * -> *) a.
Monad m =>
PortDescription (m a) -> m (PortDescription a)
Traversable)

_Ref :: L.Prism' (PortDescription a) a
_Ref :: forall a (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f a) -> p (PortDescription a) (f (PortDescription a))
_Ref = (a -> PortDescription a)
-> (PortDescription a -> Maybe a)
-> Prism (PortDescription a) (PortDescription a) a a
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
L.prism' a -> PortDescription a
forall a. a -> PortDescription a
Ref (\case Ref a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a; PortDescription a
_ -> Maybe a
forall a. Maybe a
Nothing)

instance L.Plated (PortDescription a) where
  plate :: Traversal' (PortDescription a) (PortDescription a)
plate PortDescription a -> f (PortDescription a)
f = \case
    Tuple [PortDescription a]
ps -> [PortDescription a] -> PortDescription a
forall a. [PortDescription a] -> PortDescription a
Tuple ([PortDescription a] -> PortDescription a)
-> f [PortDescription a] -> f (PortDescription a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PortDescription a -> f (PortDescription a))
-> [PortDescription a] -> f [PortDescription a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse PortDescription a -> f (PortDescription a)
f [PortDescription a]
ps
    Vec SrcSpanAnnA
s [PortDescription a]
ps -> SrcSpanAnnA -> [PortDescription a] -> PortDescription a
forall a. SrcSpanAnnA -> [PortDescription a] -> PortDescription a
Vec SrcSpanAnnA
s ([PortDescription a] -> PortDescription a)
-> f [PortDescription a] -> f (PortDescription a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PortDescription a -> f (PortDescription a))
-> [PortDescription a] -> f [PortDescription a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse PortDescription a -> f (PortDescription a)
f [PortDescription a]
ps
    Lazy SrcSpanAnnA
s PortDescription a
p -> SrcSpanAnnA -> PortDescription a -> PortDescription a
forall a. SrcSpanAnnA -> PortDescription a -> PortDescription a
Lazy SrcSpanAnnA
s (PortDescription a -> PortDescription a)
-> f (PortDescription a) -> f (PortDescription a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PortDescription a -> f (PortDescription a)
f PortDescription a
p
    PortType LHsType GhcPs
t PortDescription a
p -> LHsType GhcPs -> PortDescription a -> PortDescription a
forall a. LHsType GhcPs -> PortDescription a -> PortDescription a
PortType LHsType GhcPs
t (PortDescription a -> PortDescription a)
-> f (PortDescription a) -> f (PortDescription a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PortDescription a -> f (PortDescription a)
f PortDescription a
p
    PortDescription a
p -> PortDescription a -> f (PortDescription a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PortDescription a
p

-- | A single circuit binding. These are generated from parsing statements.
-- @
-- bOut <- bCircuit -< bIn
-- @
data Binding exp l = Binding
    { forall exp l. Binding exp l -> exp
bCircuit :: exp
    , forall exp l. Binding exp l -> PortDescription l
bOut     :: PortDescription l
    , forall exp l. Binding exp l -> PortDescription l
bIn      :: PortDescription l
    }
    deriving ((forall a b. (a -> b) -> Binding exp a -> Binding exp b)
-> (forall a b. a -> Binding exp b -> Binding exp a)
-> Functor (Binding exp)
forall a b. a -> Binding exp b -> Binding exp a
forall a b. (a -> b) -> Binding exp a -> Binding exp b
forall exp a b. a -> Binding exp b -> Binding exp a
forall exp a b. (a -> b) -> Binding exp a -> Binding exp b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall exp a b. (a -> b) -> Binding exp a -> Binding exp b
fmap :: forall a b. (a -> b) -> Binding exp a -> Binding exp b
$c<$ :: forall exp a b. a -> Binding exp b -> Binding exp a
<$ :: forall a b. a -> Binding exp b -> Binding exp a
Functor)

data CircuitState dec exp nm = CircuitState
    { forall dec exp nm. CircuitState dec exp nm -> Bag ErrMsg
_cErrors        :: Bag ErrMsg
    , forall dec exp nm. CircuitState dec exp nm -> Int
_counter        :: Int
    -- ^ unique counter for generated variables
    , forall dec exp nm. CircuitState dec exp nm -> PortDescription nm
_circuitSlaves  :: PortDescription nm
    -- ^ the final statement in a circuit
    , forall dec exp nm. CircuitState dec exp nm -> [LSig GhcPs]
_circuitTypes   :: [LSig GhcPs]
    -- ^ type signatures in let bindings
    , forall dec exp nm. CircuitState dec exp nm -> [dec]
_circuitLets    :: [dec]
    -- ^ user defined let expression inside the circuit
    , forall dec exp nm. CircuitState dec exp nm -> [Binding exp nm]
_circuitBinds   :: [Binding exp nm]
    -- ^ @out <- circuit <- in@ statements
    , forall dec exp nm. CircuitState dec exp nm -> PortDescription nm
_circuitMasters :: PortDescription nm
    -- ^ ports bound at the first lambda of a circuit
    , forall dec exp nm.
CircuitState dec exp nm
-> UniqMap FastString (SrcSpanAnnA, LHsType GhcPs)
_portVarTypes :: UniqMap GHC.FastString (SrcSpanAnnA, LHsType GhcPs)
    -- ^ types of single variable ports
    , forall dec exp nm.
CircuitState dec exp nm -> [(LHsType GhcPs, PortDescription nm)]
_portTypes :: [(LHsType GhcPs, PortDescription nm)]
    -- ^ type of more 'complicated' things (very far from vigorous)
    , forall dec exp nm. CircuitState dec exp nm -> Int
_uniqueCounter :: Int
    -- ^ counter to keep internal variables "unique"
    , forall dec exp nm. CircuitState dec exp nm -> SrcSpanAnnA
_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 ((forall a b. (a -> b) -> CircuitM a -> CircuitM b)
-> (forall a b. a -> CircuitM b -> CircuitM a) -> Functor CircuitM
forall a b. a -> CircuitM b -> CircuitM a
forall a b. (a -> b) -> CircuitM a -> CircuitM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CircuitM a -> CircuitM b
fmap :: forall a b. (a -> b) -> CircuitM a -> CircuitM b
$c<$ :: forall a b. a -> CircuitM b -> CircuitM a
<$ :: forall a b. a -> CircuitM b -> CircuitM a
Functor, Functor CircuitM
Functor CircuitM =>
(forall a. a -> CircuitM a)
-> (forall a b. CircuitM (a -> b) -> CircuitM a -> CircuitM b)
-> (forall a b c.
    (a -> b -> c) -> CircuitM a -> CircuitM b -> CircuitM c)
-> (forall a b. CircuitM a -> CircuitM b -> CircuitM b)
-> (forall a b. CircuitM a -> CircuitM b -> CircuitM a)
-> Applicative CircuitM
forall a. a -> CircuitM a
forall a b. CircuitM a -> CircuitM b -> CircuitM a
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall a b. CircuitM (a -> b) -> CircuitM a -> CircuitM b
forall a b c.
(a -> b -> c) -> CircuitM a -> CircuitM b -> CircuitM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> CircuitM a
pure :: forall a. a -> CircuitM a
$c<*> :: forall a b. CircuitM (a -> b) -> CircuitM a -> CircuitM b
<*> :: forall a b. CircuitM (a -> b) -> CircuitM a -> CircuitM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> CircuitM a -> CircuitM b -> CircuitM c
liftA2 :: forall a b c.
(a -> b -> c) -> CircuitM a -> CircuitM b -> CircuitM c
$c*> :: forall a b. CircuitM a -> CircuitM b -> CircuitM b
*> :: forall a b. CircuitM a -> CircuitM b -> CircuitM b
$c<* :: forall a b. CircuitM a -> CircuitM b -> CircuitM a
<* :: forall a b. CircuitM a -> CircuitM b -> CircuitM a
Applicative, Applicative CircuitM
Applicative CircuitM =>
(forall a b. CircuitM a -> (a -> CircuitM b) -> CircuitM b)
-> (forall a b. CircuitM a -> CircuitM b -> CircuitM b)
-> (forall a. a -> CircuitM a)
-> Monad CircuitM
forall a. a -> CircuitM a
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall a b. CircuitM a -> (a -> CircuitM b) -> CircuitM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. CircuitM a -> (a -> CircuitM b) -> CircuitM b
>>= :: forall a b. CircuitM a -> (a -> CircuitM b) -> CircuitM b
$c>> :: forall a b. CircuitM a -> CircuitM b -> CircuitM b
>> :: forall a b. CircuitM a -> CircuitM b -> CircuitM b
$creturn :: forall a. a -> CircuitM a
return :: forall a. a -> CircuitM a
Monad, Monad CircuitM
Monad CircuitM =>
(forall a. IO a -> CircuitM a) -> MonadIO CircuitM
forall a. IO a -> CircuitM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> CircuitM a
liftIO :: forall a. IO a -> CircuitM a
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 DynFlags
getDynFlags = (StateT
  (CircuitState (LHsBind GhcPs) (LHsExpr GhcPs) PortName)
  Hsc
  DynFlags
-> CircuitM DynFlags
StateT
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  Hsc
  DynFlags
-> CircuitM DynFlags
forall a.
StateT
  (CircuitState (LHsBind GhcPs) (LHsExpr GhcPs) PortName) Hsc a
-> CircuitM a
CircuitM (StateT
   (CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName)
   Hsc
   DynFlags
 -> CircuitM DynFlags)
-> (Hsc DynFlags
    -> StateT
         (CircuitState
            (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
            (GenLocated SrcSpanAnnA (HsExpr GhcPs))
            PortName)
         Hsc
         DynFlags)
-> Hsc DynFlags
-> CircuitM DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hsc DynFlags
-> StateT
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
     Hsc
     DynFlags
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags

runCircuitM :: CircuitM a -> GHC.Hsc a
runCircuitM :: forall a. CircuitM a -> Hsc a
runCircuitM (CircuitM StateT
  (CircuitState (LHsBind GhcPs) (LHsExpr GhcPs) PortName) Hsc a
m) = do
  let emptyCircuitState :: CircuitState dec exp nm
emptyCircuitState = CircuitState
        { _cErrors :: Bag ErrMsg
_cErrors = Bag ErrMsg
forall a. Bag a
emptyBag
        , _counter :: Int
_counter = Int
0
        , _circuitSlaves :: PortDescription nm
_circuitSlaves = [PortDescription nm] -> PortDescription nm
forall a. [PortDescription a] -> PortDescription a
Tuple []
        , _circuitTypes :: [LSig GhcPs]
_circuitTypes = []
        , _circuitLets :: [dec]
_circuitLets = []
        , _circuitBinds :: [Binding exp nm]
_circuitBinds = []
        , _circuitMasters :: PortDescription nm
_circuitMasters = [PortDescription nm] -> PortDescription nm
forall a. [PortDescription a] -> PortDescription a
Tuple []
        , _portVarTypes :: UniqMap FastString (SrcSpanAnnA, LHsType GhcPs)
_portVarTypes = UniqMap FastString (SrcSpanAnnA, LHsType GhcPs)
UniqMap
  FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
forall k a. UniqMap k a
emptyUniqMap
        , _portTypes :: [(LHsType GhcPs, PortDescription nm)]
_portTypes = []
        , _uniqueCounter :: Int
_uniqueCounter = Int
1
        , _circuitLoc :: SrcSpanAnnA
_circuitLoc = SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA
        }
  (a
a, CircuitState
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
  (GenLocated SrcSpanAnnA (HsExpr GhcPs))
  PortName
s) <- StateT
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  Hsc
  a
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Hsc
     (a,
      CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT
  (CircuitState (LHsBind GhcPs) (LHsExpr GhcPs) PortName) Hsc a
StateT
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  Hsc
  a
m CircuitState
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
  (GenLocated SrcSpanAnnA (HsExpr GhcPs))
  PortName
forall {dec} {exp} {nm}. CircuitState dec exp nm
emptyCircuitState
  let errs :: Bag ErrMsg
errs = CircuitState
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
  (GenLocated SrcSpanAnnA (HsExpr GhcPs))
  PortName
-> Bag ErrMsg
forall dec exp nm. CircuitState dec exp nm -> Bag ErrMsg
_cErrors CircuitState
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
  (GenLocated SrcSpanAnnA (HsExpr GhcPs))
  PortName
s
#if __GLASGOW_HASKELL__ < 904
  unless (isEmptyBag errs) $ liftIO . throwIO $ GHC.mkSrcErr errs
#else
  Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag ErrMsg -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag ErrMsg
errs) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ())
-> (SourceError -> IO ()) -> SourceError -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SourceError -> Hsc ()) -> SourceError -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> SourceError
GHC.mkSrcErr (Messages GhcMessage -> SourceError)
-> Messages GhcMessage -> SourceError
forall a b. (a -> b) -> a -> b
$ Bag ErrMsg -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
Err.mkMessages Bag ErrMsg
errs
#endif
  a -> Hsc a
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
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 :: MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage = MessageClass -> SrcSpan -> SDoc -> SDoc
Err.mkLocMessage
#endif

errM :: SrcSpan -> String -> CircuitM ()
errM :: SrcSpan -> [Char] -> CircuitM ()
errM SrcSpan
loc [Char]
msg = do
  DynFlags
dflags <- CircuitM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  let errMsg :: SDoc
errMsg = MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
sevFatal SrcSpan
loc ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
Outputable.text [Char]
msg)
  (Bag ErrMsg -> Identity (Bag ErrMsg))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(Bag ErrMsg -> f (Bag ErrMsg))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
cErrors ((Bag ErrMsg -> Identity (Bag ErrMsg))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> (Bag ErrMsg -> Bag ErrMsg) -> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ErrMsg -> Bag ErrMsg -> Bag ErrMsg
forall a. a -> Bag a -> Bag a
consBag (DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkErrMsg DynFlags
dflags SrcSpan
loc PrintUnqualified
Outputable.alwaysQualify SDoc
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 :: GenLocated SrcSpanAnnN RdrName
-> HsConPatDetails GhcPs -> Pat GhcPs
conPatIn GenLocated SrcSpanAnnN RdrName
loc HsConPatDetails GhcPs
con = XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConPatDetails GhcPs
-> Pat GhcPs
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat XConPat GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt XRec GhcPs (ConLikeP GhcPs)
GenLocated SrcSpanAnnN RdrName
loc HsConPatDetails GhcPs
con
#else
conPatIn loc con = ConPatIn loc con
#endif

#if __GLASGOW_HASKELL__ >= 902
noEpAnn :: GenLocated SrcSpan e -> GenLocated (SrcAnn ann) e
noEpAnn :: forall e ann. GenLocated SrcSpan e -> GenLocated (SrcAnn ann) e
noEpAnn (L SrcSpan
l e
e) = SrcAnn ann -> e -> GenLocated (SrcAnn ann) e
forall l e. l -> e -> GenLocated l e
L (EpAnn ann -> SrcSpan -> SrcAnn ann
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn ann
forall ann. EpAnn ann
EpAnnNotUsed SrcSpan
l) e
e

noLoc :: e -> GenLocated (SrcAnn ann) e
noLoc :: forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc = GenLocated SrcSpan e -> GenLocated (SrcAnn ann) e
forall e ann. GenLocated SrcSpan e -> GenLocated (SrcAnn ann) e
noEpAnn (GenLocated SrcSpan e -> GenLocated (SrcAnn ann) e)
-> (e -> GenLocated SrcSpan e) -> e -> GenLocated (SrcAnn ann) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> GenLocated SrcSpan e
forall e. e -> Located e
GHC.noLoc
#else
noLoc :: e -> Located e
noLoc = GHC.noLoc
#endif

tupP :: p ~ GhcPs => [LPat p] -> LPat p
tupP :: forall p. (p ~ GhcPs) => [LPat p] -> LPat p
tupP [LPat p
pat] = LPat p
pat
tupP [LPat p]
pats = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> Pat GhcPs
forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat XTuplePat GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt [LPat p]
[LPat GhcPs]
pats Boxity
GHC.Boxed

vecP :: (?nms :: ExternalNames) => SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs
vecP :: (?nms::ExternalNames) => SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs
vecP SrcSpanAnnA
srcLoc = \case
  [] -> [LPat GhcPs] -> LPat GhcPs
go []
#if __GLASGOW_HASKELL__ < 904
  as -> L srcLoc $ ParPat noExt $ go as
  where
#else
  [LPat GhcPs]
as -> SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
srcLoc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XParPat GhcPs
-> LHsToken "(" GhcPs
-> LPat GhcPs
-> LHsToken ")" GhcPs
-> Pat GhcPs
forall p.
XParPat p -> LHsToken "(" p -> LPat p -> LHsToken ")" p -> Pat p
ParPat XParPat GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
noExt LHsToken "(" GhcPs
GenLocated TokenLocation (HsToken "(")
pL ([LPat GhcPs] -> LPat GhcPs
go [LPat GhcPs]
as) LHsToken ")" GhcPs
GenLocated TokenLocation (HsToken ")")
pR
  where
  pL :: GenLocated TokenLocation (HsToken "(")
pL = TokenLocation
-> HsToken "(" -> GenLocated TokenLocation (HsToken "(")
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> TokenLocation
GHC.mkTokenLocation (SrcSpan -> TokenLocation) -> SrcSpan -> TokenLocation
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
srcLoc) HsToken "("
forall (tok :: Symbol). HsToken tok
HsTok
  pR :: GenLocated TokenLocation (HsToken ")")
pR = TokenLocation
-> HsToken ")" -> GenLocated TokenLocation (HsToken ")")
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> TokenLocation
GHC.mkTokenLocation (SrcSpan -> TokenLocation) -> SrcSpan -> TokenLocation
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
srcLoc) HsToken ")"
forall (tok :: Symbol). HsToken tok
HsTok
#endif
  go :: [LPat GhcPs] -> LPat GhcPs
  go :: [LPat GhcPs] -> LPat GhcPs
go (p :: LPat GhcPs
p@(L SrcSpanAnnA
l0 Pat GhcPs
_):[LPat GhcPs]
pats) =
    let
#if __GLASGOW_HASKELL__ >= 902
      l1 :: SrcSpanAnnN
l1 = SrcSpanAnnA
l0 SrcSpanAnnA -> SrcSpanAnnN -> SrcSpanAnnN
forall a b. a -> b -> b
`seq` SrcSpanAnnN
forall ann. SrcAnn ann
noSrcSpanA
#else
      l1 = l0
#endif
    in
      SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
srcLoc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName
-> HsConPatDetails GhcPs -> Pat GhcPs
conPatIn (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l1 (ExternalNames -> RdrName
consPat ?nms::ExternalNames
ExternalNames
?nms)) (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p ([LPat GhcPs] -> LPat GhcPs
go [LPat GhcPs]
pats))
  go [] = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
srcLoc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcPs
NoExtField
noExtField

varP :: SrcSpanAnnA -> String -> LPat GhcPs
varP :: SrcSpanAnnA -> [Char] -> LPat GhcPs
varP SrcSpanAnnA
loc [Char]
nm = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> LIdP GhcPs -> Pat GhcPs
forall p. XVarPat p -> LIdP p -> Pat p
VarPat XVarPat GhcPs
NoExtField
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (RdrName -> GenLocated SrcSpanAnnN RdrName)
-> RdrName -> GenLocated SrcSpanAnnN RdrName
forall a b. (a -> b) -> a -> b
$ [Char] -> RdrName
var [Char]
nm)

tildeP :: SrcSpanAnnA -> LPat GhcPs -> LPat GhcPs
tildeP :: SrcSpanAnnA -> LPat GhcPs -> LPat GhcPs
tildeP SrcSpanAnnA
loc LPat GhcPs
lpat = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XLazyPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat XLazyPat GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt LPat GhcPs
lpat)

hsBoxedTuple :: GHC.HsTupleSort
#if __GLASGOW_HASKELL__ >= 902
hsBoxedTuple :: HsTupleSort
hsBoxedTuple = HsTupleSort
HsBoxedOrConstraintTuple
#else
hsBoxedTuple = HsBoxedTuple
#endif

tupT :: [LHsType GhcPs] -> LHsType GhcPs
tupT :: [LHsType GhcPs] -> LHsType GhcPs
tupT [LHsType GhcPs
ty] = LHsType GhcPs
ty
tupT [LHsType GhcPs]
tys = HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
EpAnn AnnParen
forall ann. EpAnn ann
noExt HsTupleSort
hsBoxedTuple [LHsType GhcPs]
tys

vecT :: SrcSpanAnnA -> [LHsType GhcPs] -> LHsType GhcPs
vecT :: SrcSpanAnnA -> [LHsType GhcPs] -> LHsType GhcPs
vecT SrcSpanAnnA
s [] = SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
s (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
EpAnn AnnParen
forall ann. EpAnn ann
noExt (SrcSpanAnnA -> RdrName -> LHsType GhcPs
conT SrcSpanAnnA
s (Name -> RdrName
thName ''Vec) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` SrcSpanAnnA -> Int -> LHsType GhcPs
tyNum SrcSpanAnnA
s Int
0 LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` (SrcSpanAnnA -> [Char] -> LHsType GhcPs
varT SrcSpanAnnA
s (SrcSpanAnnA -> ShowS
genLocName SrcSpanAnnA
s [Char]
"vec")))
vecT SrcSpanAnnA
s tys :: [LHsType GhcPs]
tys@(LHsType GhcPs
ty:[LHsType GhcPs]
_) = SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
s (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
EpAnn AnnParen
forall ann. EpAnn ann
noExt (SrcSpanAnnA -> RdrName -> LHsType GhcPs
conT SrcSpanAnnA
s (Name -> RdrName
thName ''Vec) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` SrcSpanAnnA -> Int -> LHsType GhcPs
tyNum SrcSpanAnnA
s ([GenLocated SrcSpanAnnA (HsType GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` LHsType GhcPs
ty)

tyNum :: SrcSpanAnnA -> Int -> LHsType GhcPs
tyNum :: SrcSpanAnnA -> Int -> LHsType GhcPs
tyNum SrcSpanAnnA
s Int
i = SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
s (XTyLit GhcPs -> HsTyLit GhcPs -> HsType GhcPs
forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit XTyLit GhcPs
NoExtField
noExtField (XNumTy GhcPs -> Integer -> HsTyLit GhcPs
forall pass. XNumTy pass -> Integer -> HsTyLit pass
HsNumTy XNumTy GhcPs
SourceText
GHC.NoSourceText (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)))

appTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
appTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
appTy LHsType GhcPs
a LHsType GhcPs
b = HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcPs
NoExtField
noExtField LHsType GhcPs
a (PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
GHC.appPrec LHsType GhcPs
b))

appE :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE LHsExpr GhcPs
fun LHsExpr GhcPs
arg = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
noExt LHsExpr GhcPs
fun (PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
GHC.appPrec LHsExpr GhcPs
arg)

varE :: SrcSpanAnnA -> GHC.RdrName -> LHsExpr GhcPs
varE :: SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc RdrName
rdr = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XVar GhcPs -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcPs
NoExtField
noExtField (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc RdrName
rdr))

parenE :: LHsExpr GhcPs -> LHsExpr GhcPs
#if __GLASGOW_HASKELL__ < 904
parenE e@(L l _) = L l (HsPar noExt e)
#else
parenE :: LHsExpr GhcPs -> LHsExpr GhcPs
parenE e :: LHsExpr GhcPs
e@(L SrcSpanAnnA
l HsExpr GhcPs
_) = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XPar GhcPs
-> LHsToken "(" GhcPs
-> LHsExpr GhcPs
-> LHsToken ")" GhcPs
-> HsExpr GhcPs
forall p.
XPar p -> LHsToken "(" p -> LHsExpr p -> LHsToken ")" p -> HsExpr p
HsPar XPar GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
noExt LHsToken "(" GhcPs
GenLocated TokenLocation (HsToken "(")
pL LHsExpr GhcPs
e LHsToken ")" GhcPs
GenLocated TokenLocation (HsToken ")")
pR)
  where
  pL :: GenLocated TokenLocation (HsToken "(")
pL = TokenLocation
-> HsToken "(" -> GenLocated TokenLocation (HsToken "(")
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> TokenLocation
GHC.mkTokenLocation (SrcSpan -> TokenLocation) -> SrcSpan -> TokenLocation
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) HsToken "("
forall (tok :: Symbol). HsToken tok
HsTok
  pR :: GenLocated TokenLocation (HsToken ")")
pR = TokenLocation
-> HsToken ")" -> GenLocated TokenLocation (HsToken ")")
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> TokenLocation
GHC.mkTokenLocation (SrcSpan -> TokenLocation) -> SrcSpan -> TokenLocation
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) HsToken ")"
forall (tok :: Symbol). HsToken tok
HsTok
#endif

var :: String -> GHC.RdrName
var :: [Char] -> RdrName
var = OccName -> RdrName
GHC.Unqual (OccName -> RdrName) -> ([Char] -> OccName) -> [Char] -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> OccName
OccName.mkVarOcc

tyVar :: String -> GHC.RdrName
tyVar :: [Char] -> RdrName
tyVar = OccName -> RdrName
GHC.Unqual (OccName -> RdrName) -> ([Char] -> OccName) -> [Char] -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> OccName
OccName.mkTyVarOcc

tyCon :: String -> GHC.RdrName
tyCon :: [Char] -> RdrName
tyCon = OccName -> RdrName
GHC.Unqual (OccName -> RdrName) -> ([Char] -> OccName) -> [Char] -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> OccName
OccName.mkTcOcc

vecE :: SrcSpanAnnA -> [LHsExpr GhcPs] -> LHsExpr GhcPs
vecE :: SrcSpanAnnA -> [LHsExpr GhcPs] -> LHsExpr GhcPs
vecE SrcSpanAnnA
srcLoc = \case
  [] -> SrcSpanAnnA
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
go SrcSpanAnnA
srcLoc []
  [LHsExpr GhcPs]
as -> LHsExpr GhcPs -> LHsExpr GhcPs
parenE (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
go SrcSpanAnnA
srcLoc [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
as
  where
  go :: SrcSpanAnnA
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
go SrcSpanAnnA
loc (e :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
e@(L SrcSpanAnnA
l HsExpr GhcPs
_):[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
es) = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e (SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
l (Name -> RdrName
thName '(:>))) (SrcSpanAnnA
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
go SrcSpanAnnA
loc [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
es)
  go SrcSpanAnnA
loc [] = SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc (Name -> RdrName
thName 'Nil)

tupE :: p ~ GhcPs => SrcSpanAnnA -> [LHsExpr p] -> LHsExpr p
tupE :: forall p. (p ~ GhcPs) => SrcSpanAnnA -> [LHsExpr p] -> LHsExpr p
tupE SrcSpanAnnA
_ [LHsExpr p
ele] = LHsExpr p
ele
tupE SrcSpanAnnA
loc [LHsExpr p]
elems = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt [HsTupArg GhcPs]
tupArgs Boxity
GHC.Boxed
  where
#if __GLASGOW_HASKELL__ >= 902
    tupArgs :: [HsTupArg GhcPs]
tupArgs = (LHsExpr GhcPs -> HsTupArg GhcPs)
-> [LHsExpr GhcPs] -> [HsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt) [LHsExpr p]
[LHsExpr GhcPs]
elems
#else
    tupArgs = map (\arg@(L l _) -> L l (Present noExt arg)) elems
#endif

unL :: Located a -> a
unL :: forall a. Located a -> a
unL (L SrcSpan
_ a
a) = a
a

-- | Get a ghc name from a TH name that's known to be unique.
thName :: TH.Name -> GHC.RdrName
thName :: Name -> RdrName
thName Name
nm =
  case Name -> [RdrName]
Convert.thRdrNameGuesses Name
nm of
    [RdrName
name] -> RdrName
name
    [RdrName]
_      -> [Char] -> RdrName
forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: SrcSpanAnnA -> ShowS
genLocName (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA -> GHC.RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_) [Char]
prefix =
#elif __GLASGOW_HASKELL__ >= 900
genLocName (GHC.RealSrcSpan rss _) prefix =
#else
genLocName (GHC.RealSrcSpan rss) prefix =
#endif
  [Char]
prefix [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"_" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    ((RealSrcSpan -> Int) -> [Char]) -> [RealSrcSpan -> Int] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\RealSrcSpan -> Int
f -> Int -> [Char]
forall a. Show a => a -> [Char]
show (RealSrcSpan -> Int
f RealSrcSpan
rss)) [RealSrcSpan -> Int
srcSpanStartLine, RealSrcSpan -> Int
srcSpanEndLine, RealSrcSpan -> Int
srcSpanStartCol, RealSrcSpan -> Int
srcSpanEndCol]
genLocName SrcSpanAnnA
_ [Char]
prefix = [Char]
prefix

-- | Extract a simple lambda into inputs and body.
simpleLambda :: HsExpr GhcPs -> Maybe ([LPat GhcPs], LHsExpr GhcPs)
simpleLambda :: HsExpr GhcPs -> Maybe ([LPat GhcPs], LHsExpr GhcPs)
simpleLambda HsExpr GhcPs
expr = do
#if __GLASGOW_HASKELL__ < 906
  HsLam _ (MG _x alts _origin) <- Just expr
#else
  HsLam XLam GhcPs
_ (MG XMG GhcPs (LHsExpr GhcPs)
_x XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
alts) <- HsExpr GhcPs -> Maybe (HsExpr GhcPs)
forall a. a -> Maybe a
Just HsExpr GhcPs
expr
#endif
  L SrcSpanAnnL
_ [L SrcSpanAnnA
_ (Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_matchX HsMatchContext GhcPs
_matchContext [LPat GhcPs]
matchPats GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchGr)] <- GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe
     (GenLocated
        SrcSpanAnnL
        [GenLocated
           SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
forall a. a -> Maybe a
Just XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts
  GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_grX [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
grHss HsLocalBindsLR GhcPs GhcPs
_grLocalBinds <- GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
Just GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchGr
  [L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)] <- [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe
     [GenLocated
        (SrcAnn NoEpAnns)
        (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. a -> Maybe a
Just [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
[GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
grHss
  ([GenLocated SrcSpanAnnA (Pat GhcPs)],
 GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe
     ([GenLocated SrcSpanAnnA (Pat GhcPs)],
      GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Maybe a
Just ([LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
matchPats, GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 :: forall p.
(p ~ GhcPs) =>
SrcSpanAnnA -> [LSig p] -> [LHsBind p] -> LHsExpr p -> LHsExpr p
letE SrcSpanAnnA
loc [LSig p]
sigs [LHsBind p]
binds LHsExpr p
expr =
#if __GLASGOW_HASKELL__ < 904
    L loc (HsLet noExt localBinds expr)
#else
    SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XLet GhcPs
-> LHsToken "let" GhcPs
-> HsLocalBindsLR GhcPs GhcPs
-> LHsToken "in" GhcPs
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet XLet GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
noExt LHsToken "let" GhcPs
GenLocated TokenLocation (HsToken "let")
tkLet HsLocalBindsLR GhcPs GhcPs
localBinds LHsToken "in" GhcPs
GenLocated TokenLocation (HsToken "in")
tkIn LHsExpr p
LHsExpr GhcPs
expr)
#endif
  where
#if __GLASGOW_HASKELL__ >= 902
    localBinds :: HsLocalBinds GhcPs
    localBinds :: HsLocalBindsLR GhcPs GhcPs
localBinds = XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
EpAnn AnnList
forall ann. EpAnn ann
noExt HsValBindsLR GhcPs GhcPs
valBinds
#else
    localBinds :: LHsLocalBindsLR GhcPs GhcPs
    localBinds = L loc $ HsValBinds noExt valBinds
#endif

#if __GLASGOW_HASKELL__ >= 904
    tkLet :: GenLocated TokenLocation (HsToken "let")
tkLet = TokenLocation
-> HsToken "let" -> GenLocated TokenLocation (HsToken "let")
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> TokenLocation
GHC.mkTokenLocation (SrcSpan -> TokenLocation) -> SrcSpan -> TokenLocation
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsToken "let"
forall (tok :: Symbol). HsToken tok
HsTok
    tkIn :: GenLocated TokenLocation (HsToken "in")
tkIn = TokenLocation
-> HsToken "in" -> GenLocated TokenLocation (HsToken "in")
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> TokenLocation
GHC.mkTokenLocation (SrcSpan -> TokenLocation) -> SrcSpan -> TokenLocation
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) HsToken "in"
forall (tok :: Symbol). HsToken tok
HsTok
#endif

    valBinds :: HsValBindsLR GhcPs GhcPs
    valBinds :: HsValBindsLR GhcPs GhcPs
valBinds = XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
AnnSortKey
noAnnSortKey LHsBindsLR GhcPs GhcPs
hsBinds [LSig p]
[LSig GhcPs]
sigs

    hsBinds :: LHsBindsLR GhcPs GhcPs
    hsBinds :: LHsBindsLR GhcPs GhcPs
hsBinds = [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [LHsBind p]
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds

-- | Simple construction of a lambda expression
lamE :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE [LPat GhcPs]
pats LHsExpr GhcPs
expr = HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLam GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcPs
NoExtField
noExtField MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mg
  where
    mg :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
#if __GLASGOW_HASKELL__ < 906
    mg = MG noExtField matches GHC.Generated
#elif __GLASGOW_HASKELL__ < 908
    mg :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mg = XMG GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> XRec
     GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XMG p body -> XRec p [LMatch p body] -> MatchGroup p body
MG XMG GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
Origin
GHC.Generated XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches
#else
    mg = MG (GHC.Generated GHC.DoPmc) matches
#endif

    matches :: GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
    matches :: GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches = [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc ([GenLocated
    SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
 -> GenLocated
      SrcSpanAnnL
      [GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))])
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ [GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
singleMatch]

    singleMatch :: GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
    singleMatch :: GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
singleMatch = Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsMatchContext GhcPs
-> [LPat GhcPs]
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt HsMatchContext GhcPs
forall p. HsMatchContext p
LambdaExpr [LPat GhcPs]
pats GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grHss

    grHss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    grHss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grHss = XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> HsLocalBindsLR GhcPs GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnnComments
emptyComments [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grHs] (HsLocalBindsLR GhcPs GhcPs
 -> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsLocalBindsLR GhcPs GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ >= 902
      (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExtField
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 :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grHs =  SrcAnn NoEpAnns
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     (SrcAnn NoEpAnns)
     (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
forall ann. SrcAnn ann
noSrcSpanA (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      (SrcAnn NoEpAnns)
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     (SrcAnn NoEpAnns)
     (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [GuardLStmt GhcPs]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn GrhsAnn
forall ann. EpAnn ann
noExt [] LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
#endif

-- | Kinda hacky function to get a string name for named ports.
fromRdrName :: GHC.RdrName -> GHC.FastString
fromRdrName :: RdrName -> FastString
fromRdrName = \case
  GHC.Unqual OccName
occName -> [Char] -> FastString
mkFastString (OccName -> [Char]
OccName.occNameString OccName
occName)
  GHC.Orig Module
_ OccName
occName -> [Char] -> FastString
mkFastString (OccName -> [Char]
OccName.occNameString OccName
occName)
  RdrName
nm -> [Char] -> FastString
mkFastString (RdrName -> [Char]
forall a. Data a => a -> [Char]
deepShowD RdrName
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 :: forall p. (p ~ GhcPs) => LHsExpr p -> CircuitM ()
parseCircuit = \case
  -- strip out parenthesis
  L SrcSpanAnnA
_ (HsParP LHsExpr GhcPs
lexp) -> LHsExpr GhcPs -> CircuitM ()
forall p. (p ~ GhcPs) => LHsExpr p -> CircuitM ()
parseCircuit LHsExpr GhcPs
lexp

  -- a lambda to match the slave ports
  L SrcSpanAnnA
_ (HsExpr GhcPs -> Maybe ([LPat GhcPs], LHsExpr GhcPs)
simpleLambda -> Just ([LPat GhcPs
matchPats], LHsExpr GhcPs
body)) -> do
    (PortDescription PortName -> Identity (PortDescription PortName))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitSlaves ((PortDescription PortName -> Identity (PortDescription PortName))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> PortDescription PortName -> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= LPat GhcPs -> PortDescription PortName
forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave LPat GhcPs
matchPats
    LHsExpr GhcPs -> CircuitM ()
circuitBody LHsExpr GhcPs
body

  -- a version without a lambda (i.e. no slaves)
  LHsExpr p
e -> LHsExpr GhcPs -> CircuitM ()
circuitBody LHsExpr p
LHsExpr GhcPs
e

-- | The main part of a circuit expression. Either a do block or simple rearranging case.
circuitBody :: LHsExpr GhcPs -> CircuitM ()
circuitBody :: LHsExpr GhcPs -> CircuitM ()
circuitBody = \case
  -- strip out parenthesis
  L SrcSpanAnnA
_ (HsParP LHsExpr GhcPs
lexp) -> LHsExpr GhcPs -> CircuitM ()
circuitBody LHsExpr GhcPs
lexp

  L SrcSpanAnnA
loc (HsDo XDo GhcPs
_x HsDoFlavour
_stmtContext (L SrcSpanAnnL
_ ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe
     ([GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))],
      GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts, L SrcSpanAnnA
finLoc StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
finStmt)))) -> do
    (SrcSpanAnnA -> Identity SrcSpanAnnA)
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(SrcSpanAnnA -> f SrcSpanAnnA)
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitLoc ((SrcSpanAnnA -> Identity SrcSpanAnnA)
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> SrcSpanAnnA -> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SrcSpanAnnA
loc
    (GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> CircuitM ())
-> [GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> CircuitM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
-> CircuitM ()
GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> CircuitM ()
handleStmtM [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts

    case StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
finStmt of
      BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_bodyX GenLocated SrcSpanAnnA (HsExpr GhcPs)
bod SyntaxExpr GhcPs
_idr SyntaxExpr GhcPs
_idr' ->
        case GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ (GHC.Unqual OccName
occ)))) (L SrcSpanAnnA
_ HsExpr GhcPs
op) LHsExpr GhcPs
port)
            | HsExpr GhcPs -> Bool
forall p. (p ~ GhcPs) => HsExpr p -> Bool
isFletching HsExpr GhcPs
op
            , OccName -> [Char]
OccName.occNameString OccName
occ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"idC" -> do
                (PortDescription PortName -> Identity (PortDescription PortName))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitMasters ((PortDescription PortName -> Identity (PortDescription PortName))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> PortDescription PortName -> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= LHsExpr GhcPs -> PortDescription PortName
bindMaster LHsExpr GhcPs
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
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
_ -> do
            let ref :: PortDescription PortName
ref = PortName -> PortDescription PortName
forall a. a -> PortDescription a
Ref (SrcSpanAnnA -> FastString -> PortName
PortName SrcSpanAnnA
finLoc FastString
"final:stmt")
            Maybe (PortDescription PortName)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> CircuitM ()
bodyBinding (PortDescription PortName -> Maybe (PortDescription PortName)
forall a. a -> Maybe a
Just PortDescription PortName
ref) (GenLocated SrcSpanAnnA (HsExpr GhcPs)
bod)
            (PortDescription PortName -> Identity (PortDescription PortName))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitMasters ((PortDescription PortName -> Identity (PortDescription PortName))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> PortDescription PortName -> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= PortDescription PortName
ref

      StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
stmt -> SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
finLoc) ([Char]
"Unhandled final stmt " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Constr -> [Char]
forall a. Show a => a -> [Char]
show (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Constr
forall a. Data a => a -> Constr
Data.toConstr StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
stmt))

  -- the simple case without do notation
  L SrcSpanAnnA
loc HsExpr GhcPs
master -> do
    (SrcSpanAnnA -> Identity SrcSpanAnnA)
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(SrcSpanAnnA -> f SrcSpanAnnA)
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitLoc ((SrcSpanAnnA -> Identity SrcSpanAnnA)
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> SrcSpanAnnA -> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SrcSpanAnnA
loc
    (PortDescription PortName -> Identity (PortDescription PortName))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitMasters ((PortDescription PortName -> Identity (PortDescription PortName))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> PortDescription PortName -> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= LHsExpr GhcPs -> PortDescription PortName
bindMaster (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsExpr GhcPs
master)

-- | Handle a single statement.
handleStmtM
  :: GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
  -> CircuitM ()
handleStmtM :: GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
-> CircuitM ()
handleStmtM (L SrcSpanAnnA
loc StmtLR GhcPs GhcPs (LHsExpr GhcPs)
stmt) = case StmtLR GhcPs GhcPs (LHsExpr GhcPs)
stmt of
#if __GLASGOW_HASKELL__ >= 902
  LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
_xlet HsLocalBindsLR GhcPs GhcPs
letBind ->
#else
  LetStmt _xlet (L _ letBind) ->
#endif
    -- a regular let bindings
    case HsLocalBindsLR GhcPs GhcPs
letBind of
      HsValBinds XHsValBinds GhcPs GhcPs
_ (ValBinds XValBinds GhcPs GhcPs
_ LHsBindsLR GhcPs GhcPs
valBinds [LSig GhcPs]
sigs) -> do
        ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
 -> Identity [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm dec (f :: * -> *).
Functor f =>
([dec] -> f [dec])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitLets (([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
  -> Identity [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)])
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)] -> CircuitM ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall a. Bag a -> [a]
bagToList LHsBindsLR GhcPs GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
valBinds
        ([LSig GhcPs] -> Identity [LSig GhcPs])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
([GenLocated SrcSpanAnnA (Sig GhcPs)]
 -> Identity [GenLocated SrcSpanAnnA (Sig GhcPs)])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
([LSig GhcPs] -> f [LSig GhcPs])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitTypes (([GenLocated SrcSpanAnnA (Sig GhcPs)]
  -> Identity [GenLocated SrcSpanAnnA (Sig GhcPs)])
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> [GenLocated SrcSpanAnnA (Sig GhcPs)] -> CircuitM ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs
      HsLocalBindsLR GhcPs GhcPs
_ -> SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) ([Char]
"Unhandled let statement" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Constr -> [Char]
forall a. Show a => a -> [Char]
show (HsLocalBindsLR GhcPs GhcPs -> Constr
forall a. Data a => a -> Constr
Data.toConstr HsLocalBindsLR GhcPs GhcPs
letBind))
  BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_xbody LHsExpr GhcPs
body SyntaxExpr GhcPs
_idr SyntaxExpr GhcPs
_idr' ->
    Maybe (PortDescription PortName)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> CircuitM ()
bodyBinding Maybe (PortDescription PortName)
forall a. Maybe a
Nothing LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
#if __GLASGOW_HASKELL__ >= 900
  BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LPat GhcPs
bind LHsExpr GhcPs
body ->
#else
  BindStmt _xbody bind body _idr _idr' ->
#endif
    Maybe (PortDescription PortName)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> CircuitM ()
bodyBinding (PortDescription PortName -> Maybe (PortDescription PortName)
forall a. a -> Maybe a
Just (PortDescription PortName -> Maybe (PortDescription PortName))
-> PortDescription PortName -> Maybe (PortDescription PortName)
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> PortDescription PortName
forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave LPat GhcPs
bind) LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
  StmtLR GhcPs GhcPs (LHsExpr GhcPs)
_ -> SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [Char]
"Unhandled stmt"

-- | Turn patterns to the left of a @<-@ into a PortDescription.
bindSlave :: p ~ GhcPs => LPat p -> PortDescription PortName
bindSlave :: forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave (L SrcSpanAnnA
loc Pat GhcPs
expr) = case Pat GhcPs
expr of
  VarPat XVarPat GhcPs
_ (L SrcSpanAnnN
_ RdrName
rdrName) -> PortName -> PortDescription PortName
forall a. a -> PortDescription a
Ref (SrcSpanAnnA -> FastString -> PortName
PortName SrcSpanAnnA
loc (RdrName -> FastString
fromRdrName RdrName
rdrName))
  TuplePat XTuplePat GhcPs
_ [LPat GhcPs]
lpat Boxity
_ -> [PortDescription PortName] -> PortDescription PortName
forall a. [PortDescription a] -> PortDescription a
Tuple ([PortDescription PortName] -> PortDescription PortName)
-> [PortDescription PortName] -> PortDescription PortName
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (Pat GhcPs) -> PortDescription PortName)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [PortDescription PortName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LPat GhcPs -> PortDescription PortName
GenLocated SrcSpanAnnA (Pat GhcPs) -> PortDescription PortName
forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
lpat
  ParPatP LPat GhcPs
lpat -> LPat GhcPs -> PortDescription PortName
forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave LPat GhcPs
lpat
#if __GLASGOW_HASKELL__ >= 902
  ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ (GHC.Unqual OccName
occ)) (PrefixCon [] [LPat GhcPs
lpat])
#elif __GLASGOW_HASKELL__ >= 900
  ConPat _ (L _ (GHC.Unqual occ)) (PrefixCon [lpat])
#else
  ConPatIn (L _ (GHC.Unqual occ)) (PrefixCon [lpat])
#endif
    | OccName -> [Char]
OccName.occNameString OccName
occ [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
fwdNames -> LPat GhcPs -> PortDescription PortName
forall a. LPat GhcPs -> PortDescription a
FwdPat LPat GhcPs
lpat
  -- empty list is done as the constructor
#if __GLASGOW_HASKELL__ >= 900
  ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ RdrName
rdr) HsConPatDetails GhcPs
_
#else
  ConPatIn (L _ rdr) _
#endif
    | RdrName
rdr RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
thName '[] -> SrcSpanAnnA
-> [PortDescription PortName] -> PortDescription PortName
forall a. SrcSpanAnnA -> [PortDescription a] -> PortDescription a
Vec SrcSpanAnnA
loc []
    | RdrName
rdr RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
thName '() -> [PortDescription PortName] -> PortDescription PortName
forall a. [PortDescription a] -> PortDescription a
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 XSigPat GhcPs
_ LPat GhcPs
port HsPatSigType (NoGhcTc GhcPs)
ty -> LHsType GhcPs
-> PortDescription PortName -> PortDescription PortName
forall a. LHsType GhcPs -> PortDescription a -> PortDescription a
PortType (HsPatSigType GhcPs -> LHsType GhcPs
forall pass. HsPatSigType pass -> LHsType pass
hsps_body HsPatSigType (NoGhcTc GhcPs)
HsPatSigType GhcPs
ty) (LPat GhcPs -> PortDescription PortName
forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave LPat GhcPs
port)
#endif
  LazyPat XLazyPat GhcPs
_ LPat GhcPs
lpat -> SrcSpanAnnA -> PortDescription PortName -> PortDescription PortName
forall a. SrcSpanAnnA -> PortDescription a -> PortDescription a
Lazy SrcSpanAnnA
loc (LPat GhcPs -> PortDescription PortName
forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave LPat GhcPs
lpat)
  ListPat XListPat GhcPs
_ [LPat GhcPs]
pats -> SrcSpanAnnA
-> [PortDescription PortName] -> PortDescription PortName
forall a. SrcSpanAnnA -> [PortDescription a] -> PortDescription a
Vec SrcSpanAnnA
loc ((GenLocated SrcSpanAnnA (Pat GhcPs) -> PortDescription PortName)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [PortDescription PortName]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcPs -> PortDescription PortName
GenLocated SrcSpanAnnA (Pat GhcPs) -> PortDescription PortName
forall p. (p ~ GhcPs) => LPat p -> PortDescription PortName
bindSlave [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
pats)
  Pat GhcPs
pat ->
    SrcSpanAnnA -> SDoc -> PortDescription PortName
forall a. SrcSpanAnnA -> SDoc -> PortDescription a
PortErr SrcSpanAnnA
loc
            (MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage
              MessageClass
sevFatal
              (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
              ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
Outputable.text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char]
"Unhandled pattern " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Constr -> [Char]
forall a. Show a => a -> [Char]
show (Pat GhcPs -> Constr
forall a. Data a => a -> Constr
Data.toConstr Pat GhcPs
pat))
              )

-- | Turn expressions to the right of a @-<@ into a PortDescription.
bindMaster :: LHsExpr GhcPs -> PortDescription PortName
bindMaster :: LHsExpr GhcPs -> PortDescription PortName
bindMaster (L SrcSpanAnnA
loc HsExpr GhcPs
expr) = case HsExpr GhcPs
expr of
  HsVar XVar GhcPs
_xvar (L SrcSpanAnnN
_vloc RdrName
rdrName)
    | RdrName
rdrName RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
thName '() -> [PortDescription PortName] -> PortDescription PortName
forall a. [PortDescription a] -> PortDescription a
Tuple []
    | RdrName
rdrName RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
thName '[] -> SrcSpanAnnA
-> [PortDescription PortName] -> PortDescription PortName
forall a. SrcSpanAnnA -> [PortDescription a] -> PortDescription a
Vec SrcSpanAnnA
loc [] -- XXX: vloc?
    | Bool
otherwise -> PortName -> PortDescription PortName
forall a. a -> PortDescription a
Ref (SrcSpanAnnA -> FastString -> PortName
PortName SrcSpanAnnA
loc (RdrName -> FastString
fromRdrName RdrName
rdrName)) -- XXX: vloc?
  HsApp XApp GhcPs
_xapp (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ (GHC.Unqual OccName
occ)))) LHsExpr GhcPs
sig
    | OccName -> [Char]
OccName.occNameString OccName
occ [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
fwdNames -> LHsExpr GhcPs -> PortDescription PortName
forall a. LHsExpr GhcPs -> PortDescription a
FwdExpr LHsExpr GhcPs
sig
  ExplicitTuple XExplicitTuple GhcPs
_ [HsTupArg GhcPs]
tups Boxity
_ -> let
#if __GLASGOW_HASKELL__ >= 902
    vals :: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
vals = (HsTupArg GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [HsTupArg GhcPs] -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Present XPresent GhcPs
_ LHsExpr GhcPs
e) -> LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e) [HsTupArg GhcPs]
tups
#else
    vals = fmap (\(L _ (Present _ e)) -> e) tups
#endif
    in [PortDescription PortName] -> PortDescription PortName
forall a. [PortDescription a] -> PortDescription a
Tuple ([PortDescription PortName] -> PortDescription PortName)
-> [PortDescription PortName] -> PortDescription PortName
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PortDescription PortName)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [PortDescription PortName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcPs -> PortDescription PortName
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PortDescription PortName
bindMaster [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
vals
#if __GLASGOW_HASKELL__ >= 902
  ExplicitList XExplicitList GhcPs
_ [LHsExpr GhcPs]
exprs ->
#else
  ExplicitList _ _syntaxExpr exprs ->
#endif
    SrcSpanAnnA
-> [PortDescription PortName] -> PortDescription PortName
forall a. SrcSpanAnnA -> [PortDescription a] -> PortDescription a
Vec SrcSpanAnnA
loc ([PortDescription PortName] -> PortDescription PortName)
-> [PortDescription PortName] -> PortDescription PortName
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PortDescription PortName)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [PortDescription PortName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsExpr GhcPs -> PortDescription PortName
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> PortDescription PortName
bindMaster [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
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 XProc GhcPs
_ LPat GhcPs
_ (L SrcAnn NoEpAnns
_ (HsCmdTop XCmdTop GhcPs
_ (L SrcSpanAnnA
_ (HsCmdArrApp XCmdArrApp GhcPs
_xapp (L SrcSpanAnnA
_ (HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ (GHC.Unqual OccName
occ)))) LHsExpr GhcPs
sig HsArrAppType
_ Bool
_))))
    | OccName -> [Char]
OccName.occNameString OccName
occ [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
fwdNames -> LHsExpr GhcPs -> PortDescription PortName
forall a. LHsExpr GhcPs -> PortDescription a
FwdExpr LHsExpr GhcPs
sig
  ExprWithTySig XExprWithTySig GhcPs
_ LHsExpr GhcPs
expr' LHsSigWcType (NoGhcTc GhcPs)
ty -> LHsType GhcPs
-> PortDescription PortName -> PortDescription PortName
forall a. LHsType GhcPs -> PortDescription a -> PortDescription a
PortType (LHsSigWcType GhcPs -> LHsType GhcPs
forall p. UnXRec p => LHsSigWcType p -> LHsType p
hsSigWcType LHsSigWcType (NoGhcTc GhcPs)
LHsSigWcType GhcPs
ty) (LHsExpr GhcPs -> PortDescription PortName
bindMaster LHsExpr GhcPs
expr')
#endif

  HsParP LHsExpr GhcPs
expr' -> LHsExpr GhcPs -> PortDescription PortName
bindMaster LHsExpr GhcPs
expr'

  -- OpApp _xapp (L _ circuitVar) (L _ infixVar) appR -> k

  HsExpr GhcPs
_ -> SrcSpanAnnA -> SDoc -> PortDescription PortName
forall a. SrcSpanAnnA -> SDoc -> PortDescription a
PortErr SrcSpanAnnA
loc
    (MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage
      MessageClass
sevFatal
      (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
      ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
Outputable.text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char]
"Unhandled expression " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Constr -> [Char]
forall a. Show a => a -> [Char]
show (HsExpr GhcPs -> Constr
forall a. Data a => a -> Constr
Data.toConstr HsExpr GhcPs
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 :: Maybe (PortDescription PortName)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> CircuitM ()
bodyBinding Maybe (PortDescription PortName)
mInput lexpr :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr@(L SrcSpanAnnA
loc HsExpr GhcPs
expr) = do
  case HsExpr GhcPs
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 XOpApp GhcPs
_ LHsExpr GhcPs
circuit (L SrcSpanAnnA
_ HsExpr GhcPs
op) LHsExpr GhcPs
port | HsExpr GhcPs -> Bool
forall p. (p ~ GhcPs) => HsExpr p -> Bool
isFletching HsExpr GhcPs
op -> do
      ([Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
 -> Identity
      [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm exp (f :: * -> *).
Functor f =>
([Binding exp nm] -> f [Binding exp nm])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitBinds (([Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  -> Identity
       [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName])
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> CircuitM ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [Binding
        { bCircuit :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
bCircuit = LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
circuit
        , bOut :: PortDescription PortName
bOut     = LHsExpr GhcPs -> PortDescription PortName
bindMaster LHsExpr GhcPs
port
        , bIn :: PortDescription PortName
bIn      = PortDescription PortName
-> Maybe (PortDescription PortName) -> PortDescription PortName
forall a. a -> Maybe a -> a
fromMaybe ([PortDescription PortName] -> PortDescription PortName
forall a. [PortDescription a] -> PortDescription a
Tuple []) Maybe (PortDescription PortName)
mInput
        }]
#endif

    HsExpr GhcPs
_ -> case Maybe (PortDescription PortName)
mInput of
      Maybe (PortDescription PortName)
Nothing -> SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [Char]
"standalone expressions are not allowed (are Arrows enabled?)"
      Just PortDescription PortName
input -> ([Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
 -> Identity
      [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm exp (f :: * -> *).
Functor f =>
([Binding exp nm] -> f [Binding exp nm])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitBinds (([Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  -> Identity
       [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName])
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> CircuitM ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [Binding
        { bCircuit :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
bCircuit = GenLocated SrcSpanAnnA (HsExpr GhcPs)
lexpr
        , bOut :: PortDescription PortName
bOut     = [PortDescription PortName] -> PortDescription PortName
forall a. [PortDescription a] -> PortDescription a
Tuple []
        , bIn :: PortDescription PortName
bIn      = PortDescription PortName
input
        }]

-- Checking ------------------------------------------------------------

data Dir = Slave | Master

checkCircuit :: p ~ GhcPs => CircuitM ()
checkCircuit :: forall p. (p ~ GhcPs) => CircuitM ()
checkCircuit = do
  PortDescription PortName
slaves <- Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
-> CircuitM (PortDescription PortName)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitSlaves
  PortDescription PortName
masters <- Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
-> CircuitM (PortDescription PortName)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitMasters
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
binds <- Getting
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> CircuitM
     [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
forall dec exp nm exp (f :: * -> *).
Functor f =>
([Binding exp nm] -> f [Binding exp nm])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitBinds

  let portNames :: Dir
-> PortDescription PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
portNames Dir
d = Getting
  (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
  (PortDescription PortName)
  (FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
-> PortDescription PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
forall a s. Getting (Endo [a]) s a -> s -> [a]
L.toListOf ((PortDescription PortName
 -> Const
      (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
      (PortDescription PortName))
-> PortDescription PortName
-> Const
     (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
     (PortDescription PortName)
forall a. Plated a => Fold a a
Fold (PortDescription PortName) (PortDescription PortName)
L.cosmos ((PortDescription PortName
  -> Const
       (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
       (PortDescription PortName))
 -> PortDescription PortName
 -> Const
      (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
      (PortDescription PortName))
-> Getting
     (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
     (PortDescription PortName)
     (FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
-> Getting
     (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
     (PortDescription PortName)
     (FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortName
 -> Const
      (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]) PortName)
-> PortDescription PortName
-> Const
     (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
     (PortDescription PortName)
forall a (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f a) -> p (PortDescription a) (f (PortDescription a))
_Ref ((PortName
  -> Const
       (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]) PortName)
 -> PortDescription PortName
 -> Const
      (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
      (PortDescription PortName))
-> (((FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
     -> Const
          (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
          (FastString, ([SrcSpanAnnA], [SrcSpanAnnA])))
    -> PortName
    -> Const
         (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]) PortName)
-> Getting
     (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
     (PortDescription PortName)
     (FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortName -> (FastString, ([SrcSpanAnnA], [SrcSpanAnnA])))
-> ((FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
    -> Const
         (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
         (FastString, ([SrcSpanAnnA], [SrcSpanAnnA])))
-> PortName
-> Const
     (Endo [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]) PortName
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
L.to (Dir -> PortName -> (FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
f Dir
d))
      f :: Dir -> PortName -> (GHC.FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
      f :: Dir -> PortName -> (FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
f Dir
Slave (PortName SrcSpanAnnA
srcLoc FastString
portName) = (FastString
portName, ([SrcSpanAnnA
srcLoc], []))
      f Dir
Master (PortName SrcSpanAnnA
srcLoc FastString
portName) = (FastString
portName, ([], [SrcSpanAnnA
srcLoc]))
      bindingNames :: Binding exp PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
bindingNames = \Binding exp PortName
b -> Dir
-> PortDescription PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
portNames Dir
Master (Binding exp PortName -> PortDescription PortName
forall exp l. Binding exp l -> PortDescription l
bOut Binding exp PortName
b) [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
forall a. Semigroup a => a -> a -> a
<> Dir
-> PortDescription PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
portNames Dir
Slave (Binding exp PortName -> PortDescription PortName
forall exp l. Binding exp l -> PortDescription l
bIn Binding exp PortName
b)
      topNames :: [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
topNames = Dir
-> PortDescription PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
portNames Dir
Slave PortDescription PortName
slaves [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
forall a. Semigroup a => a -> a -> a
<> Dir
-> PortDescription PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
portNames Dir
Master PortDescription PortName
masters
      nameMap :: UniqMap FastString ([SrcSpanAnnA], [SrcSpanAnnA])
nameMap = (([SrcSpanAnnA], [SrcSpanAnnA])
 -> ([SrcSpanAnnA], [SrcSpanAnnA])
 -> ([SrcSpanAnnA], [SrcSpanAnnA]))
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> UniqMap FastString ([SrcSpanAnnA], [SrcSpanAnnA])
forall k a. Uniquable k => (a -> a -> a) -> [(k, a)] -> UniqMap k a
listToUniqMap_C ([SrcSpanAnnA], [SrcSpanAnnA])
-> ([SrcSpanAnnA], [SrcSpanAnnA]) -> ([SrcSpanAnnA], [SrcSpanAnnA])
forall a. Monoid a => a -> a -> a
mappend ([(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
 -> UniqMap FastString ([SrcSpanAnnA], [SrcSpanAnnA]))
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> UniqMap FastString ([SrcSpanAnnA], [SrcSpanAnnA])
forall a b. (a -> b) -> a -> b
$ [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
topNames [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
forall a. Semigroup a => a -> a -> a
<> (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
 -> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))])
-> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
forall {exp}.
Binding exp PortName
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
bindingNames [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
binds

  [FastString]
duplicateMasters <- [[FastString]] -> [FastString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FastString]] -> [FastString])
-> CircuitM [[FastString]] -> CircuitM [FastString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
-> ((FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))
    -> CircuitM [FastString])
-> CircuitM [[FastString]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UniqMap FastString ([SrcSpanAnnA], [SrcSpanAnnA])
-> [(FastString, ([SrcSpanAnnA], [SrcSpanAnnA]))]
forall key a. UniqMap key a -> [(key, a)]
nonDetUniqMapToList UniqMap FastString ([SrcSpanAnnA], [SrcSpanAnnA])
nameMap) \(FastString
name, ([SrcSpanAnnA], [SrcSpanAnnA])
occ) -> do
    let isIgnored :: Bool
isIgnored = case FastString -> [Char]
unpackFS FastString
name of {(Char
'_':[Char]
_) -> Bool
True; [Char]
_ -> Bool
False}

    case ([SrcSpanAnnA], [SrcSpanAnnA])
occ of
      ([], []) -> [FastString] -> CircuitM [FastString]
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ([SrcSpanAnnA
_], [SrcSpanAnnA
_]) -> [FastString] -> CircuitM [FastString]
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      (SrcSpanAnnA
s:[SrcSpanAnnA]
_, []) | Bool -> Bool
not Bool
isIgnored -> SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
s) ([Char]
"Slave port " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> FastString -> [Char]
forall a. Show a => a -> [Char]
show FastString
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" has no associated master") CircuitM () -> CircuitM [FastString] -> CircuitM [FastString]
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FastString] -> CircuitM [FastString]
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ([], SrcSpanAnnA
m:[SrcSpanAnnA]
_) | Bool -> Bool
not Bool
isIgnored -> SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
m) ([Char]
"Master port " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> FastString -> [Char]
forall a. Show a => a -> [Char]
show FastString
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" has no associated slave") CircuitM () -> CircuitM [FastString] -> CircuitM [FastString]
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FastString] -> CircuitM [FastString]
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      (ss :: [SrcSpanAnnA]
ss@(SrcSpanAnnA
s:SrcSpanAnnA
_:[SrcSpanAnnA]
_), [SrcSpanAnnA]
_) ->
        -- would be nice to show locations of all occurrences here, not sure how to do that while
        -- keeping ghc api
        SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
s) ([Char]
"Slave port " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> FastString -> [Char]
forall a. Show a => a -> [Char]
show FastString
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" defined " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([SrcSpanAnnA] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SrcSpanAnnA]
ss) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" times") CircuitM () -> CircuitM [FastString] -> CircuitM [FastString]
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [FastString] -> CircuitM [FastString]
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ([SrcSpanAnnA]
_ss, [SrcSpanAnnA]
ms) -> do
        -- if master is defined multiple times, we broadcast it
        if [SrcSpanAnnA] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SrcSpanAnnA]
ms Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
          then [FastString] -> CircuitM [FastString]
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FastString
name]
          else [FastString] -> CircuitM [FastString]
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  let
    modifyMulticast :: PortDescription PortName -> PortDescription PortName
modifyMulticast = \case
      Ref p :: PortName
p@(PortName SrcSpanAnnA
_ FastString
a) | FastString
a FastString -> [FastString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FastString]
duplicateMasters -> PortName -> PortDescription PortName
forall a. a -> PortDescription a
RefMulticast PortName
p
      PortDescription PortName
p -> PortDescription PortName
p

  -- update relevant master ports to be multicast
  (PortDescription PortName -> Identity (PortDescription PortName))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitSlaves ((PortDescription PortName -> Identity (PortDescription PortName))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> (PortDescription PortName -> PortDescription PortName)
-> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (PortDescription PortName -> PortDescription PortName)
-> PortDescription PortName -> PortDescription PortName
forall a. Plated a => (a -> a) -> a -> a
L.transform PortDescription PortName -> PortDescription PortName
modifyMulticast
  (PortDescription PortName -> Identity (PortDescription PortName))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitMasters ((PortDescription PortName -> Identity (PortDescription PortName))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> (PortDescription PortName -> PortDescription PortName)
-> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (PortDescription PortName -> PortDescription PortName)
-> PortDescription PortName -> PortDescription PortName
forall a. Plated a => (a -> a) -> a -> a
L.transform PortDescription PortName -> PortDescription PortName
modifyMulticast
  ([Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
 -> Identity
      [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm exp (f :: * -> *).
Functor f =>
([Binding exp nm] -> f [Binding exp nm])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitBinds (([Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  -> Identity
       [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName])
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> ((Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
     -> Identity
          (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName))
    -> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
    -> Identity
         [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName])
-> (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
    -> Identity
         (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
 -> Identity
      (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName))
-> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> Identity
     [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
Setter
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName)
  (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
L.mapped ((Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
  -> Identity
       (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
    -> Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName)
-> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
b -> Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
b
    { bIn = L.transform modifyMulticast (bIn b),
      bOut = L.transform modifyMulticast (bOut b)
    }

-- Creating ------------------------------------------------------------

data Direction = Fwd | Bwd deriving Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> [Char]
(Int -> Direction -> ShowS)
-> (Direction -> [Char])
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Direction -> ShowS
showsPrec :: Int -> Direction -> ShowS
$cshow :: Direction -> [Char]
show :: Direction -> [Char]
$cshowList :: [Direction] -> ShowS
showList :: [Direction] -> ShowS
Show

bindWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => GHC.DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix DynFlags
dflags Direction
dir = \case
  Tuple [PortDescription PortName]
ps -> SrcSpanAnnA -> LPat GhcPs -> LPat GhcPs
tildeP SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> LPat GhcPs
forall p. (p ~ GhcPs, ?nms::ExternalNames) => LPat p -> LPat p
taggedBundleP (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ [LPat GhcPs] -> LPat GhcPs
forall p. (p ~ GhcPs) => [LPat p] -> LPat p
tupP ([LPat GhcPs] -> LPat GhcPs) -> [LPat GhcPs] -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ (PortDescription PortName -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [PortDescription PortName]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags -> Direction -> PortDescription PortName -> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix DynFlags
dflags Direction
dir) [PortDescription PortName]
ps
  Vec SrcSpanAnnA
s [PortDescription PortName]
ps -> LPat GhcPs -> LPat GhcPs
forall p. (p ~ GhcPs, ?nms::ExternalNames) => LPat p -> LPat p
taggedBundleP (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ (?nms::ExternalNames) => SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs
SrcSpanAnnA -> [LPat GhcPs] -> LPat GhcPs
vecP SrcSpanAnnA
s ([LPat GhcPs] -> LPat GhcPs) -> [LPat GhcPs] -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ (PortDescription PortName -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [PortDescription PortName]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags -> Direction -> PortDescription PortName -> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix DynFlags
dflags Direction
dir) [PortDescription PortName]
ps
  Ref (PortName SrcSpanAnnA
loc FastString
fs) -> SrcSpanAnnA -> [Char] -> LPat GhcPs
varP SrcSpanAnnA
loc (FastString -> [Char]
GHC.unpackFS FastString
fs [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"_" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Direction -> [Char]
forall a. Show a => a -> [Char]
show Direction
dir)
  RefMulticast (PortName SrcSpanAnnA
loc FastString
fs) -> case Direction
dir of
    Direction
Bwd -> SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XWildPat GhcPs -> Pat GhcPs
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcPs
NoExtField
noExtField)
    Direction
Fwd -> SrcSpanAnnA -> [Char] -> LPat GhcPs
varP SrcSpanAnnA
loc (FastString -> [Char]
GHC.unpackFS FastString
fs [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"_" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Direction -> [Char]
forall a. Show a => a -> [Char]
show Direction
dir)
  PortErr SrcSpanAnnA
loc SDoc
msgdoc -> IO (GenLocated SrcSpanAnnA (Pat GhcPs)) -> LPat p
IO (GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a. IO a -> a
unsafePerformIO (IO (GenLocated SrcSpanAnnA (Pat GhcPs)) -> LPat p)
-> (ErrMsg -> IO (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> ErrMsg
-> LPat p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> IO (GenLocated SrcSpanAnnA (Pat GhcPs))
forall (io :: * -> *) a. MonadIO io => ErrMsg -> io a
throwOneError (ErrMsg -> LPat p) -> ErrMsg -> LPat p
forall a b. (a -> b) -> a -> b
$
    DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> ErrMsg
mkLongErrMsg DynFlags
dflags (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) PrintUnqualified
Outputable.alwaysQualify ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
Outputable.text [Char]
"Unhandled bind") SDoc
msgdoc
  Lazy SrcSpanAnnA
loc PortDescription PortName
p -> SrcSpanAnnA -> LPat GhcPs -> LPat GhcPs
tildeP SrcSpanAnnA
loc (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ DynFlags -> Direction -> PortDescription PortName -> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix DynFlags
dflags Direction
dir PortDescription PortName
p
#if __GLASGOW_HASKELL__ >= 902
  -- XXX: propagate location
  FwdExpr (L SrcSpanAnnA
_ HsExpr GhcPs
_) -> LPat p
LPat GhcPs
nlWildPat
#else
  FwdExpr (L l _) -> L l (WildPat noExt)
#endif
  FwdPat LPat GhcPs
lpat -> LPat GhcPs -> LPat GhcPs
forall p. (p ~ GhcPs, ?nms::ExternalNames) => LPat p -> LPat p
tagP LPat GhcPs
lpat
  PortType LHsType GhcPs
ty PortDescription PortName
p -> Direction -> LHsType GhcPs -> LPat GhcPs -> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> LHsType GhcPs -> LPat p -> LPat p
tagTypeP Direction
dir LHsType GhcPs
ty (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ DynFlags -> Direction -> PortDescription PortName -> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix DynFlags
dflags Direction
dir PortDescription PortName
p

revDirec :: Direction -> Direction
revDirec :: Direction -> Direction
revDirec = \case
  Direction
Fwd -> Direction
Bwd
  Direction
Bwd -> Direction
Fwd

bindOutputs
  :: (p ~ GhcPs, ?nms :: ExternalNames)
  => GHC.DynFlags
  -> Direction
  -> PortDescription PortName
  -- ^ slave ports
  -> PortDescription PortName
  -- ^ master ports
  -> LPat p
bindOutputs :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags
-> Direction
-> PortDescription PortName
-> PortDescription PortName
-> LPat p
bindOutputs DynFlags
dflags Direction
direc PortDescription PortName
slaves PortDescription PortName
masters = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName
-> HsConPatDetails GhcPs -> Pat GhcPs
conPatIn (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (ExternalNames -> RdrName
fwdBwdCon ?nms::ExternalNames
ExternalNames
?nms)) (GenLocated SrcSpanAnnA (Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
m2s LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
s2m)
  where
  m2s :: LPat GhcPs
m2s = DynFlags -> Direction -> PortDescription PortName -> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix DynFlags
dflags Direction
direc PortDescription PortName
masters
  s2m :: LPat GhcPs
s2m = DynFlags -> Direction -> PortDescription PortName -> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Direction -> PortDescription PortName -> LPat p
bindWithSuffix DynFlags
dflags (Direction -> Direction
revDirec Direction
direc) PortDescription PortName
slaves

expWithSuffix :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix Direction
dir = \case
  Tuple [PortDescription PortName]
ps -> LHsExpr GhcPs -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
LHsExpr p -> LHsExpr p
taggedBundleE (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall p. (p ~ GhcPs) => SrcSpanAnnA -> [LHsExpr p] -> LHsExpr p
tupE SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (PortDescription PortName -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [PortDescription PortName]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Direction -> PortDescription PortName -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix Direction
dir) [PortDescription PortName]
ps
  Vec SrcSpanAnnA
s [PortDescription PortName]
ps -> LHsExpr GhcPs -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
LHsExpr p -> LHsExpr p
taggedBundleE (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> [LHsExpr GhcPs] -> LHsExpr GhcPs
vecE SrcSpanAnnA
s ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (PortDescription PortName -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [PortDescription PortName]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Direction -> PortDescription PortName -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix Direction
dir) [PortDescription PortName]
ps
  Ref (PortName SrcSpanAnnA
loc FastString
fs)   -> SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc ([Char] -> RdrName
var ([Char] -> RdrName) -> [Char] -> RdrName
forall a b. (a -> b) -> a -> b
$ FastString -> [Char]
GHC.unpackFS FastString
fs [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"_" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Direction -> [Char]
forall a. Show a => a -> [Char]
show Direction
dir)
  RefMulticast (PortName SrcSpanAnnA
loc FastString
fs) -> case Direction
dir of
    Direction
Bwd -> SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (ExternalNames -> RdrName
trivialBwd ?nms::ExternalNames
ExternalNames
?nms)
    Direction
Fwd -> SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc ([Char] -> RdrName
var ([Char] -> RdrName) -> [Char] -> RdrName
forall a b. (a -> b) -> a -> b
$ FastString -> [Char]
GHC.unpackFS FastString
fs [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"_" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Direction -> [Char]
forall a. Show a => a -> [Char]
show Direction
dir)
  -- laziness only affects the pattern side
  Lazy SrcSpanAnnA
_ PortDescription PortName
p   -> Direction -> PortDescription PortName -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix Direction
dir PortDescription PortName
p
  PortErr SrcSpanAnnA
_ SDoc
_ -> [Char] -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. HasCallStack => [Char] -> a
error [Char]
"expWithSuffix PortErr!"
  FwdExpr LHsExpr GhcPs
lexpr -> LHsExpr GhcPs -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
LHsExpr p -> LHsExpr p
tagE LHsExpr GhcPs
lexpr
  FwdPat (L SrcSpanAnnA
l Pat GhcPs
_) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
LHsExpr p -> LHsExpr p
tagE (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
l (ExternalNames -> RdrName
trivialBwd ?nms::ExternalNames
ExternalNames
?nms)
  PortType LHsType GhcPs
ty PortDescription PortName
p -> Direction -> LHsType GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> LHsType GhcPs -> LHsExpr p -> LHsExpr p
tagTypeE Direction
dir LHsType GhcPs
ty (Direction -> PortDescription PortName -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix Direction
dir PortDescription PortName
p)

createInputs
  :: (p ~ GhcPs, ?nms :: ExternalNames)
  => Direction
  -> PortDescription PortName
  -- ^ slave ports
  -> PortDescription PortName
  -- ^ master ports
  -> LHsExpr p
createInputs :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction
-> PortDescription PortName
-> PortDescription PortName
-> LHsExpr p
createInputs Direction
dir PortDescription PortName
slaves PortDescription PortName
masters = HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt LHsExpr GhcPs
s2m (SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (ExternalNames -> RdrName
fwdBwdCon ?nms::ExternalNames
ExternalNames
?nms)) LHsExpr GhcPs
m2s
  where
  m2s :: LHsExpr GhcPs
m2s = Direction -> PortDescription PortName -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix (Direction -> Direction
revDirec Direction
dir) PortDescription PortName
masters
  s2m :: LHsExpr GhcPs
s2m = Direction -> PortDescription PortName -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> PortDescription PortName -> LHsExpr p
expWithSuffix Direction
dir PortDescription PortName
slaves

decFromBinding :: (p ~ GhcPs, ?nms :: ExternalNames) => GHC.DynFlags -> Binding (LHsExpr p) PortName -> HsBind p
decFromBinding :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Binding (LHsExpr p) PortName -> HsBind p
decFromBinding DynFlags
dflags Binding {LHsExpr p
PortDescription PortName
bCircuit :: forall exp l. Binding exp l -> exp
bOut :: forall exp l. Binding exp l -> PortDescription l
bIn :: forall exp l. Binding exp l -> PortDescription l
bCircuit :: LHsExpr p
bOut :: PortDescription PortName
bIn :: PortDescription PortName
..} = do
  let bindPat :: LPat GhcPs
bindPat  = DynFlags
-> Direction
-> PortDescription PortName
-> PortDescription PortName
-> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags
-> Direction
-> PortDescription PortName
-> PortDescription PortName
-> LPat p
bindOutputs DynFlags
dflags Direction
Bwd PortDescription PortName
bIn PortDescription PortName
bOut
      inputExp :: LHsExpr GhcPs
inputExp = Direction
-> PortDescription PortName
-> PortDescription PortName
-> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction
-> PortDescription PortName
-> PortDescription PortName
-> LHsExpr p
createInputs Direction
Fwd PortDescription PortName
bOut PortDescription PortName
bIn
      bod :: LHsExpr GhcPs
bod = (?nms::ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs
SrcSpanAnnA -> LHsExpr GhcPs
runCircuitFun SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` LHsExpr p
LHsExpr GhcPs
bCircuit LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` LHsExpr GhcPs
inputExp
   in LPat GhcPs -> LHsExpr GhcPs -> HsBindLR GhcPs GhcPs
patBind LPat GhcPs
bindPat LHsExpr GhcPs
bod

patBind :: LPat GhcPs -> LHsExpr GhcPs -> HsBind GhcPs
patBind :: LPat GhcPs -> LHsExpr GhcPs -> HsBindLR GhcPs GhcPs
patBind LPat GhcPs
lhs LHsExpr GhcPs
expr = XPatBind GhcPs GhcPs
-> LPat GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL -> GRHSs idR (LHsExpr idR) -> HsBindLR idL idR
PatBind XPatBind GhcPs GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt LPat GhcPs
lhs GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs
#if __GLASGOW_HASKELL__ < 906
   ([], [])
#endif
  where
    rhs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    rhs :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs = XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> HsLocalBindsLR GhcPs GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnnComments
emptyComments [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
gr] (HsLocalBindsLR GhcPs GhcPs
 -> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> HsLocalBindsLR GhcPs GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ >= 902
      XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExtField
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 :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
gr =  SrcAnn NoEpAnns
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     (SrcAnn NoEpAnns)
     (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn NoEpAnns
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr)) (XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [GuardLStmt GhcPs]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn GrhsAnn
forall ann. EpAnn ann
noExt [] LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr)
#endif

circuitConstructor :: (?nms :: ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs
circuitConstructor :: (?nms::ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs
circuitConstructor SrcSpanAnnA
loc = SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc (ExternalNames -> RdrName
circuitCon ?nms::ExternalNames
ExternalNames
?nms)

runCircuitFun :: (?nms :: ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs
runCircuitFun :: (?nms::ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs
runCircuitFun SrcSpanAnnA
loc = SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc (ExternalNames -> RdrName
runCircuitName ?nms::ExternalNames
ExternalNames
?nms)


#if __GLASGOW_HASKELL__ < 902
prefixCon :: [arg] -> HsConDetails arg rec
prefixCon a = PrefixCon a
#else
prefixCon :: [arg] -> HsConDetails tyarg arg rec
prefixCon :: forall arg tyarg rec. [arg] -> HsConDetails tyarg arg rec
prefixCon [arg]
a = [tyarg] -> [arg] -> HsConDetails tyarg arg rec
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] [arg]
a
#endif

taggedBundleP :: (p ~ GhcPs, ?nms :: ExternalNames) => LPat p -> LPat p
taggedBundleP :: forall p. (p ~ GhcPs, ?nms::ExternalNames) => LPat p -> LPat p
taggedBundleP LPat p
a = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (GenLocated SrcSpanAnnN RdrName
-> HsConPatDetails GhcPs -> Pat GhcPs
conPatIn (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (ExternalNames -> RdrName
tagBundlePat ?nms::ExternalNames
ExternalNames
?nms)) ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall arg tyarg rec. [arg] -> HsConDetails tyarg arg rec
prefixCon [LPat p
GenLocated SrcSpanAnnA (Pat GhcPs)
a]))

taggedBundleE :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsExpr p -> LHsExpr p
taggedBundleE :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
LHsExpr p -> LHsExpr p
taggedBundleE LHsExpr p
a = SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (ExternalNames -> RdrName
tagBundlePat ?nms::ExternalNames
ExternalNames
?nms) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` LHsExpr p
LHsExpr GhcPs
a

tagP :: (p ~ GhcPs, ?nms :: ExternalNames) => LPat p -> LPat p
tagP :: forall p. (p ~ GhcPs, ?nms::ExternalNames) => LPat p -> LPat p
tagP LPat p
a = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (GenLocated SrcSpanAnnN RdrName
-> HsConPatDetails GhcPs -> Pat GhcPs
conPatIn (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (ExternalNames -> RdrName
tagName ?nms::ExternalNames
ExternalNames
?nms)) ([GenLocated SrcSpanAnnA (Pat GhcPs)]
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall arg tyarg rec. [arg] -> HsConDetails tyarg arg rec
prefixCon [LPat p
GenLocated SrcSpanAnnA (Pat GhcPs)
a]))

tagE :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsExpr p -> LHsExpr p
tagE :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
LHsExpr p -> LHsExpr p
tagE LHsExpr p
a = SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (ExternalNames -> RdrName
tagName ?nms::ExternalNames
ExternalNames
?nms) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` LHsExpr p
LHsExpr GhcPs
a

tagTypeCon :: (p ~ GhcPs, ?nms :: ExternalNames) => LHsType GhcPs
tagTypeCon :: forall p. (p ~ GhcPs, ?nms::ExternalNames) => LHsType GhcPs
tagTypeCon = HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt PromotionFlag
NotPromoted (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (ExternalNames -> RdrName
tagTName ?nms::ExternalNames
ExternalNames
?nms)))

sigPat :: (p ~ GhcPs) => SrcSpanAnnA -> LHsType GhcPs -> LPat p -> LPat p
sigPat :: forall p.
(p ~ GhcPs) =>
SrcSpanAnnA -> LHsType GhcPs -> LPat p -> LPat p
sigPat SrcSpanAnnA
loc LHsType GhcPs
ty LPat p
a = SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ < 810
    SigPat (HsWC noExt (HsIB noExt ty)) a
#elif __GLASGOW_HASKELL__ < 900
    SigPat noExt a (HsWC noExt (HsIB noExt ty))
#else
    XSigPat GhcPs
-> LPat GhcPs -> HsPatSigType (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat XSigPat GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt LPat p
LPat GhcPs
a (XHsPS GhcPs -> LHsType GhcPs -> HsPatSigType GhcPs
forall pass. XHsPS pass -> LHsType pass -> HsPatSigType pass
HsPS XHsPS GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
noExt LHsType GhcPs
ty)
#endif

sigE :: (?nms :: ExternalNames) => SrcSpanAnnA -> LHsType GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
sigE :: (?nms::ExternalNames) =>
SrcSpanAnnA -> LHsType GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
sigE SrcSpanAnnA
loc LHsType GhcPs
ty LHsExpr GhcPs
a = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ < 810
    ExprWithTySig (HsWC noExt (HsIB noExt ty)) a
#elif __GLASGOW_HASKELL__ < 902
    ExprWithTySig noExt a (HsWC noExt (HsIB noExt ty))
#else
    XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt LHsExpr GhcPs
a (XHsWC GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC XHsWC GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
NoExtField
noExtField (SrcSpanAnnA
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsSig GhcPs
-> HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsSigType GhcPs
forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig XHsSig GhcPs
NoExtField
noExtField (XHsOuterImplicit GhcPs -> HsOuterSigTyVarBndrs GhcPs
forall flag pass.
XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass
HsOuterImplicit XHsOuterImplicit GhcPs
NoExtField
noExtField) LHsType GhcPs
ty))
#endif

tagTypeP :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> LHsType GhcPs -> LPat p -> LPat p
tagTypeP :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> LHsType GhcPs -> LPat p -> LPat p
tagTypeP Direction
dir LHsType GhcPs
ty
  = SrcSpanAnnA -> LHsType GhcPs -> LPat GhcPs -> LPat GhcPs
forall p.
(p ~ GhcPs) =>
SrcSpanAnnA -> LHsType GhcPs -> LPat p -> LPat p
sigPat SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (LHsType GhcPs
forall p. (p ~ GhcPs, ?nms::ExternalNames) => LHsType GhcPs
tagTypeCon LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` LHsType GhcPs
ty LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` LHsType GhcPs
busType)
  where
    busType :: LHsType GhcPs
busType = SrcSpanAnnA -> RdrName -> LHsType GhcPs
conT SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (ExternalNames -> Direction -> RdrName
fwdAndBwdTypes ?nms::ExternalNames
ExternalNames
?nms Direction
dir) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` LHsType GhcPs
ty

tagTypeE :: (p ~ GhcPs, ?nms :: ExternalNames) => Direction -> LHsType GhcPs -> LHsExpr p -> LHsExpr p
tagTypeE :: forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction -> LHsType GhcPs -> LHsExpr p -> LHsExpr p
tagTypeE Direction
dir LHsType GhcPs
ty LHsExpr p
a
  = (?nms::ExternalNames) =>
SrcSpanAnnA -> LHsType GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
SrcSpanAnnA -> LHsType GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
sigE SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (LHsType GhcPs
forall p. (p ~ GhcPs, ?nms::ExternalNames) => LHsType GhcPs
tagTypeCon LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` LHsType GhcPs
ty LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` LHsType GhcPs
busType) LHsExpr p
LHsExpr GhcPs
a
  where
    busType :: LHsType GhcPs
busType = SrcSpanAnnA -> RdrName -> LHsType GhcPs
conT SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA (ExternalNames -> Direction -> RdrName
fwdAndBwdTypes ?nms::ExternalNames
ExternalNames
?nms Direction
dir) LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appTy` LHsType GhcPs
ty

constVar :: SrcSpanAnnA -> LHsExpr GhcPs
constVar :: SrcSpanAnnA -> LHsExpr GhcPs
constVar SrcSpanAnnA
loc = SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc (Name -> RdrName
thName 'const)

deepShowD :: Data.Data a => a -> String
deepShowD :: forall a. Data a => a -> [Char]
deepShowD a
a = Constr -> [Char]
forall a. Show a => a -> [Char]
show (a -> Constr
forall a. Data a => a -> Constr
Data.toConstr a
a) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
  -- " (" <> (unwords . fst) (SYB.gmapM (\x -> ([show $ Data.toConstr x], x)) a) <> ")"
  [Char]
" (" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ([[Char]] -> [Char]
unwords ([[Char]] -> [Char])
-> (([[Char]], a) -> [[Char]]) -> ([[Char]], a) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Char]], a) -> [[Char]]
forall a b. (a, b) -> a
fst) ((forall d. Data d => d -> ([[Char]], d)) -> a -> ([[Char]], a)
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a
SYB.gmapM (\d
x -> ([d -> [Char]
forall a. Data a => a -> [Char]
deepShowD d
x], d
x)) a
a) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
")"

unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: forall a. [a] -> Maybe ([a], a)
unsnoc [] = Maybe ([a], a)
forall a. Maybe a
Nothing
unsnoc [a
x] = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([], a
x)
unsnoc (a
x:[a]
xs) = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
a, a
b)
    where Just ([a]
a,a
b) = [a] -> Maybe ([a], a)
forall a. [a] -> Maybe ([a], a)
unsnoc [a]
xs

hsFunTy :: (p ~ GhcPs) => LHsType p -> LHsType p -> HsType p
hsFunTy :: forall p. (p ~ GhcPs) => LHsType p -> LHsType p -> HsType p
hsFunTy =
  XFunTy p
-> HsArrow p -> XRec p (HsType p) -> XRec p (HsType p) -> HsType p
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy p
EpAnn NoEpAnns
forall ann. EpAnn ann
noExt
#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 904
    (HsUnrestrictedArrow GHC.NormalSyntax)
#elif __GLASGOW_HASKELL__ >= 904
    (LHsUniToken "->" "\8594" p -> HsArrow p
forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow (LHsUniToken "->" "\8594" p -> HsArrow p)
-> LHsUniToken "->" "\8594" p -> HsArrow p
forall a b. (a -> b) -> a -> b
$ TokenLocation
-> HsUniToken "->" "\8594"
-> GenLocated TokenLocation (HsUniToken "->" "\8594")
forall l e. l -> e -> GenLocated l e
L TokenLocation
NoTokenLoc HsUniToken "->" "\8594"
forall (tok :: Symbol) (utok :: Symbol). HsUniToken tok utok
HsNormalTok)
#endif

arrTy :: p ~ GhcPs => LHsType p -> LHsType p -> LHsType p
arrTy :: forall p. (p ~ GhcPs) => LHsType p -> LHsType p -> LHsType p
arrTy LHsType p
a LHsType p
b = HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall p. (p ~ GhcPs) => LHsType p -> LHsType p -> HsType p
hsFunTy (PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
GHC.funPrec LHsType p
LHsType GhcPs
a) (PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
GHC.funPrec LHsType p
LHsType GhcPs
b)

varT :: SrcSpanAnnA -> String -> LHsType GhcPs
varT :: SrcSpanAnnA -> [Char] -> LHsType GhcPs
varT SrcSpanAnnA
loc [Char]
nm = SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt PromotionFlag
NotPromoted (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc ([Char] -> RdrName
tyVar [Char]
nm)))

conT :: SrcSpanAnnA -> GHC.RdrName -> LHsType GhcPs
conT :: SrcSpanAnnA -> RdrName -> LHsType GhcPs
conT SrcSpanAnnA
loc RdrName
nm = SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noExt PromotionFlag
NotPromoted (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc RdrName
nm))

-- perhaps this should happen on construction
gatherTypes
  :: p ~ GhcPs
  => PortDescription PortName
  -> CircuitM ()
gatherTypes :: forall p. (p ~ GhcPs) => PortDescription PortName -> CircuitM ()
gatherTypes = Getting
  (Traversed () CircuitM)
  (PortDescription PortName)
  (PortDescription PortName)
-> (PortDescription PortName -> CircuitM ())
-> PortDescription PortName
-> CircuitM ()
forall (f :: * -> *) r s a.
Functor f =>
Getting (Traversed r f) s a -> (a -> f r) -> s -> f ()
L.traverseOf_ Getting
  (Traversed () CircuitM)
  (PortDescription PortName)
  (PortDescription PortName)
forall a. Plated a => Fold a a
Fold (PortDescription PortName) (PortDescription PortName)
L.cosmos PortDescription PortName -> CircuitM ()
addTypes
  where
    addTypes :: PortDescription PortName -> CircuitM ()
addTypes = \case
      PortType LHsType GhcPs
ty (Ref (PortName SrcSpanAnnA
loc FastString
fs)) ->
        (UniqMap FastString (SrcSpanAnnA, LHsType GhcPs)
 -> Identity (UniqMap FastString (SrcSpanAnnA, LHsType GhcPs)))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
(UniqMap
   FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
 -> Identity
      (UniqMap
         FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))))
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(UniqMap FastString (SrcSpanAnnA, LHsType GhcPs)
 -> f (UniqMap FastString (SrcSpanAnnA, LHsType GhcPs)))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
portVarTypes ((UniqMap
    FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
  -> Identity
       (UniqMap
          FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))))
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> (UniqMap
      FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
    -> UniqMap
         FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs)))
-> CircuitM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= \UniqMap
  FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
pvt -> (Maybe (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
 -> Maybe (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs)))
-> UniqMap
     FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
-> FastString
-> UniqMap
     FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
forall k a.
Uniquable k =>
(Maybe a -> Maybe a) -> UniqMap k a -> k -> UniqMap k a
alterUniqMap (Maybe (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. a -> b -> a
const ((SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> Maybe a
Just (SrcSpanAnnA
loc, LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty))) UniqMap
  FastString (SrcSpanAnnA, GenLocated SrcSpanAnnA (HsType GhcPs))
pvt FastString
fs
      PortType LHsType GhcPs
ty PortDescription PortName
p -> ([(LHsType GhcPs, PortDescription PortName)]
 -> Identity [(LHsType GhcPs, PortDescription PortName)])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
([(GenLocated SrcSpanAnnA (HsType GhcPs),
   PortDescription PortName)]
 -> Identity
      [(GenLocated SrcSpanAnnA (HsType GhcPs),
        PortDescription PortName)])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
([(LHsType GhcPs, PortDescription nm)]
 -> f [(LHsType GhcPs, PortDescription nm)])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
portTypes (([(GenLocated SrcSpanAnnA (HsType GhcPs),
    PortDescription PortName)]
  -> Identity
       [(GenLocated SrcSpanAnnA (HsType GhcPs),
         PortDescription PortName)])
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> [(GenLocated SrcSpanAnnA (HsType GhcPs),
     PortDescription PortName)]
-> CircuitM ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [(LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty, PortDescription PortName
p)]
      PortDescription PortName
_             -> () -> CircuitM ()
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

tyEq :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyEq :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
tyEq LHsType GhcPs
a LHsType GhcPs
b =
#if __GLASGOW_HASKELL__ < 904
  noLoc $ HsOpTy noExtField a (noLoc eqTyCon_RDR) b
#else
  HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XOpTy GhcPs
-> PromotionFlag
-> LHsType GhcPs
-> LIdP GhcPs
-> LHsType GhcPs
-> HsType GhcPs
forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
noAnn PromotionFlag
NotPromoted LHsType GhcPs
a (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc RdrName
eqTyCon_RDR) LHsType GhcPs
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 :: forall p. (p ~ GhcPs, ?nms::ExternalNames) => CircuitM (LHsExpr p)
circuitQQExpM = do
  CircuitM ()
forall p. (p ~ GhcPs) => CircuitM ()
checkCircuit

  DynFlags
dflags <- CircuitM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
binds <- Getting
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> CircuitM
     [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
forall dec exp nm exp (f :: * -> *).
Functor f =>
([Binding exp nm] -> f [Binding exp nm])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitBinds
  [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
lets <- Getting
  [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> CircuitM [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall dec exp nm dec (f :: * -> *).
Functor f =>
([dec] -> f [dec])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitLets
  [GenLocated SrcSpanAnnA (Sig GhcPs)]
letTypes <- Getting
  [GenLocated SrcSpanAnnA (Sig GhcPs)]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [GenLocated SrcSpanAnnA (Sig GhcPs)]
-> CircuitM [GenLocated SrcSpanAnnA (Sig GhcPs)]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use ([LSig GhcPs]
 -> Const [GenLocated SrcSpanAnnA (Sig GhcPs)] [LSig GhcPs])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Const
     [GenLocated SrcSpanAnnA (Sig GhcPs)]
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
Getting
  [GenLocated SrcSpanAnnA (Sig GhcPs)]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [GenLocated SrcSpanAnnA (Sig GhcPs)]
forall dec exp nm (f :: * -> *).
Functor f =>
([LSig GhcPs] -> f [LSig GhcPs])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitTypes
  PortDescription PortName
slaves <- Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
-> CircuitM (PortDescription PortName)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitSlaves
  PortDescription PortName
masters <- Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
-> CircuitM (PortDescription PortName)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitMasters

  -- Construction of the circuit expression
  let decs :: [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
decs = [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
lets [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall a. Semigroup a => a -> a -> a
<> (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
 -> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
noLoc (HsBindLR GhcPs GhcPs
 -> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
    -> HsBindLR GhcPs GhcPs)
-> Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> Binding (LHsExpr GhcPs) PortName -> HsBindLR GhcPs GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags -> Binding (LHsExpr p) PortName -> HsBind p
decFromBinding DynFlags
dflags) [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
binds

  let pats :: LPat GhcPs
pats = DynFlags
-> Direction
-> PortDescription PortName
-> PortDescription PortName
-> LPat GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
DynFlags
-> Direction
-> PortDescription PortName
-> PortDescription PortName
-> LPat p
bindOutputs DynFlags
dflags Direction
Fwd PortDescription PortName
masters PortDescription PortName
slaves
      res :: LHsExpr GhcPs
res  = Direction
-> PortDescription PortName
-> PortDescription PortName
-> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
Direction
-> PortDescription PortName
-> PortDescription PortName
-> LHsExpr p
createInputs Direction
Bwd PortDescription PortName
slaves PortDescription PortName
masters

      body :: LHsExpr GhcPs
      body :: LHsExpr GhcPs
body = SrcSpanAnnA
-> [LSig GhcPs]
-> [LHsBind GhcPs]
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall p.
(p ~ GhcPs) =>
SrcSpanAnnA -> [LSig p] -> [LHsBind p] -> LHsExpr p -> LHsExpr p
letE SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
letTypes [LHsBind GhcPs]
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
decs LHsExpr GhcPs
res

  -- see [inference-helper]
  (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
 -> CircuitM ())
-> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> CircuitM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\(Binding GenLocated SrcSpanAnnA (HsExpr GhcPs)
_ PortDescription PortName
outs PortDescription PortName
ins) -> PortDescription PortName -> CircuitM ()
forall p. (p ~ GhcPs) => PortDescription PortName -> CircuitM ()
gatherTypes PortDescription PortName
outs CircuitM () -> CircuitM () -> CircuitM ()
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PortDescription PortName -> CircuitM ()
forall p. (p ~ GhcPs) => PortDescription PortName -> CircuitM ()
gatherTypes PortDescription PortName
ins)
    [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
binds
  (PortDescription PortName -> CircuitM ())
-> [PortDescription PortName] -> CircuitM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PortDescription PortName -> CircuitM ()
forall p. (p ~ GhcPs) => PortDescription PortName -> CircuitM ()
gatherTypes [PortDescription PortName
masters, PortDescription PortName
slaves]

  LHsExpr GhcPs -> CircuitM (LHsExpr GhcPs)
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr GhcPs -> CircuitM (LHsExpr GhcPs))
-> LHsExpr GhcPs -> CircuitM (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (?nms::ExternalNames) => SrcSpanAnnA -> LHsExpr GhcPs
SrcSpanAnnA -> LHsExpr GhcPs
circuitConstructor SrcSpanAnnA
forall ann. SrcAnn ann
noSrcSpanA LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE [LPat GhcPs
pats] LHsExpr GhcPs
body

grr :: MonadIO m => OccName.NameSpace -> m ()
grr :: forall (m :: * -> *). MonadIO m => NameSpace -> m ()
grr NameSpace
nm
  | NameSpace
nm NameSpace -> NameSpace -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace
OccName.tcName = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"tcName"
  | NameSpace
nm NameSpace -> NameSpace -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace
OccName.clsName = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"clsName"
  | NameSpace
nm NameSpace -> NameSpace -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace
OccName.tcClsName = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"tcClsName"
  | NameSpace
nm NameSpace -> NameSpace -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace
OccName.dataName = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"dataName"
  | NameSpace
nm NameSpace -> NameSpace -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace
OccName.varName = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"varName"
  | NameSpace
nm NameSpace -> NameSpace -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace
OccName.tvName = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"tvName"
  | Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"I dunno"

completeUnderscores :: (?nms :: ExternalNames) => CircuitM ()
completeUnderscores :: (?nms::ExternalNames) => CircuitM ()
completeUnderscores = do
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
binds <- Getting
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> CircuitM
     [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
forall dec exp nm exp (f :: * -> *).
Functor f =>
([Binding exp nm] -> f [Binding exp nm])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitBinds
  PortDescription PortName
masters <- Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
-> CircuitM (PortDescription PortName)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitMasters
  PortDescription PortName
slaves <- Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
-> CircuitM (PortDescription PortName)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
L.use Getting
  (PortDescription PortName)
  (CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName)
  (PortDescription PortName)
forall dec exp nm (f :: * -> *).
Functor f =>
(PortDescription nm -> f (PortDescription nm))
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitSlaves
  let addDef :: String -> PortDescription PortName -> CircuitM ()
      addDef :: [Char] -> PortDescription PortName -> CircuitM ()
addDef [Char]
suffix = \case
        Ref (PortName SrcSpanAnnA
loc (FastString -> [Char]
unpackFS -> name :: [Char]
name@(Char
'_':[Char]
_))) -> do
          let bind :: HsBindLR GhcPs GhcPs
bind = LPat GhcPs -> LHsExpr GhcPs -> HsBindLR GhcPs GhcPs
patBind (SrcSpanAnnA -> [Char] -> LPat GhcPs
varP SrcSpanAnnA
loc ([Char]
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
suffix)) (LHsExpr GhcPs -> LHsExpr GhcPs
forall p.
(p ~ GhcPs, ?nms::ExternalNames) =>
LHsExpr p -> LHsExpr p
tagE (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
loc (Name -> RdrName
thName 'def))
          ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
 -> Identity [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)])
-> CircuitState
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs))
     PortName
-> Identity
     (CircuitState
        (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
        (GenLocated SrcSpanAnnA (HsExpr GhcPs))
        PortName)
forall dec exp nm dec (f :: * -> *).
Functor f =>
([dec] -> f [dec])
-> CircuitState dec exp nm -> f (CircuitState dec exp nm)
circuitLets (([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
  -> Identity [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)])
 -> CircuitState
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs))
      PortName
 -> Identity
      (CircuitState
         (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs))
         PortName))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)] -> CircuitM ()
forall s (m :: * -> *) a.
(MonadState s m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= [SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBindLR GhcPs GhcPs
bind]

        PortDescription PortName
_ -> () -> CircuitM ()
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      addBind :: Binding exp PortName -> CircuitM ()
      addBind :: forall exp. Binding exp PortName -> CircuitM ()
addBind (Binding exp
_ PortDescription PortName
bOut PortDescription PortName
bIn) = do
        Getting
  (Traversed () CircuitM)
  (PortDescription PortName)
  (PortDescription PortName)
-> (PortDescription PortName -> CircuitM ())
-> PortDescription PortName
-> CircuitM ()
forall (f :: * -> *) r s a.
Functor f =>
Getting (Traversed r f) s a -> (a -> f r) -> s -> f ()
L.traverseOf_ Getting
  (Traversed () CircuitM)
  (PortDescription PortName)
  (PortDescription PortName)
forall a. Plated a => Fold a a
Fold (PortDescription PortName) (PortDescription PortName)
L.cosmos ([Char] -> PortDescription PortName -> CircuitM ()
addDef [Char]
"_Fwd") PortDescription PortName
bOut
        Getting
  (Traversed () CircuitM)
  (PortDescription PortName)
  (PortDescription PortName)
-> (PortDescription PortName -> CircuitM ())
-> PortDescription PortName
-> CircuitM ()
forall (f :: * -> *) r s a.
Functor f =>
Getting (Traversed r f) s a -> (a -> f r) -> s -> f ()
L.traverseOf_ Getting
  (Traversed () CircuitM)
  (PortDescription PortName)
  (PortDescription PortName)
forall a. Plated a => Fold a a
Fold (PortDescription PortName) (PortDescription PortName)
L.cosmos ([Char] -> PortDescription PortName -> CircuitM ()
addDef [Char]
"_Bwd") PortDescription PortName
bIn
  (Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
 -> CircuitM ())
-> [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
-> CircuitM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName
-> CircuitM ()
forall exp. Binding exp PortName -> CircuitM ()
addBind [Binding (GenLocated SrcSpanAnnA (HsExpr GhcPs)) PortName]
binds
  Binding Any PortName -> CircuitM ()
forall exp. Binding exp PortName -> CircuitM ()
addBind (Any
-> PortDescription PortName
-> PortDescription PortName
-> Binding Any PortName
forall exp l.
exp -> PortDescription l -> PortDescription l -> Binding exp l
Binding Any
forall a. HasCallStack => a
undefined PortDescription PortName
masters PortDescription PortName
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 :: (?nms::ExternalNames) =>
Bool -> Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
transform Bool
debug = GenericM Hsc -> GenericM Hsc
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
SYB.everywhereM ((GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a -> Hsc a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
SYB.mkM LHsExpr GhcPs -> Hsc (LHsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
transform') where
  transform' :: LHsExpr GhcPs -> GHC.Hsc (LHsExpr GhcPs)

  -- the circuit keyword directly applied (either with parenthesis or with BlockArguments)
  transform' :: LHsExpr GhcPs -> Hsc (LHsExpr GhcPs)
transform' (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_xapp (L SrcSpanAnnA
_ HsExpr GhcPs
circuitVar) LHsExpr GhcPs
lappB))
    | HsExpr GhcPs -> Bool
forall p. (p ~ GhcPs) => HsExpr p -> Bool
isCircuitVar HsExpr GhcPs
circuitVar = CircuitM (LHsExpr GhcPs) -> Hsc (LHsExpr GhcPs)
forall a. CircuitM a -> Hsc a
runCircuitM (CircuitM (LHsExpr GhcPs) -> Hsc (LHsExpr GhcPs))
-> CircuitM (LHsExpr GhcPs) -> Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ do
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
x <- LHsExpr GhcPs -> CircuitM ()
forall p. (p ~ GhcPs) => LHsExpr p -> CircuitM ()
parseCircuit LHsExpr GhcPs
lappB CircuitM () -> CircuitM () -> CircuitM ()
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CircuitM ()
(?nms::ExternalNames) => CircuitM ()
completeUnderscores CircuitM ()
-> CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CircuitM (LHsExpr GhcPs)
CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p. (p ~ GhcPs, ?nms::ExternalNames) => CircuitM (LHsExpr p)
circuitQQExpM
        Bool -> CircuitM () -> CircuitM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CircuitM () -> CircuitM ()) -> CircuitM () -> CircuitM ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> CircuitM ()
forall a. Outputable a => a -> CircuitM ()
ppr GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
        GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
x

  -- `circuit $` application
  transform' (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_xapp c :: LHsExpr GhcPs
c@(L SrcSpanAnnA
_ HsExpr GhcPs
circuitVar) (L SrcSpanAnnA
_ HsExpr GhcPs
infixVar) LHsExpr GhcPs
appR))
    | HsExpr GhcPs -> Bool
forall p. (p ~ GhcPs) => HsExpr p -> Bool
isDollar HsExpr GhcPs
infixVar Bool -> Bool -> Bool
&& HsExpr GhcPs -> Bool
dollarChainIsCircuit HsExpr GhcPs
circuitVar = do
        CircuitM (LHsExpr GhcPs) -> Hsc (LHsExpr GhcPs)
forall a. CircuitM a -> Hsc a
runCircuitM (CircuitM (LHsExpr GhcPs) -> Hsc (LHsExpr GhcPs))
-> CircuitM (LHsExpr GhcPs) -> Hsc (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ do
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
x <- LHsExpr GhcPs -> CircuitM ()
forall p. (p ~ GhcPs) => LHsExpr p -> CircuitM ()
parseCircuit LHsExpr GhcPs
appR CircuitM () -> CircuitM () -> CircuitM ()
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CircuitM ()
(?nms::ExternalNames) => CircuitM ()
completeUnderscores CircuitM ()
-> CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. CircuitM a -> CircuitM b -> CircuitM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CircuitM (LHsExpr GhcPs)
CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p. (p ~ GhcPs, ?nms::ExternalNames) => CircuitM (LHsExpr p)
circuitQQExpM
          Bool -> CircuitM () -> CircuitM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CircuitM () -> CircuitM ()) -> CircuitM () -> CircuitM ()
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> CircuitM ()
forall a. Outputable a => a -> CircuitM ()
ppr GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> CircuitM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> CircuitM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dollarChainReplaceCircuit LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x LHsExpr GhcPs
c)

  transform' LHsExpr GhcPs
e = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e

-- | check if circuit is applied via `a $ chain $ of $ dollars`.
dollarChainIsCircuit :: HsExpr GhcPs -> Bool
dollarChainIsCircuit :: HsExpr GhcPs -> Bool
dollarChainIsCircuit = \case
  HsVar XVar GhcPs
_ (L SrcSpanAnnN
_ RdrName
v)                             -> RdrName
v RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> RdrName
GHC.mkVarUnqual FastString
"circuit"
  OpApp XOpApp GhcPs
_xapp LHsExpr GhcPs
_appL (L SrcSpanAnnA
_ HsExpr GhcPs
infixVar) (L SrcSpanAnnA
_ HsExpr GhcPs
appR) -> HsExpr GhcPs -> Bool
forall p. (p ~ GhcPs) => HsExpr p -> Bool
isDollar HsExpr GhcPs
infixVar Bool -> Bool -> Bool
&& HsExpr GhcPs -> Bool
dollarChainIsCircuit HsExpr GhcPs
appR
  HsExpr GhcPs
_                                           -> Bool
False

-- | Replace the circuit if it's part of a chain of `$`.
dollarChainReplaceCircuit :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dollarChainReplaceCircuit :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dollarChainReplaceCircuit LHsExpr GhcPs
circuitExpr (L SrcSpanAnnA
loc HsExpr GhcPs
app) = case HsExpr GhcPs
app of
  HsVar XVar GhcPs
_ (L SrcSpanAnnN
_loc RdrName
v)
    -> if RdrName
v RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> RdrName
GHC.mkVarUnqual FastString
"circuit"
         then LHsExpr GhcPs
circuitExpr
         else [Char] -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. HasCallStack => [Char] -> a
error [Char]
"dollarChainAddCircuit: not a circuit"
  OpApp XOpApp GhcPs
xapp LHsExpr GhcPs
appL (L SrcSpanAnnA
infixLoc HsExpr GhcPs
infixVar) LHsExpr GhcPs
appR
    -> SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
xapp LHsExpr GhcPs
appL (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
infixLoc HsExpr GhcPs
infixVar) (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dollarChainReplaceCircuit LHsExpr GhcPs
circuitExpr LHsExpr GhcPs
appR)
  HsExpr GhcPs
t -> [Char] -> LHsExpr GhcPs
forall a. HasCallStack => [Char] -> a
error ([Char] -> LHsExpr GhcPs) -> [Char] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ [Char]
"dollarChainAddCircuit unhandled case " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> HsExpr GhcPs -> [Char]
forall a. Data a => a -> [Char]
showC HsExpr GhcPs
t

-- | The plugin for circuit notation.
plugin :: GHC.Plugin
plugin :: Plugin
plugin = ExternalNames -> Plugin
mkPlugin ExternalNames
defExternalNames

-- | Make a plugin with custom external names
mkPlugin :: ExternalNames -> GHC.Plugin
mkPlugin :: ExternalNames -> Plugin
mkPlugin ExternalNames
nms = Plugin
GHC.defaultPlugin
  { GHC.parsedResultAction = let ?nms = nms in pluginImpl
    -- Mark plugin as 'pure' to prevent recompilations.
  , GHC.pluginRecompile = \[[Char]]
_cliOptions -> PluginRecompile -> IO PluginRecompile
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PluginRecompile
GHC.NoForceRecompile
  }

warningMsg :: Outputable.SDoc -> GHC.Hsc ()
warningMsg :: SDoc -> Hsc ()
warningMsg SDoc
sdoc = do
  DynFlags
dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
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
logger <- Hsc Logger
forall (m :: * -> *). HasLogger m => m Logger
GHC.getLogger
  let
    diagOpts :: DiagOpts
diagOpts = DynFlags -> DiagOpts
GHC.initDiagOpts DynFlags
dflags
    mc :: MessageClass
mc = DiagOpts
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
Err.mkMCDiagnostic DiagOpts
diagOpts DiagnosticReason
GHC.WarningWithoutFlag
#if __GLASGOW_HASKELL__ >= 906
           Maybe DiagnosticCode
forall a. Maybe a
Nothing
#endif
  IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
GHC.logMsg Logger
logger MessageClass
mc SrcSpan
noSrcSpan SDoc
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 :: (?nms::ExternalNames) =>
[[Char]] -> ModSummary -> ParsedResult -> Hsc ParsedResult
pluginImpl [[Char]]
cliOptions ModSummary
_modSummary ParsedResult
m = do
    -- cli options are activated by -fplugin-opt=CircuitNotation:debug
    Bool
debug <- case [[Char]]
cliOptions of
      []        -> Bool -> Hsc Bool
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      [[Char]
"debug"] -> Bool -> Hsc Bool
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      [[Char]]
_ -> do
        SDoc -> Hsc ()
warningMsg (SDoc -> Hsc ()) -> SDoc -> Hsc ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
Outputable.text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char]
"CircuitNotation: unknown cli options " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
cliOptions
        Bool -> Hsc Bool
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Located (HsModule GhcPs)
hpm_module' <- do
#if __GLASGOW_HASKELL__ < 904
      transform debug (GHC.hpm_module m)
    let module' = m { GHC.hpm_module = hpm_module' }
#else
      (?nms::ExternalNames) =>
Bool -> Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
Bool -> Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
transform Bool
debug (Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs)))
-> Located (HsModule GhcPs) -> Hsc (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ HsParsedModule -> Located (HsModule GhcPs)
GHC.hpm_module (HsParsedModule -> Located (HsModule GhcPs))
-> HsParsedModule -> Located (HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$ ParsedResult -> HsParsedModule
GHC.parsedResultModule ParsedResult
m
    let parsedResultModule' :: HsParsedModule
parsedResultModule' = (ParsedResult -> HsParsedModule
GHC.parsedResultModule ParsedResult
m)
                                { GHC.hpm_module = hpm_module' }
        module' :: ParsedResult
module' = ParsedResult
m { GHC.parsedResultModule = parsedResultModule' }
#endif
    ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return ParsedResult
module'

-- Debugging functions -------------------------------------------------

ppr :: GHC.Outputable a => a -> CircuitM ()
ppr :: forall a. Outputable a => a -> CircuitM ()
ppr a
a = do
  DynFlags
dflags <- CircuitM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  IO () -> CircuitM ()
forall a. IO a -> CircuitM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CircuitM ()) -> IO () -> CircuitM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn (DynFlags -> a -> [Char]
forall a. Outputable a => DynFlags -> a -> [Char]
GHC.showPpr DynFlags
dflags a
a)

showC :: Data.Data a => a -> String
showC :: forall a. Data a => a -> [Char]
showC a
a = TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Constr -> [Char]
forall a. Show a => a -> [Char]
show (a -> Constr
forall a. Data a => a -> Constr
Data.toConstr a
a)

-- Names ---------------------------------------------------------------

fwdNames :: [String]
fwdNames :: [[Char]]
fwdNames = [[Char]
"Fwd", [Char]
"Signal"]

-- | Collection of names external to circuit-notation.
data ExternalNames = ExternalNames
  { ExternalNames -> RdrName
circuitCon :: GHC.RdrName
  , ExternalNames -> RdrName
runCircuitName :: GHC.RdrName
  , ExternalNames -> RdrName
tagBundlePat :: GHC.RdrName
  , ExternalNames -> RdrName
tagName :: GHC.RdrName
  , ExternalNames -> RdrName
tagTName :: GHC.RdrName
  , ExternalNames -> RdrName
fwdBwdCon :: GHC.RdrName
  , ExternalNames -> Direction -> RdrName
fwdAndBwdTypes :: Direction -> GHC.RdrName
  , ExternalNames -> RdrName
trivialBwd :: GHC.RdrName
  , ExternalNames -> RdrName
consPat :: GHC.RdrName
  }

defExternalNames :: ExternalNames
defExternalNames :: ExternalNames
defExternalNames = ExternalNames
  { circuitCon :: RdrName
circuitCon = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkDataOcc [Char]
"TagCircuit")
  , runCircuitName :: RdrName
runCircuitName = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkVarOcc [Char]
"runTagCircuit")
  , tagBundlePat :: RdrName
tagBundlePat = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkDataOcc [Char]
"BusTagBundle")
  , tagName :: RdrName
tagName = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkDataOcc [Char]
"BusTag")
  , tagTName :: RdrName
tagTName = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkTcOcc [Char]
"BusTag")
  , fwdBwdCon :: RdrName
fwdBwdCon = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkDataOcc [Char]
":->")
  , fwdAndBwdTypes :: Direction -> RdrName
fwdAndBwdTypes = \case
      Direction
Fwd -> OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkTcOcc [Char]
"Fwd")
      Direction
Bwd -> OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkTcOcc [Char]
"Bwd")
  , trivialBwd :: RdrName
trivialBwd = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkVarOcc [Char]
"unitBwd")
#if __GLASGOW_HASKELL__ > 900
  , consPat :: RdrName
consPat = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkDataOcc [Char]
":>!")
#else
  , consPat = GHC.Unqual (OccName.mkDataOcc ":>")
#endif
  }