{-|
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 a. Data a => a -> Q 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 (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 (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 (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
      Dec
unbundlePrimAnn <- Name -> DecQ
idPrimitive Name
qualUnbundlePrimName
      Dec
bundlePrimAnn <- Name -> DecQ
idPrimitive Name
qualBundleNm
      [Dec] -> DecsQ
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [ -- Instance and its methods
             Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instTy [Dec
unbundledType, Dec
bundleD, Dec
unbundleD]

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

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

mkFunTys :: Foldable t => t TH.Type -> TH.Type -> TH.Type
mkFunTys :: t Type -> Type -> Type
mkFunTys t Type
args Type
res= (Type -> Type -> Type) -> Type -> t Type -> Type
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