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

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

import           Control.Monad.Extra         (concatMapM)
import           Clash.Annotations.Primitive (Primitive(InlinePrimitive))
import           Clash.CPP                   (maxTupleSize)
import           Clash.Signal.Internal       (Signal((:-)))
import           Clash.XException            (seqX)
import           Data.List                   (foldl')
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
  ipJson :: [Char]
ipJson = [Char]
"[{\"Primitive\": {\"name\": \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\", \"primType\": \"Function\"}}]"
  ip :: Primitive
ip = [HDL] -> [Char] -> Primitive
InlinePrimitive [HDL
forall a. Bounded a => a
minBound..HDL
forall a. Bounded a => a
maxBound] [Char]
ipJson

-- | 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 -> [Char] -> Name
mkName (Char
'a'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Int -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char] -> Name
mkName (Char
'a'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"'")) [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 -> [Char] -> Name
mkName ([Char]
"as" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)) [Int
1..Int
forall a. Num a => a
maxTupleSize::Int]
      tNm :: Name
tNm = [Char] -> Name
mkName [Char]
"t"
      sTailNm :: Name
sTailNm = [Char] -> Name
mkName [Char]
"sTail"
      sNm :: Name
sNm = [Char] -> Name
mkName [Char]
"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 = [Char] -> Name
mkName ([Char]
"bundle" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
tupleNum [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"#")
        unbundlePrimName :: Name
unbundlePrimName = [Char] -> Name
mkName ([Char]
"unbundle" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
tupleNum [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"#")
        qualBundleNm :: Name
qualBundleNm = [Char] -> Name
mkName ([Char]
"Clash.Signal.Bundle.bundle" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
tupleNum [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"#")
        qualUnbundlePrimName :: Name
qualUnbundlePrimName = [Char] -> Name
mkName ([Char]
"Clash.Signal.Bundle.unbundle" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
tupleNum [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"#")

        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 ([Char] -> Name
mkName [Char]
"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
forall a. [a] -> a
head [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
            ([Name] -> [Name]
forall a. [a] -> [a]
tail [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