{-|

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 "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
#if !(MIN_VERSION_base(4,11,0))
import           Data.Semigroup                as Semigroup
#endif
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)
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           Clash.Annotations.TopEntity    ( PortName(..)
                                                , TopEntity(..)
                                                )
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 a -> Naming b -> Naming a
(a -> b) -> Naming a -> Naming b
(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
<$ :: a -> Naming b -> Naming a
$c<$ :: forall a b. a -> Naming b -> Naming a
fmap :: (a -> b) -> Naming a -> Naming b
$cfmap :: forall a b. (a -> b) -> Naming a -> Naming b
Functor

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

instance (Semigroup a, 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
#if !(MIN_VERSION_base(4,11,0))
  mappend = (Semigroup.<>)
#endif

-- | 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 $bArrowTy :: Type -> Type -> Type
$mArrowTy :: forall r. Type -> (Type -> Type -> r) -> (Void# -> r) -> r
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 l :: Type
l r :: Type
r) = Type -> [Type]
unapp Type
l [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
r]
unapp t :: 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 x :: Type
x y :: Type
y) = Type
x Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
unarrow Type
y
unarrow _ = []

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

-- | Failure message with a prefix to add some context for end users.
failMsg :: String -> String
failMsg :: String -> String
failMsg s :: String
s = "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 = ((Set Name, String) -> String) -> Tracked Q String
forall (m :: Type -> Type) r a.
Monad m =>
(r -> a) -> ReaderT r m a
asks (Set Name, String) -> 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 s :: 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 :: Name -> b -> Tracked m a -> Tracked m a
visit name :: Name
name a :: b
a = ((Set Name, String) -> (Set Name, String))
-> Tracked m a -> Tracked m a
forall r (m :: Type -> Type) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\t :: (Set Name, String)
t -> (Set Name, String)
t (Set Name, String)
-> ((Set Name, String) -> (Set Name, String)) -> (Set Name, String)
forall a b. a -> (a -> b) -> b
& (Set Name -> Identity (Set Name))
-> (Set Name, String) -> Identity (Set Name, String)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Set Name -> Identity (Set Name))
 -> (Set Name, String) -> Identity (Set Name, String))
-> (Set Name -> Set Name)
-> (Set Name, String)
-> (Set Name, String)
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
                              (Set Name, String)
-> ((Set Name, String) -> (Set Name, String)) -> (Set Name, String)
forall a b. a -> (a -> b) -> b
& (String -> Identity String)
-> (Set Name, String) -> Identity (Set Name, String)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((String -> Identity String)
 -> (Set Name, String) -> Identity (Set Name, String))
-> String -> (Set Name, String) -> (Set Name, String)
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' d :: DatatypeInfo
d = TyVarBndr -> 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 :: a -> (DatatypeInfo -> a) -> Name -> Tracked Q a
tryReifyDatatype a :: a
a f :: DatatypeInfo -> a
f name :: Name
name = Q a -> Tracked Q 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 (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 xs :: [Type]
xs = do
  ([Naming [PortName]] -> Naming [PortName]
forall a. Monoid a => [a] -> a
mconcat ([Naming [PortName]] -> Naming [PortName])
-> ReaderT (Set Name, String) 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 (Set Name, String) Q [Naming [PortName]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Complete names :: [PortName]
names | [PortName] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [PortName]
names Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& [PortName] -> 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 (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 "Partially named constructor arguments!\n"
    x :: Naming [PortName]
x -> Naming [PortName] -> Tracked Q (Naming [PortName])
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 (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (([PortName] -> [PortName])
-> Naming [PortName] -> Naming [PortName]
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 xs :: [ConstructorInfo]
xs =
  ([Naming [PortName]] -> Naming [PortName]
forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold ([Naming [PortName]] -> Naming [PortName])
-> ReaderT (Set Name, String) 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 (Set Name, String) Q [Naming [PortName]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Complete [] -> Naming [PortName] -> Tracked Q (Naming [PortName])
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 []
    x :: 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 "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 c :: Con
c m :: 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 _ ((BangType -> Type) -> [BangType] -> [Type]
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 _ ((VarBangType -> Type) -> [VarBangType] -> [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting Type VarBangType Type -> VarBangType -> Type
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting Type VarBangType Type
forall s t a b. Field3 s t a b => Lens s t a b
_3) -> [Type]
tys)) = [Type]
tys
  ctys (InfixC _ _ (BangType -> Type
forall a b. (a, b) -> b
snd -> Type
ty)) = [Type
ty]
  ctys (ForallC _ _ c' :: Con
c') = Con -> [Type]
ctys Con
c'
  ctys (GadtC _ ((BangType -> Type) -> [BangType] -> [Type]
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 (RecGadtC _ ((VarBangType -> Type) -> [VarBangType] -> [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting Type VarBangType Type -> VarBangType -> Type
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting Type VarBangType Type
forall s t a b. Field3 s t a b => Lens s t a b
_3) -> [Type]
tys) _) = [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
name = do
  [ConstructorInfo]
constructors <- [ConstructorInfo]
-> (DatatypeInfo -> [ConstructorInfo])
-> Name
-> Tracked Q [ConstructorInfo]
forall a. a -> (DatatypeInfo -> a) -> Name -> Tracked Q a
tryReifyDatatype [] DatatypeInfo -> [ConstructorInfo]
datatypeCons Name
name

  Naming [PortName]
names <- case [ConstructorInfo]
constructors of
    []  -> Naming [PortName] -> Tracked Q (Naming [PortName])
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 []
    [x :: ConstructorInfo
x] -> [Type] -> Tracked Q (Naming [PortName])
portsFromTypes (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
x)
    xs :: [ConstructorInfo]
xs  -> [ConstructorInfo] -> Tracked Q (Naming [PortName])
handleNamesInSum [ConstructorInfo]
xs

  case Naming [PortName]
names of
    BackTrack ns :: 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 (Set Name, String) Q ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> ReaderT (Set Name, String) Q ())
-> Q () -> ReaderT (Set Name, String) Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ "Make sure HDL port names are correct:\n"
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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]
++ "\n(Type appears recursive)"
      Naming [PortName] -> Tracked Q (Naming [PortName])
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
        e :: 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 []
        xs :: Set Name
xs -> Set Name -> Naming [PortName]
forall a. Set Name -> Naming a
BackTrack Set Name
xs
    _ -> Naming [PortName] -> Tracked Q (Naming [PortName])
forall (m :: Type -> Type) a. Monad m => a -> m a
return Naming [PortName]
names

-- | 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 split :: Name
split) (LitT (StrTyLit name :: String
name)), _) (_,c :: Tracked Q (Naming [PortName])
c))
  -- Is there a '<String> ::: <something>' annotation?
  | Name
split Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(:::)
  -- 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 (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Complete [] -> Naming [PortName] -> Tracked Q (Naming [PortName])
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 xs :: [PortName]
xs -> Naming [PortName] -> Tracked Q (Naming [PortName])
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]
    x :: Naming [PortName]
x           -> Naming [PortName] -> Tracked Q (Naming [PortName])
forall (m :: Type -> Type) a. Monad m => a -> m a
return Naming [PortName]
x

typeTreeToPorts (ConTF name :: Name
name) = do
  -- Only attempt to resolve a subtree for names we haven't seen before
  Set Name
seen <- ((Set Name, String) -> Set Name)
-> ReaderT (Set Name, String) Q (Set Name)
forall (m :: Type -> Type) r a.
Monad m =>
(r -> a) -> ReaderT r m a
asks (Set Name, String) -> Set Name
forall a b. (a, b) -> a
fst
  if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
name Set Name
seen
  then Naming [PortName] -> Tracked Q (Naming [PortName])
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
$ Set Name -> Naming [PortName]
forall a. Set Name -> Naming a
BackTrack (Set Name -> Naming [PortName]) -> Set Name -> Naming [PortName]
forall a b. (a -> b) -> a -> b
$ Name -> Set Name
forall a. a -> Set a
Set.singleton Name
name
  else Name
-> Name
-> Tracked Q (Naming [PortName])
-> Tracked Q (Naming [PortName])
forall b (m :: Type -> Type) a.
Show b =>
Name -> b -> Tracked m a -> Tracked m a
visit Name
name Name
name (Tracked Q (Naming [PortName]) -> Tracked Q (Naming [PortName]))
-> Tracked Q (Naming [PortName]) -> Tracked Q (Naming [PortName])
forall a b. (a -> b) -> a -> b
$ do
    Info
info <- Q Info -> ReaderT (Set Name, String) Q Info
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> ReaderT (Set Name, String) Q Info)
-> Q Info -> ReaderT (Set Name, String) Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
name
    case Info
info of
      -- Either `name` is an unannotated primitive
      PrimTyConI _ _ _ -> Naming [PortName] -> Tracked Q (Naming [PortName])
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 _ _ t :: Type
t) -> Type -> Tracked Q (Naming [PortName])
gatherNames Type
t
      -- ... or something "datatype" like
      _ -> Name -> Tracked Q (Naming [PortName])
datatypeNameToPorts Name
name

typeTreeToPorts f :: TypeF (Type, Tracked Q (Naming [PortName]))
f@(AppTF (a :: Type
a,a' :: Tracked Q (Naming [PortName])
a') (b :: Type
b,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
    -- Return the inner type for signals
    (ConT x :: Name
x : _ : _ : []) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Clash.Signal.Signal -> Tracked Q (Naming [PortName])
b'
    (ConT x :: Name
x : _ : _ : _ : []) | 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 x :: Name
x : xs :: [Type]
xs) -> do
      Info
info <- Q Info -> ReaderT (Set Name, String) Q Info
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> ReaderT (Set Name, String) Q Info)
-> Q Info -> ReaderT (Set Name, String) Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
x
      case Info
info of
        -- 1. Type synonym case is just inserting the relevant port tree
        (TyConI (TySynD _ synvars :: [TyVarBndr]
synvars def :: 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 -> Name
tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
synvars) Type
def

        -- 2. Match argument lengths, substitute types, and then insert the port
        -- tree
        FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bds :: [TyVarBndr]
bds _ _) eqs :: [TySynEqn]
eqs) _
          | [TyVarBndr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TyVarBndr]
bds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Type]
xs ->
            case (TySynEqn -> Bool) -> [TySynEqn] -> [TySynEqn]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Type]
xs ([Type] -> Bool) -> (TySynEqn -> [Type]) -> TySynEqn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Info -> [Type] -> [Type]
forall p. TypeSubstitution p => [Type] -> Info -> p -> p
applyFamilyBindings [Type]
xs Info
info ([Type] -> [Type]) -> (TySynEqn -> [Type]) -> TySynEqn -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TySynEqn -> [Type]
tySynArgs) [TySynEqn]
eqs of
#if MIN_VERSION_template_haskell(2,15,0)
              [TySynEqn _ _ r :: Type
r] ->
#else
              [TySynEqn _ r]   ->
#endif
                Type -> Tracked Q (Naming [PortName])
gatherNames ([Type] -> Info -> Type -> Type
forall p. TypeSubstitution p => [Type] -> Info -> p -> p
applyFamilyBindings [Type]
xs Info
info Type
r)

              -- We didn't find a (single) matching instance so give up. Is this
              -- impossible?
              _ -> Naming [PortName] -> Tracked Q (Naming [PortName])
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 -> 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 (t :: Type -> Type) a. Foldable t => t a -> Int
length [Type]
xs) -> do
          (Q [Dec] -> ReaderT (Set Name, String) Q [Dec]
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT (Set Name, String) Q [Dec])
-> Q [Dec] -> ReaderT (Set Name, String) Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Q [Dec]
reifyInstances Name
x [Type]
xs) ReaderT (Set Name, String) Q [Dec]
-> ([Dec] -> Tracked Q (Naming [PortName]))
-> Tracked Q (Naming [PortName])
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 _ _ r :: Type
r)] ->
#else
            [TySynInstD _ (TySynEqn _ r)] ->
#endif
                Type -> Tracked Q (Naming [PortName])
gatherNames ([Type] -> Info -> Type -> Type
forall p. TypeSubstitution p => [Type] -> Info -> p -> p
applyFamilyBindings [Type]
xs Info
info Type
r)

            [NewtypeInstD _ _ _ _ c :: 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)
            [DataInstD    _ _ _ _ cs :: [Con]
cs _] -> do
              case [Con]
cs of
                [c :: 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)
                _ -> Naming [PortName] -> Tracked Q (Naming [PortName])
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 []
            y :: [Dec]
y -> String -> Tracked Q (Naming [PortName])
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 "Encountered unexpected type during family application!"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Dec] -> String
forall a. Ppr a => a -> String
pprint [Dec]
y

        -- 4. Check if head really is a datatype, apply free variables,
        --    and attempt to get a unique constructor
        _ -> do
          Maybe DatatypeInfo
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 -> Bool
hasAllArgs   = \vs :: DatatypeInfo
vs -> [Type] -> 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 (t :: Type -> Type) a. Foldable t => t a -> Int
length (DatatypeInfo -> [TyVarBndr]
datatypeVars DatatypeInfo
vs)
              constructors :: Maybe [ConstructorInfo]
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] -> m b
getSingleConstructor cs :: m [b]
cs = do [c :: b
c] <- m [b]
cs; b -> m b
forall (m :: Type -> Type) a. Monad m => a -> m a
return b
c
              constructor :: Maybe ConstructorInfo
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.
          Tracked Q (Naming [PortName])
-> (ConstructorInfo -> Tracked Q (Naming [PortName]))
-> Maybe ConstructorInfo
-> Tracked Q (Naming [PortName])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Tracked Q (Naming [PortName])
a' (Name
-> Doc
-> Tracked Q (Naming [PortName])
-> Tracked Q (Naming [PortName])
forall b (m :: Type -> Type) a.
Show b =>
Name -> b -> Tracked m a -> Tracked m a
visit Name
x (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
x) (Tracked Q (Naming [PortName]) -> Tracked Q (Naming [PortName]))
-> (ConstructorInfo -> Tracked Q (Naming [PortName]))
-> ConstructorInfo
-> Tracked Q (Naming [PortName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Tracked Q (Naming [PortName])
portsFromTypes ([Type] -> Tracked Q (Naming [PortName]))
-> (ConstructorInfo -> [Type])
-> ConstructorInfo
-> Tracked Q (Naming [PortName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstructorInfo -> [Type]
constructorFields) Maybe ConstructorInfo
constructor

    -- If head is a tuple or list then we take all the names
    (ListT:_)    -> TypeF (Naming [PortName]) -> Naming [PortName]
forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold (TypeF (Naming [PortName]) -> Naming [PortName])
-> ReaderT (Set Name, String) 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 (Set Name, String) 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)
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 _:_) -> TypeF (Naming [PortName]) -> Naming [PortName]
forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold (TypeF (Naming [PortName]) -> Naming [PortName])
-> ReaderT (Set Name, String) 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 (Set Name, String) 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)
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
    _ -> do
      Q () -> ReaderT (Set Name, String) Q ()
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q () -> ReaderT (Set Name, String) Q ())
-> Q () -> ReaderT (Set Name, String) Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ "Make sure HDL port names are correct:\n"
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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)
      TypeF (Naming [PortName])
f' <- ((Type, Tracked Q (Naming [PortName]))
 -> Tracked Q (Naming [PortName]))
-> TypeF (Type, Tracked Q (Naming [PortName]))
-> ReaderT (Set Name, String) 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)
mapM (Type, Tracked Q (Naming [PortName]))
-> Tracked Q (Naming [PortName])
forall a b. (a, b) -> b
snd TypeF (Type, Tracked Q (Naming [PortName]))
f
      Naming [PortName] -> Tracked Q (Naming [PortName])
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
$ TypeF (Naming [PortName]) -> Naming [PortName]
forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold TypeF (Naming [PortName])
f'
 where
  tyMap :: [a] -> [k] -> Map k a
tyMap ctx :: [a]
ctx holes :: [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 ctx :: [a]
ctx (Info -> Maybe [TyVarBndr]
familyBindings -> Just holes :: [TyVarBndr]
holes) = [a] -> [Name] -> Map Name a
forall k a. Ord k => [a] -> [k] -> Map k a
tyMap [a]
ctx (TyVarBndr -> Name
tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
holes)
  familyTyMap _ _  = String -> Map Name a
forall a. HasCallStack => String -> a
error "familyTyMap called with non family argument!"
  applyContext :: [Type] -> [Name] -> a -> a
applyContext ctx :: [Type]
ctx holes :: [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 ctx :: [Type]
ctx d :: 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 -> p -> p
applyFamilyBindings ctx :: [Type]
ctx (Info -> Maybe [TyVarBndr]
familyBindings -> Just holes :: [TyVarBndr]
holes) t :: p
t
    = [Type] -> [Name] -> p -> p
forall a. TypeSubstitution a => [Type] -> [Name] -> a -> a
applyContext [Type]
ctx (TyVarBndr -> Name
tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
holes) p
t
  applyFamilyBindings _ _ _ = String -> p
forall a. HasCallStack => String -> a
error "familyTyMap called with non family argument!"

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

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

typeTreeToPorts f :: TypeF (Type, Tracked Q (Naming [PortName]))
f = do
  -- Just collect names
  TypeF (Naming [PortName])
f' <- ((Type, Tracked Q (Naming [PortName]))
 -> Tracked Q (Naming [PortName]))
-> TypeF (Type, Tracked Q (Naming [PortName]))
-> ReaderT (Set Name, String) 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)
mapM (Type, Tracked Q (Naming [PortName]))
-> Tracked Q (Naming [PortName])
forall a b. (a, b) -> b
snd TypeF (Type, Tracked Q (Naming [PortName]))
f
  Naming [PortName] -> Tracked Q (Naming [PortName])
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
$ TypeF (Naming [PortName]) -> Naming [PortName]
forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold TypeF (Naming [PortName])
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
para Base Type (Type, Tracked Q (Naming [PortName]))
-> Tracked Q (Naming [PortName])
TypeF (Type, Tracked Q (Naming [PortName]))
-> Tracked Q (Naming [PortName])
typeTreeToPorts

-- | Build a possible failing 'PortName' tree and unwrap the 'Naming' result.
buildPorts
  :: Type
  -- ^ Type to investigate
  -> Q [PortName]
buildPorts :: Type -> Q [PortName]
buildPorts x :: Type
x = do
  (ReaderT (Set Name, String) Q [PortName]
 -> (Set Name, String) -> Q [PortName])
-> (Set Name, String)
-> ReaderT (Set Name, String) Q [PortName]
-> Q [PortName]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Set Name, String) Q [PortName]
-> (Set Name, String) -> Q [PortName]
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (Set Name
forall a. Set a
Set.empty, "") (ReaderT (Set Name, String) Q [PortName] -> Q [PortName])
-> ReaderT (Set Name, String) 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 (Set Name, String) Q [PortName])
-> ReaderT (Set Name, String) Q [PortName]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Complete xs :: [PortName]
xs -> [PortName] -> ReaderT (Set Name, String) Q [PortName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [PortName]
xs
      HasFail err :: String
err -> String -> ReaderT (Set Name, String) Q [PortName]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err
      BackTrack n :: Set Name
n -> String -> ReaderT (Set Name, String) Q [PortName]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ReaderT (Set Name, String) Q [PortName])
-> String -> ReaderT (Set Name, String) Q [PortName]
forall a b. (a -> b) -> a -> b
$ String -> String
failMsg "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 _ b :: Type
b) = Type -> Q PortName
toReturnName Type
b
toReturnName b :: Type
b             =
  Type -> Q [PortName]
buildPorts Type
b
  Q [PortName] -> ([PortName] -> Q PortName) -> Q PortName
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
     [] -> String -> Q PortName
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 "No return name specified!"
     [x :: PortName
x] -> PortName -> Q PortName
forall (m :: Type -> Type) a. Monad m => a -> m a
return PortName
x
     xs :: [PortName]
xs -> PortName -> Q PortName
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 "" [PortName]
xs

-- | Get the argument 'PortName's from a function type
toArgNames :: Type -> Q [PortName]
toArgNames :: Type -> Q [PortName]
toArgNames ty :: 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)
traverse Type -> Q PortName
build (Type -> [Type]
unarrow Type
ty)
 where
  build :: Type -> Q PortName
build x :: Type
x = Type -> Q [PortName]
buildPorts Type
x Q [PortName] -> ([PortName] -> Q PortName) -> Q PortName
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 x :: a
x []  = String -> m PortName
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 "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 (m :: Type -> Type) a. Monad m => a -> m a
return PortName
a
  check _ xs :: [PortName]
xs  = PortName -> m PortName
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 "" [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
/= :: ClockType -> ClockType -> Bool
$c/= :: ClockType -> ClockType -> Bool
== :: ClockType -> ClockType -> Bool
$c== :: 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 [] [] x :: Type
x) clk :: ClockType
clk = Type -> ClockType -> Q (Type, ClockType)
handleConstraints Type
x ClockType
clk
handleConstraints (ForallT xs :: [TyVarBndr]
xs@(_:_) _ _) _ =
  String -> Q (Type, ClockType)
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 "Free type variables!\n"
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TyVarBndr] -> String
forall a. Ppr a => a -> String
pprint [TyVarBndr]
xs
handleConstraints (ForallT _ c :: [Type]
c x :: Type
x) clk :: ClockType
clk = Type -> ClockType -> Q (Type, ClockType)
handleConstraints Type
x ClockType
hiddenClocks
 where
  hiddenClocks :: ClockType
hiddenClocks = (ClockType -> Type -> ClockType)
-> ClockType -> [Type] -> ClockType
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 a :: ClockType
a (AppT (ConT b :: Name
b) _)
    | 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 a :: ClockType
a _ = ClockType
a
handleConstraints x :: Type
x clk :: ClockType
clk = (Type, ClockType) -> Q (Type, ClockType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type
x, ClockType
clk)

clockToPorts :: ClockType -> Q [PortName]
clockToPorts :: ClockType -> Q [PortName]
clockToPorts None = [PortName] -> Q [PortName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
clockToPorts (ClockType
SingleClockResetEnable) =
  [PortName] -> Q [PortName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [String -> [PortName] -> PortName
PortProduct "" [ String -> PortName
PortName "clk" , String -> PortName
PortName "rst" , String -> PortName
PortName "en" ]]
clockToPorts Other =
  String -> Q [PortName]
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 "TH generation for multiple hidden clocks and"
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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 topName :: Maybe String
topName (name :: Name
name, ty :: Type
ty) = do
    (ty' :: Type
ty', clock :: ClockType
clock) <- Type -> ClockType -> Q (Type, ClockType)
handleConstraints Type
ty ClockType
None

    [PortName]
ins   <- ([PortName] -> [PortName] -> [PortName])
-> Q [PortName] -> Q [PortName] -> Q [PortName]
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [PortName] -> [PortName] -> [PortName]
forall a. Semigroup a => a -> a -> a
(<>) (ClockType -> Q [PortName]
clockToPorts ClockType
clock) (Type -> Q [PortName]
toArgNames Type
ty')
    PortName
out   <- Type -> Q PortName
toReturnName Type
ty'

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

    [|| 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 topName :: Maybe String
topName name :: Name
name = do
  Q (TExp (Maybe TopEntity))
-> Q (TExp (Maybe TopEntity)) -> Q (TExp (Maybe TopEntity))
forall a. Q a -> Q a -> Q a
recover ([|| 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 :: TExpQ TopEntity
expr = Name -> Q (Name, Type)
getNameBinding Name
name Q (Name, Type)
-> ((Name, Type) -> TExpQ TopEntity) -> TExpQ TopEntity
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
    [|| Just ($$expr) ||]

-- | Turn the 'Name' of a value to a @('Name', 'Type')@
getNameBinding :: Name -> Q (Name, Type)
getNameBinding :: Name -> Q (Name, Type)
getNameBinding n :: Name
n = Name -> Q Info
reify Name
n Q Info -> (Info -> Q (Name, Type)) -> Q (Name, Type)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  VarI name :: Name
name ty :: Type
ty _ -> (Name, Type) -> Q (Name, Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Name
name, Type
ty)
  _ -> String -> Q (Name, Type)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail "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' n :: Name
n topName :: Maybe String
topName = do
  (name :: Name
name,ty :: Type
ty) <- Name -> Q (Name, Type)
getNameBinding Name
n
  TExp TopEntity
topEntity <- Maybe String -> (Name, Type) -> TExpQ TopEntity
buildTopEntity Maybe String
topName (Name
name,Type
ty)
  let prag :: Exp -> Dec
prag t :: Exp
t = Pragma -> Dec
PragmaD (AnnTarget -> Exp -> Pragma
AnnP (Name -> AnnTarget
valueAnnotation Name
name) Exp
t)
  Dec -> DecQ
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Dec -> DecQ) -> Dec -> DecQ
forall a b. (a -> b) -> a -> b
$ Exp -> Dec
prag (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ TExp TopEntity -> Exp
forall a. TExp a -> Exp
unType TExp TopEntity
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 [Dec]
makeTopEntityWithName nam :: Name
nam top :: String
top = Dec -> [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> DecQ -> Q [Dec]
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 [Dec]
makeTopEntity nam :: Name
nam = Dec -> [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> DecQ -> Q [Dec]
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