    {-|
    Copyright  :  (C) 2018-2022, Google Inc
                      2019,      Myrtle Software Ltd
                      2023,      QBayLogic B.V.
    License    :  BSD2 (see the file LICENSE)
    Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
    -}

    {-# LANGUAGE ConstrainedClassMethods #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TypeFamilies #-}

    module Clash.Clocks.Internal
      ( Clocks(..)
      , deriveClocksInstances
      , ClocksSync(..)
      , deriveClocksSyncInstances
      ) where

    import Control.Monad.Extra (concatMapM)
    import Data.Kind (Constraint, Type)
    import GHC.TypeLits (Nat)
    import Language.Haskell.TH hiding (Type)

    import Clash.CPP (haddockOnly)
    import Clash.Explicit.Reset (resetSynchronizer)
    import Clash.Explicit.Signal (unsafeSynchronizer)
    import Clash.Magic (setName)
    import Clash.Promoted.Symbol (SSymbol(..))
    import Clash.Signal.Internal
      (clockGen, Clock(..), Domain, KnownDomain, Reset, Signal, unsafeFromActiveLow,
       unsafeToActiveLow)

    -- | __NB__: The documentation only shows instances up to /3/ output clocks. By
    -- default, instances up to and including /18/ clocks will exist.
    class Clocks t where
      type ClocksCxt t :: Constraint
      type NumOutClocks t :: Nat

      clocks ::
        (KnownDomain domIn, ClocksCxt t) =>
        Clock domIn ->
        Reset domIn ->
        t

    -- Derive instance for /n/ clocks
    deriveClocksInstance :: Int -> DecsQ
    deriveClocksInstance :: Int -> DecsQ
    deriveClocksInstance Int
    n =
      [d| instance Clocks $Q Type
    instType where
            type ClocksCxt $Q Type
    instType = $Q Type
    cxtType
            type NumOutClocks $Q Type
    instType = $Q Type
    numOutClocks

            clocks (Clock _ Nothing) $(Name -> Q Pat
    forall (m :: Type -> Type). Quote m => Name -> m Pat
    varP Name
    rst) = $Q Exp
    funcImpl
            clocks _ _ = error "clocks: dynamic clocks unsupported"
            {-# CLASH_OPAQUE clocks #-}
        |]
     where
      clkTyVar :: a -> m Type
    clkTyVar a
    m = Name -> m Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT (Name -> m Type) -> Name -> m Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "c" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> a -> String
    forall a. Show a => a -> String
    show a
    m
      clkTypes :: [Q Type]
    clkTypes = (Int -> Q Type) -> [Int] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    m -> [t| Clock $(Int -> Q Type
    forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> m Type
    clkTyVar Int
    m) |]) [Int
    1..Int
    n]
      lockTyVar :: Q Type
    lockTyVar = Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT (Name -> Q Type) -> Name -> Q Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName String
    "pllLock"
      -- (Clock c1, Clock c2, ..., Signal pllLock Bool)
      instType :: Q Type
    instType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    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 Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    appT (Int -> Q Type
    forall (m :: Type -> Type). Quote m => Int -> m Type
    tupleT (Int -> Q Type) -> Int -> Q Type
    forall a b. (a -> b) -> a -> b
    $ Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
    forall a b. (a -> b) -> a -> b
    $
                   [Q Type]
    clkTypes [Q Type] -> [Q Type] -> [Q Type]
    forall a. Semigroup a => a -> a -> a
    <> [ [t| Signal $Q Type
    lockTyVar Bool |] ]
      clkKnownDoms :: [Q Type]
    clkKnownDoms = (Int -> Q Type) -> [Int] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    m -> [t| KnownDomain $(Int -> Q Type
    forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> m Type
    clkTyVar Int
    m) |]) [Int
    1..Int
    n]
      -- (KnownDomain c1, KnownDomain c2, ..., KnownDomain pllLock)
      cxtType :: Q Type
    cxtType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    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 Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    appT (Int -> Q Type
    forall (m :: Type -> Type). Quote m => Int -> m Type
    tupleT (Int -> Q Type) -> Int -> Q Type
    forall a b. (a -> b) -> a -> b
    $ Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
    forall a b. (a -> b) -> a -> b
    $
                  [Q Type]
    clkKnownDoms [Q Type] -> [Q Type] -> [Q Type]
    forall a. Semigroup a => a -> a -> a
    <> [ [t| KnownDomain $Q Type
    lockTyVar |] ]
      numOutClocks :: Q Type
    numOutClocks = Q TyLit -> Q Type
    forall (m :: Type -> Type). Quote m => m TyLit -> m Type
    litT (Q TyLit -> Q Type) -> (Integer -> Q TyLit) -> Integer -> Q Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Integer -> Q TyLit
    forall (m :: Type -> Type). Quote m => Integer -> m TyLit
    numTyLit (Integer -> Q Type) -> Integer -> Q Type
    forall a b. (a -> b) -> a -> b
    $ Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger Int
    n

      -- 'clocks' function
      rst :: Name
    rst = String -> Name
    mkName String
    "rst"
      lockImpl :: Q Exp
    lockImpl = [|
        unsafeSynchronizer clockGen clockGen (unsafeToActiveLow $(Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    rst))
        |]
      clkImpls :: [Q Exp]
    clkImpls = Int -> Q Exp -> [Q Exp]
    forall a. Int -> a -> [a]
    replicate Int
    n [| Clock SSymbol Nothing |]
      funcImpl :: Q Exp
    funcImpl = [Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    tupE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Q Exp]
    clkImpls [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. Semigroup a => a -> a -> a
    <> [Q Exp
    lockImpl]

    -- Derive instances for up to and including 18 clocks, except when we are
    -- generating Haddock
    deriveClocksInstances :: DecsQ
    deriveClocksInstances :: DecsQ
    deriveClocksInstances = (Int -> DecsQ) -> [Int] -> DecsQ
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m [b]) -> [a] -> m [b]
    concatMapM Int -> DecsQ
    deriveClocksInstance [Int
    1..Int
    n]
     where
      n :: Int
    n | Bool
    haddockOnly = Int
    3
        | Bool
    otherwise   = Int
    18

    -- | __NB__: The documentation only shows instances up to /3/ output clocks. By
    -- default, instances up to and including /18/ clocks will exist.
    class ClocksSync t where
      type ClocksSyncClocksInst t (domIn :: Domain) :: Type
      type ClocksResetSynchronizerCxt t :: Constraint

      clocksResetSynchronizer ::
        ( KnownDomain domIn
        , ClocksResetSynchronizerCxt t
        ) =>
        ClocksSyncClocksInst t domIn ->
        Clock domIn ->
        t

    -- Derive instance for /n/ clocks
    deriveClocksSyncInstance :: Int -> DecsQ
    deriveClocksSyncInstance :: Int -> DecsQ
    deriveClocksSyncInstance Int
    n =
      [d|
        instance ClocksSync $Q Type
    instType where
          type ClocksSyncClocksInst $Q Type
    instType $Q Type
    domInTyVar = $Q Type
    clocksInstType
          type ClocksResetSynchronizerCxt $Q Type
    instType = $Q Type
    cxtType

          clocksResetSynchronizer pllOut $(Name -> Q Pat
    forall (m :: Type -> Type). Quote m => Name -> m Pat
    varP Name
    clkIn) =
            let $Q Pat
    pllPat = pllOut
            in $Q Exp
    funcImpl
      |]
     where
      clkVarName :: a -> Name
    clkVarName a
    m = String -> Name
    mkName (String -> Name) -> String -> Name
    forall a b. (a -> b) -> a -> b
    $ String
    "c" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> a -> String
    forall a. Show a => a -> String
    show a
    m
      clkTyVar :: Int -> TypeQ
      clkTyVar :: Int -> Q Type
    clkTyVar = Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT (Name -> Q Type) -> (Int -> Name) -> Int -> Q Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Name
    forall {a}. Show a => a -> Name
    clkVarName
      clkAndRstTy :: Int -> [Q Type]
    clkAndRstTy Int
    m = [ [t| Clock $(Int -> Q Type
    clkTyVar Int
    m) |]
                      , [t| Reset $(Int -> Q Type
    clkTyVar Int
    m) |]
                      ]
      -- (Clock c1, Reset c1, Clock c2, Reset c2, ...)
      instType :: Q Type
    instType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    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 Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    appT (Int -> Q Type
    forall (m :: Type -> Type). Quote m => Int -> m Type
    tupleT (Int -> Q Type) -> Int -> Q Type
    forall a b. (a -> b) -> a -> b
    $ Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    2) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
    forall a b. (a -> b) -> a -> b
    $ (Int -> [Q Type]) -> [Int] -> [Q Type]
    forall (t :: Type -> Type) a b.
    Foldable t =>
    (a -> [b]) -> t a -> [b]
    concatMap Int -> [Q Type]
    clkAndRstTy [Int
    1..Int
    n]
      domInTyVar :: Q Type
    domInTyVar = Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT (Name -> Q Type) -> Name -> Q Type
    forall a b. (a -> b) -> a -> b
    $ String -> Name
    mkName String
    "domIn"
      clkTypes :: [Q Type]
    clkTypes = (Int -> Q Type) -> [Int] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    m -> [t| Clock $(Int -> Q Type
    clkTyVar Int
    m) |]) [Int
    1..Int
    n]
      -- (Clock c1, Clock c2, ..., Signal domIn Bool)
      clocksInstType :: Q Type
    clocksInstType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    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 Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    appT (Int -> Q Type
    forall (m :: Type -> Type). Quote m => Int -> m Type
    tupleT (Int -> Q Type) -> Int -> Q Type
    forall a b. (a -> b) -> a -> b
    $ Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
    forall a b. (a -> b) -> a -> b
    $
                         [Q Type]
    clkTypes [Q Type] -> [Q Type] -> [Q Type]
    forall a. Semigroup a => a -> a -> a
    <> [ [t| Signal $Q Type
    domInTyVar Bool |] ]
      -- (KnownDomain c1, KnownDomain c2, ...)
      cxtType :: Q Type
    cxtType
        | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1
        = [t| KnownDomain $(Int -> Q Type
    clkTyVar Int
    1) |]
        | Bool
    otherwise
        = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
    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 Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    appT (Int -> Q Type
    forall (m :: Type -> Type). Quote m => Int -> m Type
    tupleT Int
    n) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
    forall a b. (a -> b) -> a -> b
    $
            (Int -> Q Type) -> [Int] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    m -> [t| KnownDomain $(Int -> Q Type
    clkTyVar Int
    m) |]) [Int
    1..Int
    n]

      -- 'clocksResetSynchronizer' function
      clkIn :: Name
    clkIn = String -> Name
    mkName String
    "clkIn"
      pllLock :: Name
    pllLock = String -> Name
    mkName String
    "pllLock"
      -- (c1, c2, ..., pllLock)
      pllPat :: Q Pat
    pllPat = [Q Pat] -> Q Pat
    forall (m :: Type -> Type). Quote m => [m Pat] -> m Pat
    tupP ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
    forall a b. (a -> b) -> a -> b
    $ (Int -> Q Pat) -> [Int] -> [Q Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Q Pat
    forall (m :: Type -> Type). Quote m => Name -> m Pat
    varP (Name -> Q Pat) -> (Int -> Name) -> Int -> Q Pat
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Name
    forall {a}. Show a => a -> Name
    clkVarName) [Int
    1..Int
    n] [Q Pat] -> [Q Pat] -> [Q Pat]
    forall a. Semigroup a => a -> a -> a
    <> [Name -> Q Pat
    forall (m :: Type -> Type). Quote m => Name -> m Pat
    varP Name
    pllLock]
      syncImpl :: a -> m Exp
    syncImpl a
    m =
        [|
          setName @"resetSynchronizer" (resetSynchronizer $(Name -> m Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE (Name -> m Exp) -> Name -> m Exp
    forall a b. (a -> b) -> a -> b
    $ a -> Name
    forall {a}. Show a => a -> Name
    clkVarName a
    m)
            (unsafeFromActiveLow
              (unsafeSynchronizer $(Name -> m Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    clkIn) $(Name -> m Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE (Name -> m Exp) -> Name -> m Exp
    forall a b. (a -> b) -> a -> b
    $ a -> Name
    forall {a}. Show a => a -> Name
    clkVarName a
    m)
                                  $(Name -> m Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    pllLock))))
        |]
      clkAndRstExp :: a -> [m Exp]
    clkAndRstExp a
    m = [ Name -> m Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE (Name -> m Exp) -> Name -> m Exp
    forall a b. (a -> b) -> a -> b
    $ a -> Name
    forall {a}. Show a => a -> Name
    clkVarName a
    m
                       , a -> m Exp
    forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> m Exp
    syncImpl a
    m
                       ]
      -- (c1, r1, c2, r2, ...) where rN is the synchronized reset for clock N
      funcImpl :: Q Exp
    funcImpl = [Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    tupE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Int -> [Q Exp]) -> [Int] -> [Q Exp]
    forall (t :: Type -> Type) a b.
    Foldable t =>
    (a -> [b]) -> t a -> [b]
    concatMap Int -> [Q Exp]
    forall {m :: Type -> Type} {a}. (Quote m, Show a) => a -> [m Exp]
    clkAndRstExp [Int
    1..Int
    n]

    -- Derive instances for up to and including 18 clocks, except when we are
    -- generating Haddock
    deriveClocksSyncInstances :: DecsQ
    deriveClocksSyncInstances :: DecsQ
    deriveClocksSyncInstances = (Int -> DecsQ) -> [Int] -> DecsQ
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m [b]) -> [a] -> m [b]
    concatMapM Int -> DecsQ
    deriveClocksSyncInstance [Int
    1..Int
    n]
     where
      n :: Int
    n | Bool
    haddockOnly = Int
    3
        | Bool
    otherwise   = Int
    18