{-|
  Copyright   :  (C) 2019     , Google Inc.,
                     2021-2022, QBayLogic B.V.,
                     2021-2022, Myrtle.ai
  License     :  BSD2 (see the file LICENSE)
  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- needed for constraint on the Fixed instance

module Clash.Class.AutoReg.Internal
  ( AutoReg (..)
  , deriveAutoReg
  , deriveAutoRegTuples
  )
  where

import           Data.List                    (nub,zipWith4)
import           Data.Maybe                   (fromMaybe,isJust)

import           GHC.Stack                    (HasCallStack)
import           GHC.TypeNats                 (KnownNat,Nat,type (+))
import           Clash.Explicit.Signal
import           Clash.Promoted.Nat
import           Clash.Magic
import           Clash.XException             (NFDataX, deepErrorX)

import           Clash.Sized.BitVector
import           Clash.Sized.Fixed
import           Clash.Sized.Index
import           Clash.Sized.RTree
import           Clash.Sized.Signed
import           Clash.Sized.Unsigned
import           Clash.Sized.Vector           (Vec, lazyV, smap)

import           Data.Int
import           Data.Word
import           Foreign.C.Types              (CUShort)
import           Numeric.Half                 (Half)

import           Language.Haskell.TH.Datatype
import           Language.Haskell.TH.Syntax
import           Language.Haskell.TH.Lib
import           Language.Haskell.TH.Ppr

import           Control.Lens.Internal.TH     (conAppsT)

-- $setup
-- >>> import Data.Maybe
-- >>> import Clash.Prelude
-- >>> :set -fplugin GHC.TypeLits.Normalise
-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver

-- | 'autoReg' is a "smart" version of 'register'. It does two things:
--
--   1. It splits product types over their fields. For example, given a 3-tuple,
--   the corresponding HDL will end up with three instances of a register (or
--   more if the three fields can be split up similarly).
--
--   2. Given a data type where a constructor indicates (parts) of the data will
--   (not) be updated a given cycle, it will split the data in two parts. The
--   first part will contain the "always interesting" parts (the constructor
--   bits). The second holds the "potentially uninteresting" data (the rest).
--   Both parts will be stored in separate registers. The register holding the
--   "potentially uninteresting" part will only be enabled if the constructor
--   bits indicate they're interesting.
--
--   The most important example of this is 'Maybe'. Consider @Maybe (Signed 16)@;
--   when viewed as bits, a 'Nothing' would look like:
--
--     >>> pack @(Maybe (Signed 16)) Nothing
--     0b0_...._...._...._....
--
--   and 'Just'
--
--     >>> pack @(Maybe (Signed 16)) (Just 3)
--     0b1_0000_0000_0000_0011
--
--   In the first case, Nothing, we don't particularly care about updating the
--   register holding the @Signed 16@ field, as they'll be unknown anyway. We
--   can therefore deassert its enable line.
--
-- Making Clash lay it out like this increases the chances of synthesis tools
-- clock gating the registers, saving energy.
--
-- This version of 'autoReg' will split the given data type up recursively. For
-- example, given @a :: Maybe (Maybe Int, Maybe Int)@, a total of five registers
-- will be rendered. Both the "interesting" and "uninteresting" enable lines of
-- the inner Maybe types will be controlled by the outer one, in addition to
-- the inner parts controlling their "uninteresting" parts as described in (2).
--
-- The default implementation is just 'register'. If you don't need or want
-- the special features of "AutoReg", you can use that by writing an empty instance.
--
-- > data MyDataType = ...
-- > instance AutoReg MyDataType
--
-- If you have a product type you can use 'deriveAutoReg' to derive an instance.
--
class NFDataX a => AutoReg a where
  -- | For documentation see class 'AutoReg'.
  --
  -- This is the version with explicit clock\/reset\/enable inputs,
  -- "Clash.Prelude" exports an implicit version of this: 'Clash.Prelude.autoReg'
  autoReg
    :: (HasCallStack, KnownDomain dom)
    => Clock dom -> Reset dom -> Enable dom
    -> a  -- ^ Reset value
    -> Signal dom a
    -> Signal dom a
  autoReg = Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall (dom :: Domain) a.
(KnownDomain dom, NFDataX a) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
register
  {-# INLINE autoReg #-}

instance AutoReg ()
instance AutoReg Bool

instance AutoReg Double
instance AutoReg Float
instance AutoReg CUShort
instance AutoReg Half

instance AutoReg Char

instance AutoReg Integer
instance AutoReg Int
instance AutoReg Int8
instance AutoReg Int16
instance AutoReg Int32
instance AutoReg Int64
instance AutoReg Word
instance AutoReg Word8
instance AutoReg Word16
instance AutoReg Word32
instance AutoReg Word64

instance AutoReg Bit
instance KnownNat n => AutoReg (BitVector n)
instance AutoReg (Signed n)
instance AutoReg (Unsigned n)
instance AutoReg (Index n)
instance NFDataX (rep (int + frac)) => AutoReg (Fixed rep int frac)

instance AutoReg a => AutoReg (Maybe a) where
  autoReg :: forall (dom :: Domain).
(HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom
-> Enable dom
-> Maybe a
-> Signal dom (Maybe a)
-> Signal dom (Maybe a)
autoReg Clock dom
clk Reset dom
rst Enable dom
en Maybe a
initVal Signal dom (Maybe a)
input =
    Bool -> a -> Maybe a
forall {a}. Bool -> a -> Maybe a
createMaybe (Bool -> a -> Maybe a)
-> Signal dom Bool -> Signal dom (a -> Maybe a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom Bool
tagR Signal dom (a -> Maybe a) -> Signal dom a -> Signal dom (Maybe a)
forall a b. Signal dom (a -> b) -> Signal dom a -> Signal dom b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Signal dom a
valR
   where
     tag :: Signal dom Bool
tag = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Signal dom (Maybe a) -> Signal dom Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Maybe a)
input
     tagInit :: Bool
tagInit = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
initVal
     tagR :: Signal dom Bool
tagR = Clock dom
-> Reset dom
-> Enable dom
-> Bool
-> Signal dom Bool
-> Signal dom Bool
forall (dom :: Domain) a.
(KnownDomain dom, NFDataX a) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
register Clock dom
clk Reset dom
rst Enable dom
en Bool
tagInit Signal dom Bool
tag

     val :: Signal dom a
val = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX String
"autoReg'.val") (Maybe a -> a) -> Signal dom (Maybe a) -> Signal dom a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Maybe a)
input
     valInit :: a
valInit = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX String
"autoReg'.valInit") Maybe a
initVal

     valR :: Signal dom a
valR = Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall a (dom :: Domain).
(AutoReg a, HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall (dom :: Domain).
(HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
autoReg Clock dom
clk Reset dom
rst (Enable dom -> Signal dom Bool -> Enable dom
forall (dom :: Domain). Enable dom -> Signal dom Bool -> Enable dom
andEnable Enable dom
en Signal dom Bool
tag) a
valInit Signal dom a
val

     createMaybe :: Bool -> a -> Maybe a
createMaybe Bool
t a
v = case Bool
t of
       Bool
True -> a -> Maybe a
forall a. a -> Maybe a
Just a
v
       Bool
False -> Maybe a
forall a. Maybe a
Nothing
  {-# INLINE autoReg #-}

instance (KnownNat n, AutoReg a) => AutoReg (Vec n a) where
  autoReg
    :: forall dom. (HasCallStack, KnownDomain dom)
    => Clock dom -> Reset dom -> Enable dom
    -> Vec n a -- ^ Reset value
    -> Signal dom (Vec n a)
    -> Signal dom (Vec n a)
  autoReg :: forall (dom :: Domain).
(HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom
-> Enable dom
-> Vec n a
-> Signal dom (Vec n a)
-> Signal dom (Vec n a)
autoReg Clock dom
clk Reset dom
rst Enable dom
en Vec n a
initVal Signal dom (Vec n a)
xs =
    Unbundled dom (Vec n a) -> Signal dom (Vec n a)
forall a (dom :: Domain).
Bundle a =>
Unbundled dom a -> Signal dom a
forall (dom :: Domain).
Unbundled dom (Vec n a) -> Signal dom (Vec n a)
bundle (Unbundled dom (Vec n a) -> Signal dom (Vec n a))
-> Unbundled dom (Vec n a) -> Signal dom (Vec n a)
forall a b. (a -> b) -> a -> b
$ (forall (n :: Nat). SNat n -> a -> Signal dom a -> Signal dom a)
-> Vec n a -> Vec n (Signal dom a -> Signal dom a)
forall (k :: Nat) a b.
KnownNat k =>
(forall (n :: Nat). SNat n -> a -> b) -> Vec k a -> Vec k b
smap SNat n -> a -> Signal dom a -> Signal dom a
forall (n :: Nat). SNat n -> a -> Signal dom a -> Signal dom a
go (Vec n a -> Vec n a
forall (n :: Nat) a. KnownNat n => Vec n a -> Vec n a
lazyV Vec n a
initVal) Vec n (Signal dom a -> Signal dom a)
-> Vec n (Signal dom a) -> Vec n (Signal dom a)
forall a b. Vec n (a -> b) -> Vec n a -> Vec n b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Signal dom (Vec n a) -> Unbundled dom (Vec n a)
forall a (dom :: Domain).
Bundle a =>
Signal dom a -> Unbundled dom a
forall (dom :: Domain).
Signal dom (Vec n a) -> Unbundled dom (Vec n a)
unbundle Signal dom (Vec n a)
xs
   where
    go :: forall (i :: Nat). SNat i -> a  -> Signal dom a -> Signal dom a
    go :: forall (n :: Nat). SNat n -> a -> Signal dom a -> Signal dom a
go SNat i
SNat = forall (name :: Nat) a. a -> a
suffixNameFromNatP @i ((Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a)
-> (a -> Signal dom a -> Signal dom a)
-> a
-> Signal dom a
-> Signal dom a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall a (dom :: Domain).
(AutoReg a, HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall (dom :: Domain).
(HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
autoReg Clock dom
clk Reset dom
rst Enable dom
en
  {-# INLINE autoReg #-}

instance (KnownNat d, AutoReg a) => AutoReg (RTree d a) where
  autoReg :: forall (dom :: Domain).
(HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom
-> Enable dom
-> RTree d a
-> Signal dom (RTree d a)
-> Signal dom (RTree d a)
autoReg Clock dom
clk Reset dom
rst Enable dom
en RTree d a
initVal Signal dom (RTree d a)
xs =
    Unbundled dom (RTree d a) -> Signal dom (RTree d a)
forall a (dom :: Domain).
Bundle a =>
Unbundled dom a -> Signal dom a
forall (dom :: Domain).
Unbundled dom (RTree d a) -> Signal dom (RTree d a)
bundle (Unbundled dom (RTree d a) -> Signal dom (RTree d a))
-> Unbundled dom (RTree d a) -> Signal dom (RTree d a)
forall a b. (a -> b) -> a -> b
$ (Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall a (dom :: Domain).
(AutoReg a, HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall (dom :: Domain).
(HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
autoReg Clock dom
clk Reset dom
rst Enable dom
en) (a -> Signal dom a -> Signal dom a)
-> RTree d a -> RTree d (Signal dom a -> Signal dom a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> RTree d a -> RTree d a
forall (d :: Nat) a. KnownNat d => RTree d a -> RTree d a
lazyT RTree d a
initVal RTree d (Signal dom a -> Signal dom a)
-> RTree d (Signal dom a) -> RTree d (Signal dom a)
forall a b. RTree d (a -> b) -> RTree d a -> RTree d b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Signal dom (RTree d a) -> Unbundled dom (RTree d a)
forall a (dom :: Domain).
Bundle a =>
Signal dom a -> Unbundled dom a
forall (dom :: Domain).
Signal dom (RTree d a) -> Unbundled dom (RTree d a)
unbundle Signal dom (RTree d a)
xs
  {-# INLINE autoReg #-}


-- | Decompose an applied type into its individual components. For example, this:
--
-- @
-- Either Int Char
-- @
--
-- would be unfolded to this:
--
-- @
-- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char])
-- @
--
-- This function ignores explicit parentheses and visible kind applications.
--
-- NOTE: Copied from "Control.Lens.Internal.TH".
-- TODO: Remove this function. Can be removed once we can upgrade to lens 4.18.
-- TODO: This is currently difficult due to issue with nix.
unfoldType :: Type -> (Type, [Type])
unfoldType :: Type -> (Type, [Type])
unfoldType = [Type] -> Type -> (Type, [Type])
go []
  where
    go :: [Type] -> Type -> (Type, [Type])
    go :: [Type] -> Type -> (Type, [Type])
go [Type]
acc (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
ty) = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
    go [Type]
acc (AppT Type
ty1 Type
ty2)   = [Type] -> Type -> (Type, [Type])
go (Type
ty2Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
acc) Type
ty1
    go [Type]
acc (SigT Type
ty Type
_)      = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
    go [Type]
acc (ParensT Type
ty)     = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#if MIN_VERSION_template_haskell(2,15,0)
    go [Type]
acc (AppKindT Type
ty Type
_)  = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#endif
    go [Type]
acc Type
ty               = (Type
ty, [Type]
acc)

-- | Automatically derives an 'AutoReg' instance for a product type
--
-- Usage:
--
-- > data Pair a b = MkPair { getA :: a, getB :: b } deriving (Generic, NFDataX)
-- > data Tup3 a b c = MkTup3 { getAB :: Pair a b, getC :: c } deriving (Generic, NFDataX)
-- > deriveAutoReg ''Pair
-- > deriveAutoReg ''Tup3
--
-- __NB__: Because of the way template haskell works the order here matters,
-- if you try to @deriveAutoReg ''Tup3@ before @Pair@ it will complain
-- about missing an @instance AutoReg (Pair a b)@.
deriveAutoReg :: Name -> DecsQ
deriveAutoReg :: Name -> DecsQ
deriveAutoReg Name
tyNm = do
  DatatypeInfo
tyInfo <- Name -> Q DatatypeInfo
reifyDatatype Name
tyNm
  case DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
tyInfo of
    [] -> String -> DecsQ
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Can't deriveAutoReg for empty types"
    [ConstructorInfo
conInfo] -> DatatypeInfo -> ConstructorInfo -> DecsQ
deriveAutoRegProduct DatatypeInfo
tyInfo ConstructorInfo
conInfo
    [ConstructorInfo]
_ -> String -> DecsQ
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Can't deriveAutoReg for sum types"



{-
For a type like:
   data Product a b .. = MkProduct { getA :: a, getB :: b, .. }
This generates the following instance:

instance (AutoReg a, AutoReg b, ..) => AutoReg (Product a b ..) where
  autoReg clk rst en initVal input =
    MkProduct <$> sig0 <*> sig1 ...
    where
      field0 = (\(MkProduct x _ ...) -> x) <$> input
      field1 = (\(MkProduct _ x ...) -> x) <$> input
      ...
      MkProduct initVal0 initVal1 ... = initVal
      sig0 = suffixNameP @"getA" autoReg clk rst en initVal0 field0
      sig1 = suffixNameP @"getB" autoReg clk rst en initVal1 field1
      ...
-}
deriveAutoRegProduct :: DatatypeInfo -> ConstructorInfo -> DecsQ
deriveAutoRegProduct :: DatatypeInfo -> ConstructorInfo -> DecsQ
deriveAutoRegProduct DatatypeInfo
tyInfo ConstructorInfo
conInfo = Name -> [(Maybe Name, Type)] -> DecsQ
go (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) [(Maybe Name, Type)]
fieldInfos
 where
  tyNm :: Name
tyNm = DatatypeInfo -> Name
datatypeName DatatypeInfo
tyInfo
#if MIN_VERSION_th_abstraction(0,3,0)
  tyArgs :: [Type]
tyArgs = DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
tyInfo
#else
  tyArgs = datatypeVars tyInfo
#endif
  ty :: Type
ty = Name -> [Type] -> Type
conAppsT Name
tyNm [Type]
tyArgs

  fieldInfos :: [(Maybe Name, Type)]
fieldInfos =
    [Maybe Name] -> [Type] -> [(Maybe Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe Name]
fieldNames (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
conInfo)
   where
    fieldNames :: [Maybe Name]
fieldNames =
      case ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
conInfo of
        RecordConstructor [Name]
nms -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
nms
        ConstructorVariant
_ -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing

  go :: Name -> [(Maybe Name,Type)] -> Q [Dec]
  go :: Name -> [(Maybe Name, Type)] -> DecsQ
go Name
dcNm [(Maybe Name, Type)]
fields = do
    Name
clkN     <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"clk"
    Name
rstN     <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"rst"
    Name
enN      <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"en"
    Name
initValN <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"initVal"
    Name
inputN   <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"input"
    let
      initValE :: Q Exp
initValE = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
initValN
      inputE :: Q Exp
inputE = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
inputN
      argsP :: [Q Pat]
argsP = (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP [Name
clkN, Name
rstN, Name
enN, Name
initValN, Name
inputN]
      fieldNames :: [Maybe Name]
fieldNames = ((Maybe Name, Type) -> Maybe Name)
-> [(Maybe Name, Type)] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Name, Type) -> Maybe Name
forall a b. (a, b) -> a
fst [(Maybe Name, Type)]
fields

      field :: Name -> Int -> DecQ
      field :: Name -> Int -> DecQ
field Name
nm Int
nr =
        Q Pat -> Q Body -> [DecQ] -> DecQ
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m InstanceDec] -> m InstanceDec
valD (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
nm) (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [| $Q Exp
fieldSel <$> $Q Exp
inputE |]) []
       where
        fieldSel :: Q Exp
fieldSel = do
          Name
xNm <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"x"
          let fieldP :: [Q Pat]
fieldP = [ if Int
nr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP Name
xNm else Q Pat
forall (m :: Type -> Type). Quote m => m Pat
wildP
                       | (Int
n,(Maybe Name, Type)
_) <- [Int] -> [(Maybe Name, Type)] -> [(Int, (Maybe Name, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Maybe Name, Type)]
fields]
          [Q Pat] -> Q Exp -> Q Exp
forall (m :: Type -> Type). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP Name
dcNm [Q Pat]
fieldP] (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
xNm)   -- "\(Dc _ _ .. x _ ..) -> x"

    [Name]
parts <- String -> [(Maybe Name, Type)] -> Q [Name]
forall a. String -> [a] -> Q [Name]
generateNames String
"field" [(Maybe Name, Type)]
fields
    [InstanceDec]
fieldDecls <- [DecQ] -> DecsQ
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence ([DecQ] -> DecsQ) -> [DecQ] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (Name -> Int -> DecQ) -> [Name] -> [Int] -> [DecQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Int -> DecQ
field [Name]
parts [Int
0..]
    [Name]
sigs <- String -> [(Maybe Name, Type)] -> Q [Name]
forall a. String -> [a] -> Q [Name]
generateNames String
"sig" [(Maybe Name, Type)]
fields
    [Name]
initVals <- String -> [(Maybe Name, Type)] -> Q [Name]
forall a. String -> [a] -> Q [Name]
generateNames String
"initVal" [(Maybe Name, Type)]
fields
    let initPat :: Q Pat
initPat = Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP Name
dcNm ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP [Name]
initVals)
    InstanceDec
initDecl <- Q Pat -> Q Body -> [DecQ] -> DecQ
forall (m :: Type -> Type).
Quote m =>
m Pat -> m Body -> [m InstanceDec] -> m InstanceDec
valD Q Pat
initPat (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB Q Exp
initValE) []

    let
      clkE :: Q Exp
clkE = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
clkN
      rstE :: Q Exp
rstE = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
rstN
      enE :: Q Exp
enE  = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE Name
enN
      genAutoRegDecl :: PatQ -> ExpQ -> ExpQ -> Maybe Name -> DecsQ
      genAutoRegDecl :: Q Pat -> Q Exp -> Q Exp -> Maybe Name -> DecsQ
genAutoRegDecl Q Pat
s Q Exp
v Q Exp
i Maybe Name
nameM =
        [d| $Q Pat
s = $Q Exp
nameMe autoReg $Q Exp
clkE $Q Exp
rstE $Q Exp
enE $Q Exp
i $Q Exp
v |]
       where
        nameMe :: Q Exp
nameMe = case Maybe Name
nameM of
          Maybe Name
Nothing -> [| id |]
          Just Name
nm -> let nmSym :: Q Type
nmSym = Q TyLit -> Q Type
forall (m :: Type -> Type). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q TyLit
forall (m :: Type -> Type). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
nm)
                     in [| suffixNameP @($Q Type
nmSym) |]

    [InstanceDec]
partDecls <- [[InstanceDec]] -> [InstanceDec]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[InstanceDec]] -> [InstanceDec]) -> Q [[InstanceDec]] -> DecsQ
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DecsQ] -> Q [[InstanceDec]]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence ([DecsQ] -> Q [[InstanceDec]]) -> [DecsQ] -> Q [[InstanceDec]]
forall a b. (a -> b) -> a -> b
$ (Q Pat -> Q Exp -> Q Exp -> Maybe Name -> DecsQ)
-> [Q Pat] -> [Q Exp] -> [Q Exp] -> [Maybe Name] -> [DecsQ]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Q Pat -> Q Exp -> Q Exp -> Maybe Name -> DecsQ
genAutoRegDecl
                                                 (Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
sigs)
                                                 (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
parts)
                                                 (Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
initVals)
                                                 ([Maybe Name]
fieldNames)
                            )
    let
        decls :: [DecQ]
        decls :: [DecQ]
decls = (InstanceDec -> DecQ) -> [InstanceDec] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map InstanceDec -> DecQ
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InstanceDec
initDecl InstanceDec -> [InstanceDec] -> [InstanceDec]
forall a. a -> [a] -> [a]
: [InstanceDec]
fieldDecls [InstanceDec] -> [InstanceDec] -> [InstanceDec]
forall a. [a] -> [a] -> [a]
++ [InstanceDec]
partDecls)
        tyConE :: Q Exp
tyConE = Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
conE Name
dcNm
        body :: Q Exp
body =
          case (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE [Name]
sigs of
            (Q Exp
sig0:[Q Exp]
rest) -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
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
                             (\Q Exp
acc Q Exp
sigN -> [| $Q Exp
acc <*> $Q Exp
sigN |])
                             [| $Q Exp
tyConE <$> $Q Exp
sig0 |]
                             [Q Exp]
rest
            [] -> [| $Q Exp
tyConE |]

    InstanceDec
autoRegDec <- Name -> [Q Clause] -> DecQ
forall (m :: Type -> Type).
Quote m =>
Name -> [m Clause] -> m InstanceDec
funD 'autoReg [[Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m InstanceDec] -> m Clause
clause [Q Pat]
argsP (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB Q Exp
body) [DecQ]
decls]
    [Type]
ctx <- ConstructorInfo -> Q [Type]
calculateRequiredContext ConstructorInfo
conInfo
    [InstanceDec] -> DecsQ
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Maybe Overlap -> [Type] -> Type -> [InstanceDec] -> InstanceDec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
ctx (Type -> Type -> Type
AppT (Name -> Type
ConT ''AutoReg) Type
ty)
              [ InstanceDec
autoRegDec
              , Pragma -> InstanceDec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'autoReg Inline
Inline RuleMatch
FunLike Phases
AllPhases) ]]

-- Calculate the required constraint to call autoReg on all the fields of a
-- given constructor
calculateRequiredContext :: ConstructorInfo -> Q Cxt
calculateRequiredContext :: ConstructorInfo -> Q [Type]
calculateRequiredContext ConstructorInfo
conInfo = do
  let fieldTys :: [Type]
fieldTys = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
conInfo
  [[Type]]
wantedInstances <- (Type -> Q [Type]) -> [Type] -> Q [[Type]]
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
ty -> Name -> [Type] -> Q [Type]
constraintsWantedFor ''AutoReg [Type
ty]) ([Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub [Type]
fieldTys)
  [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub ([[Type]] -> [Type]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Type]]
wantedInstances)

constraintsWantedFor :: Name -> [Type] -> Q Cxt
constraintsWantedFor :: Name -> [Type] -> Q [Type]
constraintsWantedFor Name
clsNm [Type]
tys
  | Name -> String
forall a. Show a => a -> String
show Name
clsNm String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.TypeNats.KnownNat" = do
  -- KnownNat is special, you can't just lookup instances with reifyInstances.
  -- So we just pass KnownNat constraints.
  -- This will most likely require UndecidableInstances.
    [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Name -> [Type] -> Type
conAppsT Name
clsNm [Type]
tys]

constraintsWantedFor Name
clsNm [Type
ty] = case Type
ty of
  VarT Name
_ -> [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Type -> Type -> Type
AppT (Name -> Type
ConT Name
clsNm) Type
ty]
  ConT Name
_ -> [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
  Type
_ -> do
    [InstanceDec]
insts <- Name -> [Type] -> DecsQ
reifyInstances Name
clsNm [Type
ty]
    case [InstanceDec]
insts of
      [InstanceD Maybe Overlap
_ [Type]
cxtInst (AppT Type
autoRegCls Type
instTy) [InstanceDec]
_]
        | Type
autoRegCls Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT Name
clsNm -> do
          let substs :: [(Name, Type)]
substs = Type -> Type -> [(Name, Type)]
findTyVarSubsts Type
instTy Type
ty
              cxt2 :: [Type]
cxt2 = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Type)] -> Type -> Type
applyTyVarSubsts [(Name, Type)]
substs) [Type]
cxtInst
              okCxt :: [Type]
okCxt = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
isOk [Type]
cxt2
              recurseCxt :: [Type]
recurseCxt = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
needRecurse [Type]
cxt2
          [[Type]]
recursed <- (Type -> Q [Type]) -> [Type] -> Q [[Type]]
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 -> Q [Type]
recurse [Type]
recurseCxt
          [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Type]
okCxt [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [[Type]] -> [Type]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Type]]
recursed)
      []      -> String -> Q [Type]
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [Type]) -> String -> Q [Type]
forall a b. (a -> b) -> a -> b
$ String
"Missing instance " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      (InstanceDec
_:InstanceDec
_:[InstanceDec]
_) -> String -> Q [Type]
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [Type]) -> String -> Q [Type]
forall a b. (a -> b) -> a -> b
$ String
"There are multiple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" instances for "
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [InstanceDec] -> String
forall a. Ppr a => a -> String
pprint [InstanceDec]
insts
      [InstanceDec]
_ -> String -> Q [Type]
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [Type]) -> String -> Q [Type]
forall a b. (a -> b) -> a -> b
$ String
"Got unexpected instance: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [InstanceDec] -> String
forall a. Ppr a => a -> String
pprint [InstanceDec]
insts
 where
  isOk :: Type -> Bool
  isOk :: Type -> Bool
isOk (Type -> (Type, [Type])
unfoldType -> (Type
_cls,[Type]
tys)) =
    case [Type]
tys of
      [VarT Name
_] -> Bool
True
      [Type
_] -> Bool
False
      [Type]
_ -> Bool
True -- see [NOTE: MultiParamTypeClasses]
  needRecurse :: Type -> Bool
  needRecurse :: Type -> Bool
needRecurse (Type -> (Type, [Type])
unfoldType -> (Type
cls,[Type]
tys)) =
    case [Type]
tys of
      [AppT Type
_ Type
_] -> Bool
True
      [VarT Name
_] -> Bool
False  -- gets copied by "filter isOk" above
      [ConT Name
_] -> Bool
False  -- we can just drop constraints like: "AutoReg Bool => ..."
      [LitT TyLit
_] -> Bool
False  -- or "KnownNat 4 =>"
      [TupleT Int
0] -> Bool
False  -- handle Unit ()
      [Type
_] -> String -> Bool
forall a. HasCallStack => String -> a
error ( String
"Error while deriveAutoReg: don't know how to handle: "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Type] -> String
forall a. Ppr a => a -> String
pprint [Type]
tys String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" )
      [Type]
_ -> Bool
False  -- see [NOTE: MultiParamTypeClasses]

  recurse :: Type -> Q Cxt
  recurse :: Type -> Q [Type]
recurse (Type -> (Type, [Type])
unfoldType -> (ConT Name
cls,[Type]
tys)) = Name -> [Type] -> Q [Type]
constraintsWantedFor Name
cls [Type]
tys
  recurse Type
t =
    String -> Q [Type]
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Expected a class applied to some arguments but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
t)

constraintsWantedFor Name
clsNm [Type]
tys =
  [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Name -> [Type] -> Type
conAppsT Name
clsNm [Type]
tys] -- see [NOTE: MultiParamTypeClasses]

-- [NOTE: MultiParamTypeClasses]
-- The constraint calculation code doesn't handle MultiParamTypeClasses
-- "properly", but it will try to pass them on, so the resulting instance should
-- still compile with UndecidableInstances enabled.


-- | Find tyVar substitutions between a general type and a second possibly less
-- general type. For example:
--
-- @
-- findTyVarSubsts "Either a b" "Either c [Bool]"
--   == "[(a,c), (b,[Bool])]"
-- @
findTyVarSubsts :: Type -> Type -> [(Name,Type)]
findTyVarSubsts :: Type -> Type -> [(Name, Type)]
findTyVarSubsts = Type -> Type -> [(Name, Type)]
go
 where
  go :: Type -> Type -> [(Name, Type)]
go Type
ty1 Type
ty2 = case (Type
ty1,Type
ty2) of
    (VarT Name
nm1       , VarT Name
nm2) | Name
nm1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm2 -> []
    (VarT Name
nm        , Type
t)                     -> [(Name
nm,Type
t)]
    (ConT Name
_         , ConT Name
_)                -> []
    (AppT Type
x1 Type
y1     , AppT Type
x2 Type
y2)            -> Type -> Type -> [(Name, Type)]
go Type
x1 Type
x2 [(Name, Type)] -> [(Name, Type)] -> [(Name, Type)]
forall a. [a] -> [a] -> [a]
++ Type -> Type -> [(Name, Type)]
go Type
y1 Type
y2
    (SigT Type
t1 Type
k1     , SigT Type
t2 Type
k2)            -> Type -> Type -> [(Name, Type)]
go Type
t1 Type
t2 [(Name, Type)] -> [(Name, Type)] -> [(Name, Type)]
forall a. [a] -> [a] -> [a]
++ Type -> Type -> [(Name, Type)]
go Type
k1 Type
k2
    (InfixT Type
x1 Name
_ Type
y1 , InfixT Type
x2 Name
_ Type
y2)        -> Type -> Type -> [(Name, Type)]
go Type
x1 Type
x2 [(Name, Type)] -> [(Name, Type)] -> [(Name, Type)]
forall a. [a] -> [a] -> [a]
++ Type -> Type -> [(Name, Type)]
go Type
y1 Type
y2
    (UInfixT Type
x1 Name
_ Type
y1, UInfixT Type
x2 Name
_ Type
y2)       -> Type -> Type -> [(Name, Type)]
go Type
x1 Type
x2 [(Name, Type)] -> [(Name, Type)] -> [(Name, Type)]
forall a. [a] -> [a] -> [a]
++ Type -> Type -> [(Name, Type)]
go Type
y1 Type
y2
    (ParensT Type
x1     , ParensT Type
x2)            -> Type -> Type -> [(Name, Type)]
go Type
x1 Type
x2
    (AppKindT Type
t1 Type
k1     , AppKindT Type
t2 Type
k2)      -> Type -> Type -> [(Name, Type)]
go Type
t1 Type
t2 [(Name, Type)] -> [(Name, Type)] -> [(Name, Type)]
forall a. [a] -> [a] -> [a]
++ Type -> Type -> [(Name, Type)]
go Type
k1 Type
k2
    (ImplicitParamT String
_ Type
x1, ImplicitParamT String
_ Type
x2) -> Type -> Type -> [(Name, Type)]
go Type
x1 Type
x2
    (PromotedT Name
_          , PromotedT Name
_          ) -> []
    (TupleT Int
_             , TupleT Int
_             ) -> []
    (UnboxedTupleT Int
_      , UnboxedTupleT Int
_      ) -> []
    (UnboxedSumT Int
_        , UnboxedSumT Int
_        ) -> []
    (Type
ArrowT               , Type
ArrowT               ) -> []
    (Type
EqualityT            , Type
EqualityT            ) -> []
    (Type
ListT                , Type
ListT                ) -> []
    (PromotedTupleT Int
_     , PromotedTupleT Int
_     ) -> []
    (Type
PromotedNilT         , Type
PromotedNilT         ) -> []
    (Type
PromotedConsT        , Type
PromotedConsT        ) -> []
    (Type
StarT                , Type
StarT                ) -> []
    (Type
ConstraintT          , Type
ConstraintT          ) -> []
    (LitT TyLit
_               , LitT TyLit
_               ) -> []
    (Type
WildCardT            , Type
WildCardT            ) -> []
    (Type, Type)
_ -> String -> [(Name, Type)]
forall a. HasCallStack => String -> a
error (String -> [(Name, Type)]) -> String -> [(Name, Type)]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"findTyVarSubsts: Unexpected types"
                         , String
"ty1:", Type -> String
forall a. Ppr a => a -> String
pprint Type
ty1,String
"ty2:", Type -> String
forall a. Ppr a => a -> String
pprint Type
ty2]

applyTyVarSubsts :: [(Name,Type)] -> Type -> Type
applyTyVarSubsts :: [(Name, Type)] -> Type -> Type
applyTyVarSubsts [(Name, Type)]
substs Type
ty = Type -> Type
go Type
ty
  where
    go :: Type -> Type
go Type
ty' = case Type
ty' of
      VarT Name
n -> case Name -> [(Name, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Type)]
substs of
                  Maybe Type
Nothing -> Type
ty'
                  Just Type
m  -> Type
m
      ConT Name
_ -> Type
ty'
      AppT Type
ty1 Type
ty2 -> Type -> Type -> Type
AppT (Type -> Type
go Type
ty1) (Type -> Type
go Type
ty2)
      LitT TyLit
_ -> Type
ty'
      Type
_ -> String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"TODO applyTyVarSubsts: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty'


-- | Generate a list of fresh Name's:
-- prefix0_.., prefix1_.., prefix2_.., ..
generateNames :: String -> [a] -> Q [Name]
generateNames :: forall a. String -> [a] -> Q [Name]
generateNames String
prefix [a]
xs =
  [Q Name] -> Q [Name]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence ((Int -> a -> Q Name) -> [Int] -> [a] -> [Q Name]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n a
_ -> String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show @Int Int
n) [Int
0..] [a]
xs)

deriveAutoRegTuples :: [Int] -> DecsQ
deriveAutoRegTuples :: [Int] -> DecsQ
deriveAutoRegTuples [Int]
xs = [[InstanceDec]] -> [InstanceDec]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[InstanceDec]] -> [InstanceDec]) -> Q [[InstanceDec]] -> DecsQ
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> DecsQ) -> [Int] -> Q [[InstanceDec]]
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 Int -> DecsQ
deriveAutoRegTuple [Int]
xs

deriveAutoRegTuple :: Int -> DecsQ
deriveAutoRegTuple :: Int -> DecsQ
deriveAutoRegTuple Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = String -> DecsQ
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ String
"deriveAutoRegTuple doesn't work for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-tuples"
  | Bool
otherwise = Name -> DecsQ
deriveAutoReg Name
tupN
  where
    tupN :: Name
tupN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"