    {-|
    Copyright  :  (C) 2024, QBayLogic B.V.
    License    :  BSD2 (see the file LICENSE)
    Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>
    -}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE TemplateHaskell #-}

    module Clash.Signal.Bundle.Internal (deriveBundleTuples, idPrimitive) where

    import           Control.Monad.Extra         (concatMapM)
    import           Clash.Annotations.Primitive (Primitive(InlineYamlPrimitive))
    import           Clash.CPP                   (maxTupleSize)
    import           Clash.Signal.Internal       (Signal((:-)))
    import           Clash.XException            (seqX)
    #if !MIN_VERSION_base(4,20,0)
    import           Data.List                   (foldl')
    #endif
    import           Data.List                   (uncons)
    import           Data.String.Interpolate     (__i)
    import qualified Language.Haskell.TH.Syntax  as TH
    import           Language.Haskell.TH
    import           Language.Haskell.TH.Compat

    idPrimitive :: TH.Name -> DecQ
    idPrimitive :: Name -> DecQ
    idPrimitive Name
    nm =
      Pragma -> Dec
    PragmaD (Pragma -> Dec) -> (Exp -> Pragma) -> Exp -> Dec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . AnnTarget -> Exp -> Pragma
    AnnP (Name -> AnnTarget
    ValueAnnotation Name
    nm) (Exp -> Dec) -> Q Exp -> DecQ
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Primitive -> Q Exp
    forall (m :: Type -> Type) a. (Quote m, Data a) => a -> m Exp
    TH.liftData Primitive
    ip
     where
      ip :: Primitive
    ip = [HDL] -> String -> Primitive
    InlineYamlPrimitive [HDL
    forall a. Bounded a => a
    minBound..] [__i|
             Primitive:
               name: #{nm}
               primType: Function
             |]

    -- | Contruct all the tuple instances for Bundle.
    deriveBundleTuples
      :: Name
      -- ^ Bundle
      -> Name
      -- ^ Unbundled
      -> Name
      -- ^ bundle
      -> Name
      -- ^ unbundle
      -> DecsQ
    deriveBundleTuples :: Name -> Name -> Name -> Name -> DecsQ
    deriveBundleTuples Name
    bundleTyName Name
    unbundledTyName Name
    bundleName Name
    unbundleName = do
      let bundleTy :: Type
    bundleTy = Name -> Type
    ConT Name
    bundleTyName
          signal :: Type
    signal   = Name -> Type
    ConT ''Signal

          aNamesAll :: [Name]
    aNamesAll = (Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    i -> String -> Name
    mkName (Char
    'a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Int -> String
    forall a. Show a => a -> String
    show Int
    i)) [Int
    1..Int
    forall a. Num a => a
    maxTupleSize::Int]
          aPrimeNamesAll :: [Name]
    aPrimeNamesAll = (Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    i -> String -> Name
    mkName (Char
    'a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Int -> String
    forall a. Show a => a -> String
    show Int
    iString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "'")) [Int
    1..Int
    forall a. Num a => a
    maxTupleSize::Int]
          asNamesAll :: [Name]
    asNamesAll = (Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    i -> String -> Name
    mkName (String
    "as" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> Int -> String
    forall a. Show a => a -> String
    show Int
    i)) [Int
    1..Int
    forall a. Num a => a
    maxTupleSize::Int]
          tNm :: Name
    tNm = String -> Name
    mkName String
    "t"
          sTailNm :: Name
    sTailNm = String -> Name
    mkName String
    "sTail"
          sNm :: Name
    sNm = String -> Name
    mkName String
    "s"

      ((Int -> DecsQ) -> [Int] -> DecsQ)
    -> [Int] -> (Int -> DecsQ) -> DecsQ
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Int -> DecsQ) -> [Int] -> DecsQ
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m [b]) -> [a] -> m [b]
    concatMapM [Int
    2..Int
    forall a. Num a => a
    maxTupleSize] ((Int -> DecsQ) -> DecsQ) -> (Int -> DecsQ) -> DecsQ
    forall a b. (a -> b) -> a -> b
    $ \Int
    tupleNum ->
        let aNames :: [Name]
    aNames = Int -> [Name] -> [Name]
    forall a. Int -> [a] -> [a]
    take Int
    tupleNum [Name]
    aNamesAll
            aPrimeNames :: [Name]
    aPrimeNames = Int -> [Name] -> [Name]
    forall a. Int -> [a] -> [a]
    take Int
    tupleNum [Name]
    aPrimeNamesAll
            asNames :: [Name]
    asNames = Int -> [Name] -> [Name]
    forall a. Int -> [a] -> [a]
    take Int
    tupleNum [Name]
    asNamesAll
            vars :: [Type]
    vars  = (Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Type
    VarT [Name]
    aNames

            bundlePrimName :: Name
    bundlePrimName = String -> Name
    mkName (String
    "bundle" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    tupleNum String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "#")
            unbundlePrimName :: Name
    unbundlePrimName = String -> Name
    mkName (String
    "unbundle" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    tupleNum String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "#")
            qualBundleNm :: Name
    qualBundleNm = String -> Name
    mkName (String
    "Clash.Signal.Bundle.bundle" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    tupleNum String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "#")
            qualUnbundlePrimName :: Name
    qualUnbundlePrimName = String -> Name
    mkName (String
    "Clash.Signal.Bundle.unbundle" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    tupleNum String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "#")

            mkTupleT :: [Type] -> Type
    mkTupleT = (Type -> Type -> Type) -> Type -> [Type] -> 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' Type -> Type -> Type
    AppT (Int -> Type
    TupleT Int
    tupleNum)

            -- Instance declaration
            instTy :: Type
    instTy = Type -> Type -> Type
    AppT Type
    bundleTy (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ [Type] -> Type
    mkTupleT [Type]
    vars

            -- Associated type Unbundled
    #if MIN_VERSION_template_haskell(2,15,0)
            unbundledTypeEq :: TySynEqn
    unbundledTypeEq =
              Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
    TySynEqn Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing
                ((Name -> Type
    ConT Name
    unbundledTyName Type -> Type -> Type
    `AppT`
                    Name -> Type
    VarT Name
    tNm ) Type -> Type -> Type
    `AppT` [Type] -> Type
    mkTupleT [Type]
    vars )
                (Type -> TySynEqn) -> Type -> TySynEqn
    forall a b. (a -> b) -> a -> b
    $ [Type] -> Type
    mkTupleT ([Type] -> Type) -> [Type] -> Type
    forall a b. (a -> b) -> a -> b
    $ (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type -> Type -> Type
    AppT (Type
    signal Type -> Type -> Type
    `AppT` Name -> Type
    VarT Name
    tNm)) [Type]
    vars
            unbundledType :: Dec
    unbundledType = TySynEqn -> Dec
    TySynInstD TySynEqn
    unbundledTypeEq
    #else
            unbundledTypeEq =
              TySynEqn
                [ VarT tNm, mkTupleT vars ]
                $ mkTupleT $ map (AppT (signal `AppT` VarT tNm)) vars
            unbundledType = TySynInstD unbundledTyName unbundledTypeEq
    #endif

            mkFunD :: Name -> Name -> Dec
    mkFunD Name
    nm Name
    alias = Name -> [Clause] -> Dec
    FunD Name
    nm [[Pat] -> Body -> [Dec] -> Clause
    Clause [] (Exp -> Body
    NormalB (Name -> Exp
    VarE Name
    alias)) []]
            bundleD :: Dec
    bundleD = Name -> Name -> Dec
    mkFunD Name
    bundleName Name
    bundlePrimName
            unbundleD :: Dec
    unbundleD = Name -> Name -> Dec
    mkFunD Name
    unbundleName Name
    unbundlePrimName

            sigType :: Type -> Type
    sigType Type
    t = Name -> Type
    ConT ''Signal Type -> Type -> Type
    `AppT` Name -> Type
    VarT (String -> Name
    mkName String
    "dom") Type -> Type -> Type
    `AppT` Type
    t

            -- unbundle3# ~s@((a, b, c) :- abcs) =
            --   let (as, bs, cs) = s `seq` unbundle3# abcs in
            --   (a :- as, b :- bs, c :- cs)
            unbundleNoInlineAnn :: Dec
    unbundleNoInlineAnn = Pragma -> Dec
    PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
    InlineP Name
    unbundlePrimName Inline
    NoInline RuleMatch
    FunLike Phases
    AllPhases)

            unbundleSig :: Dec
    unbundleSig = Name -> Type -> Dec
    SigD Name
    unbundlePrimName (
              [Type] -> Type -> Type
    forall (t :: Type -> Type). Foldable t => t Type -> Type -> Type
    mkFunTys
                [[Type] -> Type
    mkTupleT ((Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Type
    sigType ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    aNames))]
                (Type -> Type
    sigType ([Type] -> Type
    mkTupleT ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    aNames)))
              )

            seqE :: Name -> Exp -> Exp
    seqE Name
    nm Exp
    res = Exp -> Exp -> Exp -> Exp
    UInfixE (Name -> Exp
    VarE Name
    nm) (Name -> Exp
    VarE 'seq) Exp
    res
            seqXE :: Name -> Exp -> Exp
    seqXE Name
    nm Exp
    res = Exp -> Exp -> Exp -> Exp
    UInfixE (Name -> Exp
    VarE Name
    nm) (Name -> Exp
    VarE 'seqX) Exp
    res

            unbundleFBody :: Exp
    unbundleFBody =
              [Dec] -> Exp -> Exp
    LetE
                [ Pat -> Body -> [Dec] -> Dec
    ValD
                    ([Pat] -> Pat
    TupP ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    asNames))
                    (Exp -> Body
    NormalB (
                      Name
    tNm Name -> Exp -> Exp
    `seqXE` (Name
    sNm Name -> Exp -> Exp
    `seqE` (Name -> Exp
    VarE Name
    unbundlePrimName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    sTailNm)))) []]
                ([Exp] -> Exp
    mkTupE
                  ((Name -> Name -> Exp) -> [Name] -> [Name] -> [Exp]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith
                    (\Name
    a Name
    as -> Exp -> Exp -> Exp -> Exp
    UInfixE (Name -> Exp
    VarE Name
    a) (Name -> Exp
    ConE '(:-)) (Name -> Exp
    VarE Name
    as))
                    [Name]
    aNames
                    [Name]
    asNames))

            unbundleF :: Dec
    unbundleF =
              Name -> [Clause] -> Dec
    FunD
                Name
    unbundlePrimName
                [[Pat] -> Body -> [Dec] -> Clause
    Clause
                  [Name -> Pat -> Pat
    AsP Name
    sNm (Pat -> Pat
    TildeP (Pat -> Name -> Pat -> Pat
    UInfixP
                                     (Name -> Pat -> Pat
    AsP Name
    tNm (Pat -> Pat
    TildeP ([Pat] -> Pat
    TupP ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    aNames))))
                                     '(:-)
                                     (Name -> Pat
    VarP Name
    sTailNm)))]
                  (Exp -> Body
    NormalB Exp
    unbundleFBody)
                  [] ]

            -- bundle2# (a1, a2) = (\ a1' a2' -> (a1', a2')) <$> a1 <*> a2
            bundleNoInlineAnn :: Dec
    bundleNoInlineAnn = Pragma -> Dec
    PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
    InlineP Name
    bundlePrimName Inline
    NoInline RuleMatch
    FunLike Phases
    AllPhases)

            bundleSig :: Dec
    bundleSig = Name -> Type -> Dec
    SigD Name
    bundlePrimName (
              [Type] -> Type -> Type
    forall (t :: Type -> Type). Foldable t => t Type -> Type -> Type
    mkFunTys
                [Type -> Type
    sigType ([Type] -> Type
    mkTupleT ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    aNames))]
                ([Type] -> Type
    mkTupleT ((Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Type
    sigType ((Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    aNames)))
              )

            bundleFmap :: Exp
    bundleFmap =
              Exp -> Exp -> Exp -> Exp
    UInfixE
                ([Pat] -> Exp -> Exp
    LamE ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    aPrimeNames) ([Exp] -> Exp
    mkTupE ((Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Exp
    VarE [Name]
    aPrimeNames)))
                (Name -> Exp
    VarE '(<$>))
                (Name -> Exp
    VarE (Name -> ((Name, [Name]) -> Name) -> Maybe (Name, [Name]) -> Name
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Name
    forall a. HasCallStack => String -> a
    error String
    "impossible") (Name, [Name]) -> Name
    forall a b. (a, b) -> a
    fst ([Name] -> Maybe (Name, [Name])
    forall a. [a] -> Maybe (a, [a])
    uncons [Name]
    aNames)))

            bundleFBody :: Exp
    bundleFBody =
              (Exp -> Name -> Exp) -> Exp -> [Name] -> 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'
                (\Exp
    e Name
    n -> Exp -> Exp -> Exp -> Exp
    UInfixE Exp
    e (Name -> Exp
    VarE '(<*>)) (Name -> Exp
    VarE Name
    n))
                Exp
    bundleFmap
                (Int -> [Name] -> [Name]
    forall a. Int -> [a] -> [a]
    drop Int
    1 [Name]
    aNames)

            bundleF :: Dec
    bundleF =
              Name -> [Clause] -> Dec
    FunD
                Name
    bundlePrimName
                [[Pat] -> Body -> [Dec] -> Clause
    Clause
                  [[Pat] -> Pat
    TupP ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    aNames)]
                  (Exp -> Body
    NormalB Exp
    bundleFBody)
                  [] ]
        in do
          unbundlePrimAnn <- Name -> DecQ
    idPrimitive Name
    qualUnbundlePrimName
          bundlePrimAnn <- idPrimitive qualBundleNm
          pure [ -- Instance and its methods
                 InstanceD Nothing [] instTy [unbundledType, bundleD, unbundleD]

                 -- Bundle primitive
               , bundleSig, bundleF, bundlePrimAnn, bundleNoInlineAnn

                 -- Unbundle primitive
               , unbundleSig, unbundleF, unbundlePrimAnn, unbundleNoInlineAnn
               ]

    mkFunTys :: Foldable t => t TH.Type -> TH.Type -> TH.Type
    mkFunTys :: forall (t :: Type -> Type). Foldable t => t Type -> Type -> Type
    mkFunTys t Type
    args Type
    res= (Type -> Type -> Type) -> Type -> t Type -> Type
    forall b a. (b -> a -> b) -> b -> t a -> b
    forall (t :: Type -> Type) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Type -> Type -> Type
    go Type
    res t Type
    args
     where
      go :: Type -> Type -> Type
    go Type
    l Type
    r = Type -> Type -> Type
    AppT (Type -> Type -> Type
    AppT Type
    ArrowT Type
    l) Type
    r