    {-|
      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 (l :: Nat). SNat l -> 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 (l :: Nat). SNat l -> a -> b) -> Vec k a -> Vec k b
    smap SNat l -> a -> Signal dom a -> Signal dom a
    forall (l :: Nat). SNat l -> 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 (l :: Nat). SNat l -> 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
      tyInfo <- Name -> Q DatatypeInfo
    reifyDatatype Name
    tyNm
      case datatypeCons 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
        clkN     <- String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m Name
    newName String
    "clk"
        rstN     <- newName "rst"
        enN      <- newName "en"
        initValN <- newName "initVal"
        inputN   <- newName "input"
        let
          initValE = Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    initValN
          inputE = Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    inputN
          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, 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
    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
              xNm <- String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m Name
    newName String
    "x"
              let 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]
              lamE [conP dcNm fieldP] (varE xNm)   -- "\(Dc _ _ .. x _ ..) -> x"

        parts <- generateNames "field" fields
        fieldDecls <- sequence $ zipWith field parts [0..]
        sigs <- generateNames "sig" fields
        initVals <- generateNames "initVal" fields
        let 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)
        initDecl <- valD initPat (normalB initValE) []

        let
          clkE = Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    clkN
          rstE = Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    rstN
          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
    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) |]

        partDecls <- concat <$> (sequence $ zipWith4 genAutoRegDecl
                                                     (varP <$> sigs)
                                                     (varE <$> parts)
                                                     (varE <$> initVals)
                                                     (fieldNames)
                                )
        let
            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 = Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    conE Name
    dcNm
            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 |]

        autoRegDec <- funD 'autoReg [clause argsP (normalB body) decls]
        ctx <- calculateRequiredContext conInfo
        return [InstanceD Nothing ctx (AppT (ConT ''AutoReg) ty)
                  [ autoRegDec
                  , PragmaD (InlineP 'autoReg Inline FunLike 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
      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)
      return $ nub (concat 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
        insts <- Name -> [Type] -> DecsQ
    reifyInstances Name
    clsNm [Type
    ty]
        case 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
              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
              return (okCxt ++ concat 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

    #if __GLASGOW_HASKELL__ >= 808
        (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
    #endif

        (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
    ")"