    {-|

    This module can automatically generate TopEntity definitions from "Clash.NamedTypes"
    annotations. Annotations involving data\/type families must be inspected for correctness.
    Not all cases can be handled with automatic generation due to the difficulty of type manipulation
    in template Haskell. In particular annotations __inside__ the following is unlikely to work:

    - Data\/type family referencing other data\/type families.
    - Annotations inside recursive data types
    - Clock constraints other than a single HiddenClockResetEnable. (You can still
      use arbitrary explicit clock\/reset\/enables!)

    See <https://github.com/clash-lang/clash-compiler/blob/master/clash-prelude/tests/Clash/Tests/TopEntityGeneration.hs Clash.Tests.TopEntityGeneration>
    for more examples.

    @
    import Clash.Annotations.TH

    data Named
      = Named
      { name1 :: "named1" ::: BitVector 3
      , name2 :: "named2" ::: BitVector 5
      }

    topEntity :: "tup1" ::: Signal System (Int, Bool)
              -> "tup2" ::: (Signal System Int, Signal System Bool)
              -> "tup3" ::: Signal System ("int":::Int, "bool":::Bool)
              -> "tup4" ::: ("int":::Signal System Int, "bool":::Signal System Bool)
              -> "custom" ::: Signal System Named
              -> "outTup" ::: Signal System ("outint":::Int, "outbool":::Bool)
    topEntity = undefined
    makeTopEntity 'topEntity
    -- ===>
    --  {-# ANN topEntity Synthesize "topEntity3"
    --     [ PortName "tup1"
    --     , PortName "tup2"
    --     , PortProduct "tup3" [PortName "int",PortName "bool"]
    --     , PortProduct "tup4" [PortName "int",PortName "bool"]
    --     , PortProduct "custom" [PortName "named1",PortName "named2"]
    --     ]
    --     (PortProduct "outTup" [PortName "outint",PortName "outbool"])
    --     #-}
    @

    -}

    {-# OPTIONS_GHC -fno-warn-orphans #-}
    -- Required to 'makeBaseFunctor' of 'Language.Haskell.TH.Syntax.Type'

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE PatternSynonyms #-}
    {-# LANGUAGE PolyKinds #-}
    {-# LANGUAGE StandaloneDeriving #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeFamilies #-}

    module Clash.Annotations.TH
      ( -- * To create a Synthesize annotation pragma
        makeTopEntity
      , makeTopEntityWithName
      , makeTopEntityWithName'
        -- * To create a TopEntity value
      , buildTopEntity
      , maybeBuildTopEntity
      , getNameBinding
      )
    where

    import           Data.Foldable                  ( fold)
    import qualified Data.Set                      as Set
    import qualified Data.Map                      as Map
    import           Data.Maybe                     ( catMaybes )
    import           Language.Haskell.TH

    import           Data.Functor.Foldable          ( para )
    import           Data.Functor.Foldable.TH
    import           Control.Lens                   ( (%~), (&), (.~)
                                                    , _1, _2, _3, view
                                                    )
    import           Control.Monad                  (mfilter, liftM2, forM, zipWithM)
    import           Control.Monad.Trans.Reader     (ReaderT(..), asks, local)
    import           Control.Monad.Trans.Class      (lift)
    import           Language.Haskell.TH.Instances  ( )
    import           Language.Haskell.TH.Datatype
    import           Language.Haskell.TH.Syntax     (qRecover)
    import           Data.Generics.Uniplate.Data    (rewrite)

    import           Clash.Annotations.TopEntity    ( PortName(..)
                                                    , TopEntity(..)
                                                    )
    import           Clash.Magic                    (SimOnly)
    import           Clash.NamedTypes               ((:::))
    import           Clash.Signal                   ( HiddenClockResetEnable
                                                    , HiddenClock, HiddenReset, HiddenEnable
                                                    , Signal)
    import           Clash.Signal.Delayed           (DSignal)

    $(makeBaseFunctor ''Type)

    -- | A datatype to track failing naming in a subtree.
    data Naming a = Complete a | HasFail String | BackTrack (Set.Set Name)
      deriving (forall a b. (a -> b) -> Naming a -> Naming b)
    -> (forall a b. a -> Naming b -> Naming a) -> Functor Naming
    forall a b. a -> Naming b -> Naming a
    forall a b. (a -> b) -> Naming a -> Naming b
    forall (f :: Type -> Type).
    (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) -> Naming a -> Naming b
    fmap :: forall a b. (a -> b) -> Naming a -> Naming b
    $c<$ :: forall a b. a -> Naming b -> Naming a
    <$ :: forall a b. a -> Naming b -> Naming a
    Functor

    instance Semigroup a => Semigroup (Naming a) where
      Complete a
    a <> :: Naming a -> Naming a -> Naming a
    <> Complete a
    b     = a -> Naming a
    forall a. a -> Naming a
    Complete (a -> Naming a) -> a -> Naming a
    forall a b. (a -> b) -> a -> b
    $ a
    a a -> a -> a
    forall a. Semigroup a => a -> a -> a
    <> a
    b
      BackTrack Set Name
    n1 <> BackTrack Set Name
    n2 = Set Name -> Naming a
    forall a. Set Name -> Naming a
    BackTrack (Set Name -> Naming a) -> Set Name -> Naming a
    forall a b. (a -> b) -> a -> b
    $ Set Name
    n1 Set Name -> Set Name -> Set Name
    forall a. Semigroup a => a -> a -> a
    <> Set Name
    n2
      BackTrack Set Name
    n <> Naming a
    _             = Set Name -> Naming a
    forall a. Set Name -> Naming a
    BackTrack Set Name
    n
      Naming a
    _ <> BackTrack Set Name
    n             = Set Name -> Naming a
    forall a. Set Name -> Naming a
    BackTrack Set Name
    n
      HasFail String
    e1 <> HasFail String
    e2     = String -> Naming a
    forall a. String -> Naming a
    HasFail (String -> Naming a) -> String -> Naming a
    forall a b. (a -> b) -> a -> b
    $ String
    e1 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    e2
      Naming a
    _ <> HasFail String
    e               = String -> Naming a
    forall a. String -> Naming a
    HasFail String
    e
      HasFail String
    e <> Naming a
    _               = String -> Naming a
    forall a. String -> Naming a
    HasFail String
    e

    instance Monoid a => Monoid (Naming a) where
      mempty :: Naming a
    mempty = a -> Naming a
    forall a. a -> Naming a
    Complete a
    forall a. Monoid a => a
    mempty

    -- | Track seen 'Name's, and track current 'Info' for error reporting.
    type ErrorContext = String
    type TrackData = (Set.Set Name, ErrorContext)
    type Tracked m a = ReaderT TrackData m a

    -- * Utility functions

    -- | Matches a type `a -> b`
    pattern ArrowTy :: Type -> Type -> Type
    pattern $mArrowTy :: forall {r}. Type -> (Type -> Type -> r) -> ((# #) -> r) -> r
    $bArrowTy :: Type -> Type -> Type
    ArrowTy a b = AppT (AppT ArrowT a) b

    -- | Greedily split on top level 'AppT' to recover basic type
    -- application as a list of 'Type'.
    unapp :: Type -> [Type]
    unapp :: Type -> [Type]
    unapp (AppT Type
    l Type
    r) = Type -> [Type]
    unapp Type
    l [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type
    r]
    unapp Type
    t = [Type
    t]

    -- | Greedily split on top level outer arrows, splitting a function 'Type' into
    -- it's arguments. (Result type discarded)
    unarrow :: Type -> [Type]
    unarrow :: Type -> [Type]
    unarrow (ArrowTy Type
    x Type
    y) = Type
    x Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : Type -> [Type]
    unarrow Type
    y
    unarrow Type
    _ = []

    -- | Collapse a list of 'PortName's into a single 'PortName'
    collapseNames :: [PortName] -> [PortName]
    collapseNames :: [PortName] -> [PortName]
    collapseNames [] = []
    collapseNames [PortName
    x] = [PortName
    x]
    collapseNames [PortName]
    xs = [String -> [PortName] -> PortName
    PortProduct String
    "" [PortName]
    xs]

    -- | Failure message with a prefix to add some context for end users.
    failMsg :: String -> String
    failMsg :: String -> String
    failMsg String
    s = String
    "TopEntity generation error: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s

    -- | Retrieve current error context
    errorContext :: Tracked Q String
    errorContext :: Tracked Q String
    errorContext = (TrackData -> String) -> Tracked Q String
    forall (m :: Type -> Type) r a.
    Monad m =>
    (r -> a) -> ReaderT r m a
    asks TrackData -> String
    forall a b. (a, b) -> b
    snd

    -- Failure message with prefix in a 'Tracked' context
    failMsgWithContext :: String -> Tracked Q String
    failMsgWithContext :: String -> Tracked Q String
    failMsgWithContext String
    s = String -> String -> String
    forall a. [a] -> [a] -> [a]
    (++) (String -> String
    failMsg String
    s) (String -> String) -> Tracked Q String -> Tracked Q String
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Tracked Q String
    errorContext

    -- | Track a new seen 'Name' and update 'Info' for error handling
    visit :: (Show b) => Name -> b -> Tracked m a -> Tracked m a
    visit :: forall b (m :: Type -> Type) a.
    Show b =>
    Name -> b -> Tracked m a -> Tracked m a
    visit Name
    name b
    a = (TrackData -> TrackData)
    -> ReaderT TrackData m a -> ReaderT TrackData m a
    forall r (m :: Type -> Type) a.
    (r -> r) -> ReaderT r m a -> ReaderT r m a
    local (\TrackData
    t -> TrackData
    t TrackData -> (TrackData -> TrackData) -> TrackData
    forall a b. a -> (a -> b) -> b
    & (Set Name -> Identity (Set Name))
    -> TrackData -> Identity TrackData
    forall s t a b. Field1 s t a b => Lens s t a b
    Lens TrackData TrackData (Set Name) (Set Name)
    _1 ((Set Name -> Identity (Set Name))
     -> TrackData -> Identity TrackData)
    -> (Set Name -> Set Name) -> TrackData -> TrackData
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    %~ Name -> Set Name -> Set Name
    forall a. Ord a => a -> Set a -> Set a
    Set.insert Name
    name
                                  TrackData -> (TrackData -> TrackData) -> TrackData
    forall a b. a -> (a -> b) -> b
    & (String -> Identity String) -> TrackData -> Identity TrackData
    forall s t a b. Field2 s t a b => Lens s t a b
    Lens TrackData TrackData String String
    _2 ((String -> Identity String) -> TrackData -> Identity TrackData)
    -> String -> TrackData -> TrackData
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ b -> String
    forall a. Show a => a -> String
    show b
    a)

    -- | Grab the 'Name's of type variables in a datatype
    datatypeVars' :: DatatypeInfo -> [Name]
    #if MIN_VERSION_th_abstraction(0,3,0)
    datatypeVars' :: DatatypeInfo -> [Name]
    datatypeVars' DatatypeInfo
    d = TyVarBndr () -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> DatatypeInfo -> [TyVarBndr ()]
    datatypeVars DatatypeInfo
    d
    #else
    datatypeVars' d = name <$> datatypeVars d
     where
      name (VarT n) = n
      name (SigT n _) = name n
      name e = error $ "Unexpected datatype variable name of type " ++ show e
    #endif

    -- | Run a 'Name' through the template haskell machinery, getting a
    -- 'DatatypeInfo' if the 'Name' specified a datatype. The result is processed by
    -- a given function or a default @a@ is returned in the style of 'maybe'.
    tryReifyDatatype :: a -> (DatatypeInfo -> a) -> Name -> Tracked Q a
    tryReifyDatatype :: forall a. a -> (DatatypeInfo -> a) -> Name -> Tracked Q a
    tryReifyDatatype a
    a DatatypeInfo -> a
    f Name
    name = Q a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a.
    Monad m =>
    m a -> ReaderT TrackData m a
    forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q a -> Q a -> Q a
    forall a. Q a -> Q a -> Q a
    recover (a -> Q a
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure a
    a) (Q a -> Q a) -> Q a -> Q a
    forall a b. (a -> b) -> a -> b
    $ DatatypeInfo -> a
    f (DatatypeInfo -> a) -> Q DatatypeInfo -> Q a
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> Q DatatypeInfo
    reifyDatatype Name
    name)

    -- * Type tree folding \/ unfolding

    -- | Flag constructors with partially named fields as failing.
    portsFromTypes
      :: [Type]
      -> Tracked Q (Naming [PortName])
    portsFromTypes :: [Type] -> Tracked Q (Naming [PortName])
    portsFromTypes [Type]
    xs = do
      ([Naming [PortName]] -> Naming [PortName]
    forall a. Monoid a => [a] -> a
    mconcat ([Naming [PortName]] -> Naming [PortName])
    -> ReaderT TrackData Q [Naming [PortName]]
    -> Tracked Q (Naming [PortName])
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Type -> Tracked Q (Naming [PortName]))
    -> [Type] -> ReaderT TrackData Q [Naming [PortName]]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM Type -> Tracked Q (Naming [PortName])
    f [Type]
    xs)
      Tracked Q (Naming [PortName])
    -> (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b.
    ReaderT TrackData Q a
    -> (a -> ReaderT TrackData Q b) -> ReaderT TrackData Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
        Complete [PortName]
    names | [PortName] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [PortName]
    names Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0 Bool -> Bool -> Bool
    && [PortName] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [PortName]
    names Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= [Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Type]
    xs ->
          String -> Naming [PortName]
    forall a. String -> Naming a
    HasFail (String -> Naming [PortName])
    -> Tracked Q String -> Tracked Q (Naming [PortName])
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Tracked Q String
    failMsgWithContext String
    "Partially named constructor arguments!\n"
        Naming [PortName]
    x -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Naming [PortName]
    x
     where
      f :: Type -> Tracked Q (Naming [PortName])
    f = (Naming [PortName] -> Naming [PortName])
    -> Tracked Q (Naming [PortName]) -> Tracked Q (Naming [PortName])
    forall a b.
    (a -> b) -> ReaderT TrackData Q a -> ReaderT TrackData Q b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (([PortName] -> [PortName])
    -> Naming [PortName] -> Naming [PortName]
    forall a b. (a -> b) -> Naming a -> Naming b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap [PortName] -> [PortName]
    collapseNames) (Tracked Q (Naming [PortName]) -> Tracked Q (Naming [PortName]))
    -> (Type -> Tracked Q (Naming [PortName]))
    -> Type
    -> Tracked Q (Naming [PortName])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Tracked Q (Naming [PortName])
    gatherNames

    -- | Flag sum types as failing if they have any constructors with names.
    handleNamesInSum
      :: [ConstructorInfo]
      -> Tracked Q (Naming [PortName])
    handleNamesInSum :: [ConstructorInfo] -> Tracked Q (Naming [PortName])
    handleNamesInSum [ConstructorInfo]
    xs =
      ([Naming [PortName]] -> Naming [PortName]
    forall a. Monoid a => [a] -> a
    forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
    fold ([Naming [PortName]] -> Naming [PortName])
    -> ReaderT TrackData Q [Naming [PortName]]
    -> Tracked Q (Naming [PortName])
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> ([Type] -> Tracked Q (Naming [PortName]))
    -> [[Type]] -> ReaderT TrackData Q [Naming [PortName]]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM [Type] -> Tracked Q (Naming [PortName])
    portsFromTypes (ConstructorInfo -> [Type]
    constructorFields (ConstructorInfo -> [Type]) -> [ConstructorInfo] -> [[Type]]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> [ConstructorInfo]
    xs)) Tracked Q (Naming [PortName])
    -> (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b.
    ReaderT TrackData Q a
    -> (a -> ReaderT TrackData Q b) -> ReaderT TrackData Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
        Complete [] -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete []
        Naming [PortName]
    x ->
          Naming [PortName] -> Naming [PortName] -> Naming [PortName]
    forall a. Monoid a => a -> a -> a
    mappend Naming [PortName]
    x (Naming [PortName] -> Naming [PortName])
    -> (String -> Naming [PortName]) -> String -> Naming [PortName]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Naming [PortName]
    forall a. String -> Naming a
    HasFail (String -> Naming [PortName])
    -> Tracked Q String -> Tracked Q (Naming [PortName])
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> Tracked Q String
    failMsgWithContext String
    "Annotated sum types not supported!\n"

    -- | Build a list of 'PortName's from a Template Haskell 'Con' and a free
    -- variable mapping
    constructorToPorts :: Con -> Map.Map Name Type -> Tracked Q (Naming [PortName])
    constructorToPorts :: Con -> Map Name Type -> Tracked Q (Naming [PortName])
    constructorToPorts Con
    c Map Name Type
    m = do
      let xs :: [Type]
    xs = Map Name Type -> [Type] -> [Type]
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution Map Name Type
    m (Con -> [Type]
    ctys Con
    c)
      [Type] -> Tracked Q (Naming [PortName])
    portsFromTypes [Type]
    xs
     where
      ctys :: Con -> [Type]
    ctys (NormalC Name
    _ ((BangType -> Type) -> [BangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap BangType -> Type
    forall a b. (a, b) -> b
    snd -> [Type]
    tys)) = [Type]
    tys
      ctys (RecC Name
    _ (((Name, Bang, Type) -> Type) -> [(Name, Bang, Type)] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Getting Type (Name, Bang, Type) Type -> (Name, Bang, Type) -> Type
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    view Getting Type (Name, Bang, Type) Type
    forall s t a b. Field3 s t a b => Lens s t a b
    Lens (Name, Bang, Type) (Name, Bang, Type) Type Type
    _3) -> [Type]
    tys)) = [Type]
    tys
      ctys (InfixC BangType
    _ Name
    _ (BangType -> Type
    forall a b. (a, b) -> b
    snd -> Type
    ty)) = [Type
    ty]
      ctys (ForallC [TyVarBndr Specificity]
    _ [Type]
    _ Con
    c') = Con -> [Type]
    ctys Con
    c'
      ctys (GadtC [Name]
    _ ((BangType -> Type) -> [BangType] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap BangType -> Type
    forall a b. (a, b) -> b
    snd -> [Type]
    tys) Type
    _) = [Type]
    tys
      ctys (RecGadtC [Name]
    _ (((Name, Bang, Type) -> Type) -> [(Name, Bang, Type)] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Getting Type (Name, Bang, Type) Type -> (Name, Bang, Type) -> Type
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    view Getting Type (Name, Bang, Type) Type
    forall s t a b. Field3 s t a b => Lens s t a b
    Lens (Name, Bang, Type) (Name, Bang, Type) Type Type
    _3) -> [Type]
    tys) Type
    _) = [Type]
    tys

    -- | Build a list of 'PortName's from a Template Haskell 'Name'
    datatypeNameToPorts
      :: Name
      -> Tracked Q (Naming [PortName])
    datatypeNameToPorts :: Name -> Tracked Q (Naming [PortName])
    datatypeNameToPorts Name
    name = do
      constructors <- [ConstructorInfo]
    -> (DatatypeInfo -> [ConstructorInfo])
    -> Name
    -> Tracked Q [ConstructorInfo]
    forall a. a -> (DatatypeInfo -> a) -> Name -> Tracked Q a
    tryReifyDatatype [] DatatypeInfo -> [ConstructorInfo]
    datatypeCons Name
    name

      names <- case constructors of
        [ConstructorInfo]
    _ | Name
    name Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''SimOnly -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete []
        []  -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete []
        [ConstructorInfo
    x] -> [Type] -> Tracked Q (Naming [PortName])
    portsFromTypes (ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    x)
        [ConstructorInfo]
    xs  -> [ConstructorInfo] -> Tracked Q (Naming [PortName])
    handleNamesInSum [ConstructorInfo]
    xs

      case names of
        BackTrack Set Name
    ns | Name -> Set Name -> Bool
    forall a. Ord a => a -> Set a -> Bool
    Set.member Name
    name Set Name
    ns -> do
          Q () -> ReaderT TrackData Q ()
    forall (m :: Type -> Type) a.
    Monad m =>
    m a -> ReaderT TrackData m a
    forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q () -> ReaderT TrackData Q ()) -> Q () -> ReaderT TrackData Q ()
    forall a b. (a -> b) -> a -> b
    $ String -> Q ()
    reportWarning (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String
    "Make sure HDL port names are correct:\n"
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "Backtracked when constructing " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Ppr a => a -> String
    pprint Name
    name
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n(Type appears recursive)"
          Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ case (Name -> Set Name -> Set Name
    forall a. Ord a => a -> Set a -> Set a
    Set.delete Name
    name Set Name
    ns) of
            Set Name
    e | Set Name
    e Set Name -> Set Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Set Name
    forall a. Set a
    Set.empty -> [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete []
            Set Name
    xs -> Set Name -> Naming [PortName]
    forall a. Set Name -> Naming a
    BackTrack Set Name
    xs
        Naming [PortName]
    _ -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Naming [PortName]
    names

    -- This shouldn't reduce
    type family PortLabel where

    -- Replace (:::) annotations with a stuck type family, to inhibit unifyTypes to reduce it
    guardPorts :: Type -> Type
    guardPorts :: Type -> Type
    guardPorts = (Type -> Maybe Type) -> Type -> Type
    forall on. Uniplate on => (on -> Maybe on) -> on -> on
    rewrite ((Type -> Maybe Type) -> Type -> Type)
    -> (Type -> Maybe Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ \case
        AppT (ConT Name
    split) name :: Type
    name@(LitT (StrTyLit String
    _)) | Name
    split Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''(:::) -> Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Type -> Maybe Type) -> Type -> Maybe Type
    forall a b. (a -> b) -> a -> b
    $ Type -> Type -> Type
    AppT (Name -> Type
    ConT ''PortLabel) Type
    name
        Type
    _ -> Maybe Type
    forall a. Maybe a
    Nothing

    -- | Recursively walking a 'Type' tree and building a list of 'PortName's.
    typeTreeToPorts
      :: TypeF (Type, Tracked Q (Naming [PortName]))
      -- ^ Case under scrutiny, paramorphism style
      -> Tracked Q (Naming [PortName])
    typeTreeToPorts :: TypeF (Type, Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    typeTreeToPorts (AppTF (AppT (ConT Name
    split) (LitT (StrTyLit String
    name)), Tracked Q (Naming [PortName])
    _) (Type
    _,Tracked Q (Naming [PortName])
    c))
      -- Is there a '<String> ::: <something>' annotation?
      | Name
    split Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''PortLabel
      -- We found our split. If:
      -- - We only have no names from children: use split name as PortName
      -- - We have children reporting names: use split name as name to PortProduct
      = Tracked Q (Naming [PortName])
    c Tracked Q (Naming [PortName])
    -> (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b.
    ReaderT TrackData Q a
    -> (a -> ReaderT TrackData Q b) -> ReaderT TrackData Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
        Complete []  -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete [String -> PortName
    PortName String
    name]
        Complete [PortName String
    n2] -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete [String -> PortName
    PortName (String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    n2)]
        Complete [PortName]
    xs  -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete [String -> [PortName] -> PortName
    PortProduct String
    name [PortName]
    xs]
        Naming [PortName]
    x            -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Naming [PortName]
    x

    typeTreeToPorts (ConTF Name
    name) = do
      -- Only attempt to resolve a subtree for names we haven't seen before
      seen <- (TrackData -> Set Name) -> ReaderT TrackData Q (Set Name)
    forall (m :: Type -> Type) r a.
    Monad m =>
    (r -> a) -> ReaderT r m a
    asks TrackData -> Set Name
    forall a b. (a, b) -> a
    fst
      if Set.member name seen
      then return $ BackTrack $ Set.singleton name
      else visit name name $ do
        info <- lift $ reify name
        case info of
          -- Either `name` is an unannotated primitive
          PrimTyConI Name
    _ Int
    _ Bool
    _ -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete []
          -- ... or a type synonym
          TyConI (TySynD Name
    _ [TyVarBndr BndrVis]
    _ Type
    t) -> Type -> Tracked Q (Naming [PortName])
    gatherNames Type
    t
          -- ... or something "datatype" like
          Info
    _ -> Name -> Tracked Q (Naming [PortName])
    datatypeNameToPorts Name
    name

    typeTreeToPorts f :: TypeF (Type, Tracked Q (Naming [PortName]))
    f@(AppTF (Type
    a,Tracked Q (Naming [PortName])
    a') (Type
    b,Tracked Q (Naming [PortName])
    b')) = do
      -- Gather types applied to a head type
      case Type -> [Type]
    unapp (Type -> Type -> Type
    AppT Type
    a Type
    b) of
        -- Skip SimOnly constructs - they're always zero bits
        (ConT Name
    x : [Type]
    _) | Name
    x Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''SimOnly -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure ([PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete [])
        -- Return the inner type for signals
        (ConT Name
    x : Type
    _ : Type
    _ : []) | Name
    x Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Clash.Signal.Signal -> Tracked Q (Naming [PortName])
    b'
        (ConT Name
    x : Type
    _ : Type
    _ : Type
    _ : []) | Name
    x Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Clash.Signal.Delayed.DSignal -> Tracked Q (Naming [PortName])
    b'

        -- Other handled type applications are
        -- 1. Type synonyms
        -- 2. Closed type families
        -- 3. Open type and data families
        -- 4. Regular data types
        (ConT Name
    x : [Type]
    xs) -> do
          info <- Q Info -> ReaderT TrackData Q Info
    forall (m :: Type -> Type) a.
    Monad m =>
    m a -> ReaderT TrackData m a
    forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q Info -> ReaderT TrackData Q Info)
    -> Q Info -> ReaderT TrackData Q Info
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Info
    reify Name
    x
          case info of
            -- 1. Type synonym case is just inserting the relevant port tree
            (TyConI (TySynD Name
    _ [TyVarBndr BndrVis]
    synvars Type
    def)) -> do
              Type -> Tracked Q (Naming [PortName])
    gatherNames (Type -> Tracked Q (Naming [PortName]))
    -> Type -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [Type] -> [Name] -> Type -> Type
    forall {a}. TypeSubstitution a => [Type] -> [Name] -> a -> a
    applyContext [Type]
    xs (TyVarBndr BndrVis -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName (TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr BndrVis]
    synvars) Type
    def

            -- 2. Match argument lengths, substitute types, and then insert the port
            -- tree
            FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
    _ [TyVarBndr BndrVis]
    bds FamilyResultSig
    _ Maybe InjectivityAnn
    _) [TySynEqn]
    eqs) [InstanceDec]
    _
              | [TyVarBndr BndrVis] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [TyVarBndr BndrVis]
    bds Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Type]
    xs -> do
                  matches <- Q [Maybe Type] -> ReaderT TrackData Q [Maybe Type]
    forall (m :: Type -> Type) a.
    Monad m =>
    m a -> ReaderT TrackData m a
    forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q [Maybe Type] -> ReaderT TrackData Q [Maybe Type])
    -> Q [Maybe Type] -> ReaderT TrackData Q [Maybe Type]
    forall a b. (a -> b) -> a -> b
    $ [TySynEqn] -> (TySynEqn -> Q (Maybe Type)) -> Q [Maybe Type]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [TySynEqn]
    eqs ((TySynEqn -> Q (Maybe Type)) -> Q [Maybe Type])
    -> (TySynEqn -> Q (Maybe Type)) -> Q [Maybe Type]
    forall a b. (a -> b) -> a -> b
    $ \TySynEqn
    eq -> Q (Maybe Type) -> Q (Maybe Type) -> Q (Maybe Type)
    forall a. Q a -> Q a -> Q a
    forall (m :: Type -> Type) a. Quasi m => m a -> m a -> m a
    qRecover (Maybe Type -> Q (Maybe Type)
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Maybe Type
    forall a. Maybe a
    Nothing) (Q (Maybe Type) -> Q (Maybe Type))
    -> (Q Type -> Q (Maybe Type)) -> Q Type -> Q (Maybe Type)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Q Type -> Q (Maybe Type)) -> Q Type -> Q (Maybe Type)
    forall a b. (a -> b) -> a -> b
    $ do
                      sub <- [Map Name Type] -> Map Name Type
    forall a. Monoid a => [a] -> a
    mconcat ([Map Name Type] -> Map Name Type)
    -> Q [Map Name Type] -> Q (Map Name Type)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Type -> Type -> Q (Map Name Type))
    -> [Type] -> [Type] -> Q [Map Name Type]
    forall (m :: Type -> Type) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m [c]
    zipWithM (\Type
    l Type
    r -> [Type] -> Q (Map Name Type)
    unifyTypes [Type
    l, Type
    r]) [Type]
    xs (TySynEqn -> [Type]
    tySynArgs TySynEqn
    eq)
                      return $ applySubstitution sub $ tySynRHS eq
                  case catMaybes matches of
                      (Type
    r:[Type]
    _) -> Type -> Tracked Q (Naming [PortName])
    gatherNames Type
    r
                      -- We didn't find any matching instances (i.e. the
                      -- type family application is stuck) so give up.
                      [] -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete []

            -- 3. Match argument lengths then:
            --   - Substitute port tree for type family
            --   - Try to get a unique constructor for data families and build
            --     port tree from the constructor
            Info
    _ | Info -> Maybe Int
    familyArity Info
    info Maybe Int -> Maybe Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int -> Maybe Int
    forall a. a -> Maybe a
    Just ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Type]
    xs) -> do
              (Q [InstanceDec] -> ReaderT TrackData Q [InstanceDec]
    forall (m :: Type -> Type) a.
    Monad m =>
    m a -> ReaderT TrackData m a
    forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q [InstanceDec] -> ReaderT TrackData Q [InstanceDec])
    -> Q [InstanceDec] -> ReaderT TrackData Q [InstanceDec]
    forall a b. (a -> b) -> a -> b
    $ Name -> [Type] -> Q [InstanceDec]
    reifyInstances Name
    x [Type]
    xs) ReaderT TrackData Q [InstanceDec]
    -> ([InstanceDec] -> Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b.
    ReaderT TrackData Q a
    -> (a -> ReaderT TrackData Q b) -> ReaderT TrackData Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
    #if MIN_VERSION_template_haskell(2,15,0)
                [TySynInstD (TySynEqn Maybe [TyVarBndr ()]
    _ Type
    _ Type
    r)] ->
    #else
                [TySynInstD _ (TySynEqn _ r)] ->
    #endif
                    Type -> Tracked Q (Naming [PortName])
    gatherNames ([Type] -> Info -> Type -> Type
    forall {a}. TypeSubstitution a => [Type] -> Info -> a -> a
    applyFamilyBindings [Type]
    xs Info
    info Type
    r)

                [NewtypeInstD [Type]
    _ Maybe [TyVarBndr ()]
    _ Type
    _ Maybe Type
    _ Con
    c [DerivClause]
    _] -> Con -> Map Name Type -> Tracked Q (Naming [PortName])
    constructorToPorts Con
    c ([Type] -> Info -> Map Name Type
    forall {a}. [a] -> Info -> Map Name a
    familyTyMap [Type]
    xs Info
    info)
                [DataInstD    [Type]
    _ Maybe [TyVarBndr ()]
    _ Type
    _ Maybe Type
    _ [Con]
    cs [DerivClause]
    _] -> do
                  case [Con]
    cs of
                    [Con
    c] -> Con -> Map Name Type -> Tracked Q (Naming [PortName])
    constructorToPorts Con
    c ([Type] -> Info -> Map Name Type
    forall {a}. [a] -> Info -> Map Name a
    familyTyMap [Type]
    xs Info
    info)
                    [Con]
    _ -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Naming [PortName] -> Tracked Q (Naming [PortName]))
    -> Naming [PortName] -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ [PortName] -> Naming [PortName]
    forall a. a -> Naming a
    Complete []
                [InstanceDec]
    y -> String -> Tracked Q (Naming [PortName])
    forall a. String -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Tracked Q (Naming [PortName]))
    -> String -> Tracked Q (Naming [PortName])
    forall a b. (a -> b) -> a -> b
    $ String -> String
    failMsg String
    "Encountered unexpected type during family application!"
                          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [InstanceDec] -> String
    forall a. Ppr a => a -> String
    pprint [InstanceDec]
    y

            -- 4. Check if head really is a datatype, apply free variables,
            --    and attempt to get a unique constructor
            Info
    _ -> do
              dataTy <- Maybe DatatypeInfo
    -> (DatatypeInfo -> Maybe DatatypeInfo)
    -> Name
    -> Tracked Q (Maybe DatatypeInfo)
    forall a. a -> (DatatypeInfo -> a) -> Name -> Tracked Q a
    tryReifyDatatype Maybe DatatypeInfo
    forall a. Maybe a
    Nothing DatatypeInfo -> Maybe DatatypeInfo
    forall a. a -> Maybe a
    Just Name
    x

              let -- Apply tail types to head datatype free type variables
                  hasAllArgs   = \DatatypeInfo
    vs -> [Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Type]
    xs Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == [TyVarBndr ()] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length (DatatypeInfo -> [TyVarBndr ()]
    datatypeVars DatatypeInfo
    vs)
                  constructors = [Type] -> DatatypeInfo -> [ConstructorInfo]
    applyDatatypeContext [Type]
    xs (DatatypeInfo -> [ConstructorInfo])
    -> Maybe DatatypeInfo -> Maybe [ConstructorInfo]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> (DatatypeInfo -> Bool) -> Maybe DatatypeInfo -> Maybe DatatypeInfo
    forall (m :: Type -> Type) a.
    MonadPlus m =>
    (a -> Bool) -> m a -> m a
    mfilter DatatypeInfo -> Bool
    hasAllArgs Maybe DatatypeInfo
    dataTy

                  -- Attempt to get a unique constructor
                  getSingleConstructor m [b]
    cs = do [c] <- m [b]
    cs; return c
                  constructor = Maybe [ConstructorInfo] -> Maybe ConstructorInfo
    forall {m :: Type -> Type} {b}. MonadFail m => m [b] -> m b
    getSingleConstructor Maybe [ConstructorInfo]
    constructors

              -- If any steps failed, return the PortNames according to the head type.
              maybe a' (visit x (ppr x) . portsFromTypes . constructorFields) constructor

        -- If head is a tuple or list then we take all the names
        (Type
    ListT:[Type]
    _)    -> TypeF (Naming [PortName]) -> Naming [PortName]
    forall m. Monoid m => TypeF m -> m
    forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
    fold (TypeF (Naming [PortName]) -> Naming [PortName])
    -> ReaderT TrackData Q (TypeF (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> ((Type, Tracked Q (Naming [PortName]))
     -> Tracked Q (Naming [PortName]))
    -> TypeF (Type, Tracked Q (Naming [PortName]))
    -> ReaderT TrackData Q (TypeF (Naming [PortName]))
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> TypeF a -> m (TypeF b)
    mapM (Type, Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b. (a, b) -> b
    snd TypeF (Type, Tracked Q (Naming [PortName]))
    f
        (TupleT Int
    _:[Type]
    _) -> TypeF (Naming [PortName]) -> Naming [PortName]
    forall m. Monoid m => TypeF m -> m
    forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
    fold (TypeF (Naming [PortName]) -> Naming [PortName])
    -> ReaderT TrackData Q (TypeF (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> ((Type, Tracked Q (Naming [PortName]))
     -> Tracked Q (Naming [PortName]))
    -> TypeF (Type, Tracked Q (Naming [PortName]))
    -> ReaderT TrackData Q (TypeF (Naming [PortName]))
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> TypeF a -> m (TypeF b)
    mapM (Type, Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b. (a, b) -> b
    snd TypeF (Type, Tracked Q (Naming [PortName]))
    f

        -- We're not applying to a head 'ConT' so lets try best effort of getting names
        -- from all applied types
        [Type]
    _ -> do
          Q () -> ReaderT TrackData Q ()
    forall (m :: Type -> Type) a.
    Monad m =>
    m a -> ReaderT TrackData m a
    forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Q () -> ReaderT TrackData Q ()) -> Q () -> ReaderT TrackData Q ()
    forall a b. (a -> b) -> a -> b
    $ String -> Q ()
    reportWarning (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String
    "Make sure HDL port names are correct:\n"
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "Type application with non ConT head:\n:("
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint (Type -> Type -> Type
    AppT Type
    a Type
    b)
          f' <- ((Type, Tracked Q (Naming [PortName]))
     -> Tracked Q (Naming [PortName]))
    -> TypeF (Type, Tracked Q (Naming [PortName]))
    -> ReaderT TrackData Q (TypeF (Naming [PortName]))
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> TypeF a -> m (TypeF b)
    mapM (Type, Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b. (a, b) -> b
    snd TypeF (Type, Tracked Q (Naming [PortName]))
    f
          return $ fold f'
     where
      tyMap :: [a] -> [k] -> Map k a
    tyMap [a]
    ctx [k]
    holes = [(k, a)] -> Map k a
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(k, a)] -> Map k a) -> [(k, a)] -> Map k a
    forall a b. (a -> b) -> a -> b
    $ [k] -> [a] -> [(k, a)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [k]
    holes [a]
    ctx
      familyTyMap :: [a] -> Info -> Map Name a
    familyTyMap [a]
    ctx (Info -> Maybe [TyVarBndr BndrVis]
    familyBindings -> Just [TyVarBndr BndrVis]
    holes) = [a] -> [Name] -> Map Name a
    forall {k} {a}. Ord k => [a] -> [k] -> Map k a
    tyMap [a]
    ctx (TyVarBndr BndrVis -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName (TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr BndrVis]
    holes)
      familyTyMap [a]
    _ Info
    _  = String -> Map Name a
    forall a. HasCallStack => String -> a
    error String
    "familyTyMap called with non family argument!"
      applyContext :: [Type] -> [Name] -> a -> a
    applyContext [Type]
    ctx [Name]
    holes = Map Name Type -> a -> a
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution ([Type] -> [Name] -> Map Name Type
    forall {k} {a}. Ord k => [a] -> [k] -> Map k a
    tyMap [Type]
    ctx [Name]
    holes)
      applyDatatypeContext :: [Type] -> DatatypeInfo -> [ConstructorInfo]
    applyDatatypeContext [Type]
    ctx DatatypeInfo
    d = [Type] -> [Name] -> ConstructorInfo -> ConstructorInfo
    forall {a}. TypeSubstitution a => [Type] -> [Name] -> a -> a
    applyContext [Type]
    ctx (DatatypeInfo -> [Name]
    datatypeVars' DatatypeInfo
    d) (ConstructorInfo -> ConstructorInfo)
    -> [ConstructorInfo] -> [ConstructorInfo]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> DatatypeInfo -> [ConstructorInfo]
    datatypeCons DatatypeInfo
    d
      applyFamilyBindings :: [Type] -> Info -> a -> a
    applyFamilyBindings [Type]
    ctx (Info -> Maybe [TyVarBndr BndrVis]
    familyBindings -> Just [TyVarBndr BndrVis]
    holes) a
    t
        = [Type] -> [Name] -> a -> a
    forall {a}. TypeSubstitution a => [Type] -> [Name] -> a -> a
    applyContext [Type]
    ctx (TyVarBndr BndrVis -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName (TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> [TyVarBndr BndrVis]
    holes) a
    t
      applyFamilyBindings [Type]
    _ Info
    _ a
    _ = String -> a
    forall a. HasCallStack => String -> a
    error String
    "familyTyMap called with non family argument!"

    #if MIN_VERSION_template_haskell(2,15,0)
      tySynArgs :: TySynEqn -> [Type]
    tySynArgs (TySynEqn Maybe [TyVarBndr ()]
    _ Type
    args Type
    _) = Int -> [Type] -> [Type]
    forall a. Int -> [a] -> [a]
    drop Int
    1 (Type -> [Type]
    unapp Type
    args)
    #else
      tySynArgs (TySynEqn args _) = args
    #endif

    #if MIN_VERSION_template_haskell(2,15,0)
      tySynRHS :: TySynEqn -> Type
    tySynRHS (TySynEqn Maybe [TyVarBndr ()]
    _ Type
    _ Type
    r) = Type
    r
    #else
      tySynRHS (TySynEqn _ r) = r
    #endif

      familyBindings :: Info -> Maybe [TyVarBndr BndrVis]
    familyBindings (FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
    _ [TyVarBndr BndrVis]
    xs FamilyResultSig
    _ Maybe InjectivityAnn
    _) [TySynEqn]
    _) [InstanceDec]
    _) = [TyVarBndr BndrVis] -> Maybe [TyVarBndr BndrVis]
    forall a. a -> Maybe a
    Just [TyVarBndr BndrVis]
    xs
      familyBindings (FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
    _ [TyVarBndr BndrVis]
    xs FamilyResultSig
    _ Maybe InjectivityAnn
    _)) [InstanceDec]
    _) = [TyVarBndr BndrVis] -> Maybe [TyVarBndr BndrVis]
    forall a. a -> Maybe a
    Just [TyVarBndr BndrVis]
    xs
      familyBindings (FamilyI (DataFamilyD Name
    _ [TyVarBndr BndrVis]
    xs Maybe Type
    _) [InstanceDec]
    _) = [TyVarBndr BndrVis] -> Maybe [TyVarBndr BndrVis]
    forall a. a -> Maybe a
    Just [TyVarBndr BndrVis]
    xs
      familyBindings Info
    _ = Maybe [TyVarBndr BndrVis]
    forall a. Maybe a
    Nothing
      familyArity :: Info -> Maybe Int
    familyArity = ([TyVarBndr BndrVis] -> Int)
    -> Maybe [TyVarBndr BndrVis] -> Maybe Int
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap [TyVarBndr BndrVis] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length (Maybe [TyVarBndr BndrVis] -> Maybe Int)
    -> (Info -> Maybe [TyVarBndr BndrVis]) -> Info -> Maybe Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Info -> Maybe [TyVarBndr BndrVis]
    familyBindings

    typeTreeToPorts TypeF (Type, Tracked Q (Naming [PortName]))
    f = do
      -- Just collect names
      f' <- ((Type, Tracked Q (Naming [PortName]))
     -> Tracked Q (Naming [PortName]))
    -> TypeF (Type, Tracked Q (Naming [PortName]))
    -> ReaderT TrackData Q (TypeF (Naming [PortName]))
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> TypeF a -> m (TypeF b)
    mapM (Type, Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    forall a b. (a, b) -> b
    snd TypeF (Type, Tracked Q (Naming [PortName]))
    f
      return $ fold f'

    -- | Gather naming tree attached to a 'Type' and its inner 'Type's
    gatherNames
      :: Type
      -- ^ Type to investigate
      -> Tracked Q (Naming [PortName])
    gatherNames :: Type -> Tracked Q (Naming [PortName])
    gatherNames =
      (Base Type (Type, Tracked Q (Naming [PortName]))
     -> Tracked Q (Naming [PortName]))
    -> Type -> Tracked Q (Naming [PortName])
    forall t a. Recursive t => (Base t (t, a) -> a) -> t -> a
    forall a. (Base Type (Type, a) -> a) -> Type -> a
    para Base Type (Type, Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    TypeF (Type, Tracked Q (Naming [PortName]))
    -> Tracked Q (Naming [PortName])
    typeTreeToPorts (Type -> Tracked Q (Naming [PortName]))
    -> (Type -> Type) -> Type -> Tracked Q (Naming [PortName])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type
    guardPorts

    -- Build a possible failing 'PortName' tree and unwrap the 'Naming' result.
    buildPorts
      :: Type
      -- ^ Type to investigate
      -> Q [PortName]
    buildPorts :: Type -> Q [PortName]
    buildPorts Type
    x = do
      (ReaderT TrackData Q [PortName] -> TrackData -> Q [PortName])
    -> TrackData -> ReaderT TrackData Q [PortName] -> Q [PortName]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ReaderT TrackData Q [PortName] -> TrackData -> Q [PortName]
    forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
    runReaderT (Set Name
    forall a. Set a
    Set.empty, String
    "") (ReaderT TrackData Q [PortName] -> Q [PortName])
    -> ReaderT TrackData Q [PortName] -> Q [PortName]
    forall a b. (a -> b) -> a -> b
    $ Type -> Tracked Q (Naming [PortName])
    gatherNames Type
    x
        Tracked Q (Naming [PortName])
    -> (Naming [PortName] -> ReaderT TrackData Q [PortName])
    -> ReaderT TrackData Q [PortName]
    forall a b.
    ReaderT TrackData Q a
    -> (a -> ReaderT TrackData Q b) -> ReaderT TrackData Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
          Complete [PortName]
    xs -> [PortName] -> ReaderT TrackData Q [PortName]
    forall a. a -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return [PortName]
    xs
          HasFail String
    err -> String -> ReaderT TrackData Q [PortName]
    forall a. String -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail String
    err
          BackTrack Set Name
    n -> String -> ReaderT TrackData Q [PortName]
    forall a. String -> ReaderT TrackData Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> ReaderT TrackData Q [PortName])
    -> String -> ReaderT TrackData Q [PortName]
    forall a b. (a -> b) -> a -> b
    $ String -> String
    failMsg String
    "Encountered recursive type at entry! " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Set Name -> String
    forall a. Show a => a -> String
    show Set Name
    n

    -- | Get the result 'PortName' from a function type
    toReturnName :: Type -> Q PortName
    toReturnName :: Type -> Q PortName
    toReturnName (ArrowTy Type
    _ Type
    b) = Type -> Q PortName
    toReturnName Type
    b
    toReturnName Type
    b             =
      Type -> Q [PortName]
    buildPorts Type
    b
      Q [PortName] -> ([PortName] -> Q PortName) -> Q PortName
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
         [] -> String -> Q PortName
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q PortName) -> String -> Q PortName
    forall a b. (a -> b) -> a -> b
    $ String -> String
    failMsg String
    "No return name specified!"
         [PortName
    x] -> PortName -> Q PortName
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return PortName
    x
         [PortName]
    xs -> PortName -> Q PortName
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (PortName -> Q PortName) -> PortName -> Q PortName
    forall a b. (a -> b) -> a -> b
    $ String -> [PortName] -> PortName
    PortProduct String
    "" [PortName]
    xs

    -- | Get the argument 'PortName's from a function type
    toArgNames :: Type -> Q [PortName]
    toArgNames :: Type -> Q [PortName]
    toArgNames Type
    ty = (Type -> Q PortName) -> [Type] -> Q [PortName]
    forall (t :: Type -> Type) (f :: Type -> Type) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: Type -> Type) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse Type -> Q PortName
    build (Type -> [Type]
    unarrow Type
    ty)
     where
      build :: Type -> Q PortName
    build Type
    x = Type -> Q [PortName]
    buildPorts Type
    x Q [PortName] -> ([PortName] -> Q PortName) -> Q PortName
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Type -> [PortName] -> Q PortName
    forall {m :: Type -> Type} {a}.
    (MonadFail m, Ppr a) =>
    a -> [PortName] -> m PortName
    check Type
    x
      check :: a -> [PortName] -> m PortName
    check a
    x []  = String -> m PortName
    forall a. String -> m a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> m PortName) -> String -> m PortName
    forall a b. (a -> b) -> a -> b
    $ String -> String
    failMsg String
    "Unnamed argument " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Ppr a => a -> String
    pprint a
    x
      check a
    _ [PortName
    a] = PortName -> m PortName
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return PortName
    a
      check a
    _ [PortName]
    xs  = PortName -> m PortName
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (PortName -> m PortName) -> PortName -> m PortName
    forall a b. (a -> b) -> a -> b
    $ String -> [PortName] -> PortName
    PortProduct String
    "" [PortName]
    xs

    data ClockType = None | SingleClockResetEnable | Other
      deriving ClockType -> ClockType -> Bool
    (ClockType -> ClockType -> Bool)
    -> (ClockType -> ClockType -> Bool) -> Eq ClockType
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ClockType -> ClockType -> Bool
    == :: ClockType -> ClockType -> Bool
    $c/= :: ClockType -> ClockType -> Bool
    /= :: ClockType -> ClockType -> Bool
    Eq

    -- | Strip constraints from a type.
    --
    -- Fail if:
    -- - There are free type variables.
    -- - There are multiple hidden clocks
    handleConstraints :: Type -> ClockType -> Q (Type, ClockType)
    handleConstraints :: Type -> ClockType -> Q (Type, ClockType)
    handleConstraints (ForallT [] [] Type
    x) ClockType
    clk = Type -> ClockType -> Q (Type, ClockType)
    handleConstraints Type
    x ClockType
    clk
    handleConstraints (ForallT xs :: [TyVarBndr Specificity]
    xs@(TyVarBndr Specificity
    _:[TyVarBndr Specificity]
    _) [Type]
    _ Type
    _) ClockType
    _ =
      String -> Q (Type, ClockType)
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q (Type, ClockType)) -> String -> Q (Type, ClockType)
    forall a b. (a -> b) -> a -> b
    $ String -> String
    failMsg String
    "Free type variables!\n"
           String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [TyVarBndr Specificity] -> String
    forall a. Ppr a => a -> String
    pprint [TyVarBndr Specificity]
    xs
    handleConstraints (ForallT [TyVarBndr Specificity]
    _ [Type]
    c Type
    x) ClockType
    clk = Type -> ClockType -> Q (Type, ClockType)
    handleConstraints Type
    x ClockType
    hiddenClocks
     where
      hiddenClocks :: ClockType
    hiddenClocks = (ClockType -> Type -> ClockType)
    -> ClockType -> [Type] -> ClockType
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: Type -> Type) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl ClockType -> Type -> ClockType
    findHiddenClocks ClockType
    clk [Type]
    c
      findHiddenClocks :: ClockType -> Type -> ClockType
    findHiddenClocks ClockType
    a (AppT (ConT Name
    b) Type
    _)
        | Name
    b Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Clash.Signal.HiddenClockResetEnable Bool -> Bool -> Bool
    && ClockType
    a ClockType -> ClockType -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClockType
    None
          = ClockType
    SingleClockResetEnable
        | Name
    b Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Clash.Signal.HiddenClockResetEnable Bool -> Bool -> Bool
    && ClockType
    a ClockType -> ClockType -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ClockType
    None
          = ClockType
    Other
        | Name
    b Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Clash.Signal.HiddenClock
          Bool -> Bool -> Bool
    || Name
    b Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Clash.Signal.HiddenReset
          Bool -> Bool -> Bool
    || Name
    b Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Clash.Signal.HiddenEnable
          = ClockType
    Other
      findHiddenClocks ClockType
    a Type
    _ = ClockType
    a
    handleConstraints Type
    x ClockType
    clk = (Type, ClockType) -> Q (Type, ClockType)
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Type
    x, ClockType
    clk)

    clockToPorts :: ClockType -> Q [PortName]
    clockToPorts :: ClockType -> Q [PortName]
    clockToPorts ClockType
    None = [PortName] -> Q [PortName]
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return []
    clockToPorts (ClockType
    SingleClockResetEnable) =
      [PortName] -> Q [PortName]
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return [String -> [PortName] -> PortName
    PortProduct String
    "" [ String -> PortName
    PortName String
    "clk" , String -> PortName
    PortName String
    "rst" , String -> PortName
    PortName String
    "en" ]]
    clockToPorts ClockType
    Other =
      String -> Q [PortName]
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail (String -> Q [PortName]) -> String -> Q [PortName]
    forall a b. (a -> b) -> a -> b
    $ String -> String
    failMsg String
    "TH generation for multiple hidden clocks and"
           String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " HiddenClock/HiddenReset/HiddenEnable currently unsupported!"

    -- *

    -- | Return a typed expression for a 'TopEntity' of a given @('Name', 'Type')@.
    buildTopEntity :: Maybe String -> (Name, Type) -> TExpQ TopEntity
    buildTopEntity :: Maybe String -> (Name, Type) -> TExpQ TopEntity
    buildTopEntity Maybe String
    topName (Name
    name, Type
    ty) = do
        (ty', clock) <- Type -> ClockType -> Q (Type, ClockType)
    handleConstraints Type
    ty ClockType
    None

        ins   <- liftM2 (<>) (clockToPorts clock) (toArgNames ty')
        out   <- toReturnName ty'

        let outName = case Maybe String
    topName of
              Just String
    name' -> String
    name'          -- user specified name
              Maybe String
    Nothing    -> Name -> String
    nameBase Name
    name  -- auto-generated from Haskell name

    #if MIN_VERSION_template_haskell(2,17,0)
        (examineCode
    #else
        (
    #endif
                      [|| Synthesize
                         { t_name   = outName
                         , t_inputs = ins
                         , t_output = out
                         } ||])

    -- | Return a typed 'Maybe TopEntity' expression given a 'Name'.
    -- This will return an 'TExp' of 'Nothing' if 'TopEntity' generation failed.
    maybeBuildTopEntity :: Maybe String -> Name -> Q (TExp (Maybe TopEntity))
    maybeBuildTopEntity :: Maybe String -> Name -> Q (TExp (Maybe TopEntity))
    maybeBuildTopEntity Maybe String
    topName Name
    name = do
    #if MIN_VERSION_template_haskell(2,17,0)
      Q (TExp (Maybe TopEntity))
    -> Q (TExp (Maybe TopEntity)) -> Q (TExp (Maybe TopEntity))
    forall a. Q a -> Q a -> Q a
    recover (Code Q (Maybe TopEntity) -> Q (TExp (Maybe TopEntity))
    forall (m :: Type -> Type) a. Code m a -> m (TExp a)
    examineCode [|| Maybe a
    forall a. Maybe a
    Nothing ||]) (Q (TExp (Maybe TopEntity)) -> Q (TExp (Maybe TopEntity)))
    -> Q (TExp (Maybe TopEntity)) -> Q (TExp (Maybe TopEntity))
    forall a b. (a -> b) -> a -> b
    $ do
        let expr :: Code Q TopEntity
    expr = TExpQ TopEntity -> Code Q TopEntity
    forall a (m :: Type -> Type). m (TExp a) -> Code m a
    liftCode (Name -> Q (Name, Type)
    getNameBinding Name
    name Q (Name, Type)
    -> ((Name, Type) -> TExpQ TopEntity) -> TExpQ TopEntity
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Maybe String -> (Name, Type) -> TExpQ TopEntity
    buildTopEntity Maybe String
    topName)
        Code Q (Maybe TopEntity) -> Q (TExp (Maybe TopEntity))
    forall (m :: Type -> Type) a. Code m a -> m (TExp a)
    examineCode [|| a -> Maybe a
    forall a. a -> Maybe a
    Just ($$Code Q TopEntity
    expr) ||]
    #else
      recover ([|| Nothing ||]) $ do
        let expr = getNameBinding name >>= buildTopEntity topName
        [|| Just ($$expr) ||]
    #endif

    -- | Turn the 'Name' of a value to a @('Name', 'Type')@
    getNameBinding :: Name -> Q (Name, Type)
    getNameBinding :: Name -> Q (Name, Type)
    getNameBinding Name
    n = Name -> Q Info
    reify Name
    n Q Info -> (Info -> Q (Name, Type)) -> Q (Name, Type)
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
      VarI Name
    name Type
    ty Maybe InstanceDec
    _ -> (Name, Type) -> Q (Name, Type)
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Name
    name, Type
    ty)
      Info
    _ -> String -> Q (Name, Type)
    forall a. String -> Q a
    forall (m :: Type -> Type) a. MonadFail m => String -> m a
    fail String
    "getNameBinding: Invalid Name, must be a top-level binding!"

    -- | Wrap a 'TopEntity' expression in an annotation pragma
    makeTopEntityWithName' :: Name -> Maybe String -> DecQ
    makeTopEntityWithName' :: Name -> Maybe String -> DecQ
    makeTopEntityWithName' Name
    n Maybe String
    topName = do
      (name,ty) <- Name -> Q (Name, Type)
    getNameBinding Name
    n
      topEntity <- buildTopEntity topName (name,ty)
      let prag Exp
    t = Pragma -> InstanceDec
    PragmaD (AnnTarget -> Exp -> Pragma
    AnnP (Name -> AnnTarget
    valueAnnotation Name
    name) Exp
    t)
      return $ prag $ unType topEntity

    -- | Automatically create a @'TopEntity'@ for a given @'Name'@, using the given
    -- @'String'@ to specify the name of the generated RTL entity.
    --
    -- The function arguments and return values of the function specified by the
    -- given @'Name'@ must be annotated with @'(:::)'@. This annotation provides the
    -- given name of the port.
    makeTopEntityWithName :: Name -> String -> DecsQ
    makeTopEntityWithName :: Name -> String -> Q [InstanceDec]
    makeTopEntityWithName Name
    nam String
    top = InstanceDec -> [InstanceDec]
    forall a. a -> [a]
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (InstanceDec -> [InstanceDec]) -> DecQ -> Q [InstanceDec]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> Maybe String -> DecQ
    makeTopEntityWithName' Name
    nam (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    top)

    -- | Automatically create a @'TopEntity'@ for a given @'Name'@. The name of the
    -- generated RTL entity will be the name of the function that has been
    -- specified; e.g. @'makeTopEntity' 'foobar@ will generate a @foobar@ module.
    --
    -- The function arguments and return values of the function specified by the
    -- given @'Name'@ must be annotated with @'(:::)'@. This annotation provides the
    -- given name of the port.
    makeTopEntity :: Name -> DecsQ
    makeTopEntity :: Name -> Q [InstanceDec]
    makeTopEntity Name
    nam = InstanceDec -> [InstanceDec]
    forall a. a -> [a]
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (InstanceDec -> [InstanceDec]) -> DecQ -> Q [InstanceDec]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> Maybe String -> DecQ
    makeTopEntityWithName' Name
    nam Maybe String
    forall a. Maybe a
    Nothing