{-
 ██████╗██╗██████╗  ██████╗██╗   ██╗██╗████████╗███████╗
██╔════╝██║██╔══██╗██╔════╝██║   ██║██║╚══██╔══╝██╔════╝
██║     ██║██████╔╝██║     ██║   ██║██║   ██║   ███████╗
██║     ██║██╔══██╗██║     ██║   ██║██║   ██║   ╚════██║
╚██████╗██║██║  ██║╚██████╗╚██████╔╝██║   ██║   ███████║
 ╚═════╝╚═╝╚═╝  ╚═╝ ╚═════╝ ╚═════╝ ╚═╝   ╚═╝   ╚══════╝
  (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 #-}
{-# 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)
import           System.IO.Unsafe
import           Data.Typeable

-- ghc
import qualified Language.Haskell.TH    as TH
import qualified GHC

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

import           GHC.Data.Bag
import           GHC.Data.FastString       (mkFastString, unpackFS)
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

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
#if __GLASGOW_HASKELL__ < 910
import qualified GHC.Parser.PostProcess       as GHC
#else
import GHC.Parser.PostProcess () -- instances
#endif

import qualified GHC.ThToHs             as Convert
import           GHC.Hs
  hiding (locA)

import           GHC.Builtin.Types      (eqTyCon_RDR)

import "ghc" GHC.Types.Unique.Map

#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
import           Control.Monad.State

-- 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__ < 910
type MsgDoc = Outputable.SDoc

locA :: SrcAnn a -> SrcSpan
locA = GHC.locA

noAnnSortKey :: AnnSortKey
noAnnSortKey = NoAnnSortKey
#else
type MsgDoc = Outputable.SDoc

locA :: EpAnn a -> SrcSpan
locA :: forall a. EpAnn a -> SrcSpan
locA = EpAnn a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
GHC.locA

noAnnSortKey :: AnnSortKey a
noAnnSortKey :: forall a. AnnSortKey a
noAnnSortKey = AnnSortKey a
forall a. AnnSortKey a
NoAnnSortKey
#endif

type ErrMsg = Err.MsgEnvelope GHC.GhcMessage

sevFatal :: Err.MessageClass
sevFatal :: MessageClass
sevFatal = MessageClass
Err.MCFatal

#if __GLASGOW_HASKELL__ >= 910
noExt :: NoAnn a => a
noExt :: forall a. NoAnn a => a
noExt = a
forall a. NoAnn a => a
noAnn
#else
noExt :: EpAnn ann
noExt = EpAnnNotUsed
#endif

#if __GLASGOW_HASKELL__ < 910
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

type PrintUnqualified = Outputable.NamePprCtx

mkErrMsg :: GHC.DynFlags -> SrcSpan -> PrintUnqualified -> Outputable.SDoc -> ErrMsg
-- 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

mkLongErrMsg :: GHC.DynFlags -> SrcSpan -> PrintUnqualified -> Outputable.SDoc -> Outputable.SDoc -> ErrMsg
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]

-- 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 e. HasAnnotation e => e
noSrcSpanA
        }
  (a, 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 = 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
  unless (isEmptyBag errs) $ liftIO . throwIO $ GHC.mkSrcErr $ Err.mkMessages errs
  pure a

mkLocMessage :: Err.MessageClass -> SrcSpan -> Outputable.SDoc -> Outputable.SDoc
mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage = MessageClass -> SrcSpan -> SDoc -> SDoc
Err.mkLocMessage

errM :: SrcSpan -> String -> CircuitM ()
errM :: SrcSpan -> [Char] -> CircuitM ()
errM SrcSpan
loc [Char]
msg = do
  dflags <- CircuitM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  let errMsg = MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
sevFatal SrcSpan
loc ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
Outputable.text [Char]
msg)
  cErrors %= consBag (mkErrMsg dflags loc Outputable.alwaysQualify errMsg)

-- ghc helpers ---------------------------------------------------------

-- It's very possible that most of these are already in the ghc library in some form. It's not the
-- easiest library to discover these kind of functions.

conPatIn :: GenLocated SrcSpanAnnN GHC.RdrName -> HsConPatDetails GhcPs -> Pat GhcPs
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 [AddEpAnn]
XConPat GhcPs
forall a. NoAnn a => a
noExt XRec GhcPs (ConLikeP GhcPs)
GenLocated SrcSpanAnnN RdrName
loc HsConPatDetails GhcPs
con

#if __GLASGOW_HASKELL__ >= 910
noEpAnn :: NoAnn ann => GenLocated SrcSpan e -> GenLocated (EpAnn ann) e
noEpAnn :: forall ann e.
NoAnn ann =>
GenLocated SrcSpan e -> GenLocated (EpAnn ann) e
noEpAnn (L SrcSpan
l e
e) = EpAnn ann -> e -> GenLocated (EpAnn ann) e
forall l e. l -> e -> GenLocated l e
L (Anchor -> ann -> EpAnnComments -> EpAnn ann
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> Anchor
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor SrcSpan
l) ann
forall a. NoAnn a => a
noAnn EpAnnComments
emptyComments) e
e

noLoc :: NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc :: forall ann e. NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc = GenLocated SrcSpan e -> GenLocated (EpAnn ann) e
forall ann e.
NoAnn ann =>
GenLocated SrcSpan e -> GenLocated (EpAnn ann) e
noEpAnn (GenLocated SrcSpan e -> GenLocated (EpAnn ann) e)
-> (e -> GenLocated SrcSpan e) -> e -> GenLocated (EpAnn ann) e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> GenLocated SrcSpan e
forall e. e -> Located e
GHC.noLoc
#else
noEpAnn :: GenLocated SrcSpan e -> GenLocated (SrcAnn ann) e
noEpAnn (L l e) = L (SrcSpanAnn noExt l) e

noLoc :: e -> GenLocated (SrcAnn ann) e
noLoc = noEpAnn . 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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 [AddEpAnn]
XTuplePat GhcPs
forall a. NoAnn a => a
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__ < 910
  as -> L srcLoc $ ParPat noExt pL (go as) pR
  where
  pL = L (GHC.mkTokenLocation $ locA srcLoc) HsTok
  pR = L (GHC.mkTokenLocation $ locA srcLoc) HsTok
#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 -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat (EpToken "("
pL,EpToken ")"
pR) ([LPat GhcPs] -> LPat GhcPs
go [LPat GhcPs]
as)
  where
  pL :: EpToken "("
pL = Anchor -> EpToken "("
forall (tok :: Symbol). Anchor -> EpToken tok
EpTok (Anchor -> EpToken "(") -> Anchor -> EpToken "("
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Anchor
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. EpAnn a -> SrcSpan
locA SrcSpanAnnA
srcLoc
  pR :: EpToken ")"
pR = Anchor -> EpToken ")"
forall (tok :: Symbol). Anchor -> EpToken tok
EpTok (Anchor -> EpToken ")") -> Anchor -> EpToken ")"
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Anchor
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. EpAnn a -> SrcSpan
locA SrcSpanAnnA
srcLoc
#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 l1 :: SrcSpanAnnN
l1 = SrcSpanAnnA
l0 SrcSpanAnnA -> SrcSpanAnnN -> SrcSpanAnnN
forall a b. a -> b -> b
`seq` SrcSpanAnnN
forall e. HasAnnotation e => e
noSrcSpanA
    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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 [AddEpAnn]
XLazyPat GhcPs
forall a. NoAnn a => a
noExt LPat GhcPs
lpat)

hsBoxedTuple :: GHC.HsTupleSort
hsBoxedTuple :: HsTupleSort
hsBoxedTuple = HsTupleSort
HsBoxedOrConstraintTuple

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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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
AnnParen
forall a. NoAnn a => a
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
AnnParen
forall a. NoAnn a => a
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
AnnParen
forall a. NoAnn a => a
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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 e. HasAnnotation e => e
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
#if __GLASGOW_HASKELL__ >= 910
  XApp GhcPs
NoExtField
noExtField
#else
  noAnn
#endif
  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 ann e. NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc RdrName
rdr))

parenE :: LHsExpr GhcPs -> LHsExpr GhcPs
#if __GLASGOW_HASKELL__ < 910
parenE e@(L l _) = L l (HsPar noExt pL e pR)
  where
  pL = L (GHC.mkTokenLocation $ locA l) HsTok
  pR = L (GHC.mkTokenLocation $ locA l) HsTok
#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 -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar (EpToken "("
pL,EpToken ")"
pR) LHsExpr GhcPs
e)
  where
  pL :: EpToken "("
pL = Anchor -> EpToken "("
forall (tok :: Symbol). Anchor -> EpToken tok
EpTok (Anchor -> EpToken "(") -> Anchor -> EpToken "("
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Anchor
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. EpAnn a -> SrcSpan
locA SrcSpanAnnA
l
  pR :: EpToken ")"
pR = Anchor -> EpToken ")"
forall (tok :: Symbol). Anchor -> EpToken tok
EpTok (Anchor -> EpToken ")") -> Anchor -> EpToken ")"
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Anchor
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. EpAnn a -> SrcSpan
locA SrcSpanAnnA
l
#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
#if __GLASGOW_HASKELL__ >= 912
    noExtField
#else
    XOpApp GhcPs
forall a. NoAnn a => a
noExt
#endif
    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 [AddEpAnn]
XExplicitTuple GhcPs
forall a. NoAnn a => a
noExt [HsTupArg GhcPs]
tupArgs Boxity
GHC.Boxed
  where
    tupArgs :: [HsTupArg GhcPs]
tupArgs = (LHsExpr GhcPs -> HsTupArg GhcPs)
-> [LHsExpr GhcPs] -> [HsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map
#if __GLASGOW_HASKELL__ >= 910
      (XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcPs
NoExtField
noExtField)
#else
      (Present noAnn)
#endif
      [LHsExpr p]
[LHsExpr GhcPs]
elems

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
genLocName :: SrcSpanAnnA -> ShowS
genLocName (SrcSpanAnnA -> SrcSpan
forall a. EpAnn a -> SrcSpan
locA -> GHC.RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_) [Char]
prefix =
  [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__ < 910
  HsLam _ (MG _x alts) <- Just expr
#else
  HsLam _ _ (MG _x alts) <- HsExpr GhcPs -> Maybe (HsExpr GhcPs)
forall a. a -> Maybe a
Just HsExpr GhcPs
expr
#endif
#if __GLASGOW_HASKELL__ >= 912
  L _ [L _ (Match _matchX _matchContext (L _ matchPats) matchGr)] <- Just alts
#else
  L _ [L _ (Match _matchX _matchContext matchPats matchGr)] <- Just alts
#endif
  GRHSs _grX grHss _grLocalBinds <- Just matchGr
  [L _ (GRHS _ _ body)] <- Just grHss
  Just (matchPats, body)

-- | Create a simple let binding.
letE
  :: p ~ GhcPs
  => SrcSpanAnnA
  -- ^ location for top level let bindings
  -> [LSig p]
  -- ^ type signatures
  -> [LHsBind p]
  -- ^ let bindings
  -> LHsExpr p
  -- ^ final `in` expressions
  -> LHsExpr p
letE :: 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__ < 908
    L loc (HsLet noExt tkLet localBinds tkIn expr)
#elif __GLASGOW_HASKELL__ < 910
    L loc (HsLet noExt tkLet localBinds tkIn expr)
#else
    SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XLet GhcPs
-> HsLocalBindsLR GhcPs GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet (EpToken "let"
tkLet,EpToken "in"
tkIn) HsLocalBindsLR GhcPs GhcPs
localBinds LHsExpr p
LHsExpr GhcPs
expr)
#endif
  where
    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
SrcSpanAnnL
forall a. NoAnn a => a
noExt HsValBindsLR GhcPs GhcPs
valBinds

#if __GLASGOW_HASKELL__ >= 910
    tkLet :: EpToken "let"
tkLet = Anchor -> EpToken "let"
forall (tok :: Symbol). Anchor -> EpToken tok
EpTok (Anchor -> EpToken "let") -> Anchor -> EpToken "let"
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Anchor
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. EpAnn a -> SrcSpan
locA SrcSpanAnnA
loc
    tkIn :: EpToken "in"
tkIn  = Anchor -> EpToken "in"
forall (tok :: Symbol). Anchor -> EpToken tok
EpTok (Anchor -> EpToken "in") -> Anchor -> EpToken "in"
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Anchor
forall a. SrcSpan -> EpaLocation' a
spanAsAnchor (SrcSpan -> Anchor) -> SrcSpan -> Anchor
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> SrcSpan
forall a. EpAnn a -> SrcSpan
locA SrcSpanAnnA
loc
#else
    tkLet = L (GHC.mkTokenLocation $ locA loc) HsTok
    tkIn  = L (GHC.mkTokenLocation $ locA loc) 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 BindTag
forall a. AnnSortKey a
noAnnSortKey LHsBindsLR GhcPs GhcPs
hsBinds [LSig p]
[LSig GhcPs]
sigs

    hsBinds :: LHsBindsLR GhcPs GhcPs
#if __GLASGOW_HASKELL__ >= 912
    hsBinds = binds
#else
    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
#endif

-- | 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 =
#if __GLASGOW_HASKELL__ >= 910
    HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall ann e. NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLam GhcPs
-> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p.
XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam [AddEpAnn]
XLam GhcPs
forall a. NoAnn a => a
noExt HsLamVariant
LamSingle MatchGroup GhcPs (LHsExpr GhcPs)
MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mg
#else
    noLoc $ HsLam noExtField mg
#endif
  where
    mg :: MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
#if __GLASGOW_HASKELL__ < 908
    mg = MG GHC.Generated matches
#elif __GLASGOW_HASKELL__ < 910
    mg = MG (GHC.Generated GHC.DoPmc) matches
#else
    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 (GenReason -> DoPmc -> Origin
GHC.Generated GenReason
GHC.OtherExpansion DoPmc
GHC.DoPmc) XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches
#endif

#if __GLASGOW_HASKELL__ >= 912
    matches :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
    matches = noLoc [singleMatch]
#else
    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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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]
#endif

    singleMatch :: GenLocated SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
#if __GLASGOW_HASKELL__ >= 912
    singleMatch = noLoc $ Match noExtField (LamAlt LamSingle) (L (EpaSpan noSrcSpan) pats) grHss
#elif __GLASGOW_HASKELL__ >= 910
    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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 (LIdP (NoGhcTc GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCMatch p body
-> HsMatchContext (LIdP (NoGhcTc p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match [AddEpAnn]
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. NoAnn a => a
noExt (HsLamVariant -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
LamSingle) [LPat GhcPs]
pats GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grHss
#else
    singleMatch = noLoc $ Match noExt LambdaExpr pats grHss
#endif

    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
$
      (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExtField
noExtField)

    grHs :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    grHs :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
grHs =  EpAnnCO
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L EpAnnCO
forall e. HasAnnotation e => e
noSrcSpanA (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     EpAnnCO (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 a. NoAnn a => a
noExt [] LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr

-- | 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
          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

          -- 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. EpAnn 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
  LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
_xlet HsLocalBindsLR GhcPs GhcPs
letBind ->
    -- 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
#if __GLASGOW_HASKELL__ >= 912
        circuitLets <>= valBinds
#else
        ([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
#endif
        ([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. EpAnn 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
  BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LPat GhcPs
bind LHsExpr GhcPs
body ->
    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. EpAnn 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
  ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ (GHC.Unqual OccName
occ)) (PrefixCon [] [LPat GhcPs
lpat])
    | 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
  ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ RdrName
rdr) HsConPatDetails GhcPs
_
    | 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 []
  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)
  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. EpAnn 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
    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
    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
  ExplicitList XExplicitList GhcPs
_ [LHsExpr GhcPs]
exprs ->
    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
  -- XXX: Untested?
  HsProc XProc GhcPs
_ LPat GhcPs
_ (L EpAnnCO
_ (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')

  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. EpAnn 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
    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
        }]

    HsExpr GhcPs
_ -> case Maybe (PortDescription PortName)
mInput of
      Maybe (PortDescription PortName)
Nothing -> SrcSpan -> [Char] -> CircuitM ()
errM (SrcSpanAnnA -> SrcSpan
forall a. EpAnn 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
  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
  masters <- L.use circuitMasters
  binds <- L.use circuitBinds

  let 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
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
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 = 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 = (([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

  duplicateMasters <- concat <$> forM (nonDetUniqMapToList 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. EpAnn 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. EpAnn 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. EpAnn 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 = \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
  circuitSlaves %= L.transform modifyMulticast
  circuitMasters %= L.transform modifyMulticast
  circuitBinds . L.mapped %= \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 e. HasAnnotation e => e
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. EpAnn 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
  -- XXX: propagate location
  FwdExpr (L SrcSpanAnnA
_ HsExpr GhcPs
_) -> LPat p
LPat GhcPs
nlWildPat
  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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 e. HasAnnotation e => e
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 e. HasAnnotation e => e
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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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
#if __GLASGOW_HASKELL__ >= 912
  noExtField
#else
  [AddEpAnn]
XOpApp GhcPs
forall a. NoAnn a => a
noExt
#endif
  LHsExpr GhcPs
s2m (SrcSpanAnnA -> RdrName -> LHsExpr GhcPs
varE SrcSpanAnnA
forall e. HasAnnotation e => e
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 e. HasAnnotation e => e
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 =
#if __GLASGOW_HASKELL__ < 910
  PatBind noExt lhs rhs
#else
  XPatBind GhcPs GhcPs
-> LPat GhcPs
-> HsMultAnn GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
-> HsBindLR GhcPs GhcPs
forall idL idR.
XPatBind idL idR
-> LPat idL
-> HsMultAnn idL
-> GRHSs idR (LHsExpr idR)
-> HsBindLR idL idR
PatBind XPatBind GhcPs GhcPs
NoExtField
noExtField LPat GhcPs
lhs (XNoMultAnn GhcPs -> HsMultAnn GhcPs
forall pass. XNoMultAnn pass -> HsMultAnn pass
HsNoMultAnn NoExtField
XNoMultAnn GhcPs
noExtField) GRHSs GhcPs (LHsExpr GhcPs)
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rhs
#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
$
      XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExtField
noExtField

    gr :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    gr :: LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
gr =  EpAnnCO
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnnCO
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated 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 a. NoAnn a => a
noExt [] LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr)

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)


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

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 ann e. NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc (GenLocated SrcSpanAnnN RdrName
-> HsConPatDetails GhcPs -> Pat GhcPs
conPatIn (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated (EpAnn 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 e. HasAnnotation e => e
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 ann e. NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc (GenLocated SrcSpanAnnN RdrName
-> HsConPatDetails GhcPs -> Pat GhcPs
conPatIn (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated (EpAnn 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 e. HasAnnotation e => e
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 ann e. NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc (XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar [AddEpAnn]
XTyVar GhcPs
forall a. NoAnn a => a
noExt PromotionFlag
NotPromoted (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated (EpAnn 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
$
    XSigPat GhcPs
-> LPat GhcPs -> HsPatSigType (NoGhcTc GhcPs) -> Pat GhcPs
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat [AddEpAnn]
XSigPat GhcPs
forall a. NoAnn a => a
noExt LPat p
LPat GhcPs
a (XHsPS GhcPs -> LHsType GhcPs -> HsPatSigType GhcPs
forall pass. XHsPS pass -> LHsType pass -> HsPatSigType pass
HsPS XHsPS GhcPs
EpAnnCO
forall a. NoAnn a => a
noExt LHsType GhcPs
ty)

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
$
    XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig [AddEpAnn]
XExprWithTySig GhcPs
forall a. NoAnn a => a
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))

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 e. HasAnnotation e => e
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 e. HasAnnotation e => e
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 e. HasAnnotation e => e
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 e. HasAnnotation e => e
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 =
#if __GLASGOW_HASKELL__ >= 910
    XFunTy p -> HsArrow p -> LHsType p -> LHsType p -> HsType p
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy p
NoExtField
noExtField (XUnrestrictedArrow p -> HsArrow p
forall pass. XUnrestrictedArrow pass -> HsArrow pass
HsUnrestrictedArrow EpUniToken "->" "\8594"
XUnrestrictedArrow p
forall a. NoAnn a => a
noAnn)
#else
    HsFunTy noExt (HsUnrestrictedArrow $ L NoTokenLoc 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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 [AddEpAnn]
XTyVar GhcPs
forall a. NoAnn a => a
noExt PromotionFlag
NotPromoted (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated (EpAnn 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 [AddEpAnn]
XTyVar GhcPs
forall a. NoAnn a => a
noExt PromotionFlag
NotPromoted (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated (EpAnn 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 =
  HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall ann e. NoAnn ann => e -> GenLocated (EpAnn 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
#if __GLASGOW_HASKELL__ >= 912
    noExtField
#else
    [AddEpAnn]
XOpTy GhcPs
forall a. NoAnn a => a
noExt
#endif
    PromotionFlag
NotPromoted LHsType GhcPs
a (RdrName -> GenLocated SrcSpanAnnN RdrName
forall ann e. NoAnn ann => e -> GenLocated (EpAnn ann) e
noLoc RdrName
eqTyCon_RDR) LHsType GhcPs
b
-- eqTyCon is a special name that has to be exactly correct for ghc to recognise it.

-- 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

  dflags <- CircuitM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  binds <- L.use circuitBinds
  lets <- L.use circuitLets
  letTypes <- L.use circuitTypes
  slaves <- L.use circuitSlaves
  masters <- L.use circuitMasters

  -- Construction of the circuit expression
  let decs = [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 ann e. NoAnn ann => e -> GenLocated (EpAnn 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 = 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  = 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 = 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 e. HasAnnotation e => e
noSrcSpanA [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
letTypes [LHsBind GhcPs]
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
decs LHsExpr GhcPs
res

  -- see [inference-helper]
  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)
    binds
  mapM_ gatherTypes [masters, slaves]

  pure $ circuitConstructor noSrcSpanA `appE` lamE [pats] 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
  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
  masters <- L.use circuitMasters
  slaves <- L.use circuitSlaves
  let addDef :: String -> 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 (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
  mapM_ addBind binds
  addBind (Binding undefined masters slaves)


-- | Transform declarations in the module by converting circuit blocks.
transform
    :: (?nms :: ExternalNames)
    => Bool
    -> GHC.Located (HsModule GhcPs)
    -> GHC.Hsc (GHC.Located (HsModule GhcPs))
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
        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
        when debug $ ppr x
        pure 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
          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
          when debug $ ppr x
          pure (dollarChainReplaceCircuit x 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
  dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  logger <- GHC.getLogger
  let
    diagOpts = DynFlags -> DiagOpts
GHC.initDiagOpts DynFlags
dflags
    mc = DiagOpts
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
Err.mkMCDiagnostic DiagOpts
diagOpts DiagnosticReason
GHC.WarningWithoutFlag
           Maybe DiagnosticCode
forall a. Maybe a
Nothing
  liftIO $ GHC.logMsg logger mc noSrcSpan sdoc

-- | The actual implementation.
pluginImpl ::
  (?nms :: ExternalNames) => [GHC.CommandLineOption] -> GHC.ModSummary ->
  GHC.ParsedResult -> GHC.Hsc GHC.ParsedResult
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
    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
    hpm_module' <- do
      transform debug $ GHC.hpm_module $ GHC.parsedResultModule m
    let parsedResultModule' = (ParsedResult -> HsParsedModule
GHC.parsedResultModule ParsedResult
m)
                                { GHC.hpm_module = hpm_module' }
        module' = ParsedResult
m { GHC.parsedResultModule = parsedResultModule' }
    return module'

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

ppr :: GHC.Outputable a => a -> CircuitM ()
ppr :: forall a. Outputable a => a -> CircuitM ()
ppr a
a = do
  dflags <- CircuitM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
GHC.getDynFlags
  liftIO $ putStrLn (GHC.showPpr dflags 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")
  , consPat :: RdrName
consPat = OccName -> RdrName
GHC.Unqual ([Char] -> OccName
OccName.mkDataOcc [Char]
":>!")
  }