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

module Clash.Signal.Bundle.Internal where

import           Clash.CPP             (maxTupleSize)
import           Clash.Signal.Internal (Signal)
import           Control.Monad         (replicateM)
import           Data.List             (foldl')
import           Language.Haskell.TH

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

  [Name]
allNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
forall a. Num a => a
maxTupleSize (String -> Q Name
newName "a")
  [Name]
tempNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
forall a. Num a => a
maxTupleSize (String -> Q Name
newName "b")
  Name
t <- String -> Q Name
newName "t"
  Name
x <- String -> Q Name
newName "x"
  Name
tup <- String -> Q Name
newName "tup"

  [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ ((Int -> Dec) -> [Int] -> [Dec]) -> [Int] -> (Int -> Dec) -> [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Dec) -> [Int] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map [2..Int
forall a. Num a => a
maxTupleSize] ((Int -> Dec) -> [Dec]) -> (Int -> Dec) -> [Dec]
forall a b. (a -> b) -> a -> b
$ \tupleNum :: Int
tupleNum ->
    let names :: [Name]
names = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
tupleNum [Name]
allNames
        temps :: [Name]
temps = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
tupleNum [Name]
tempNames
        vars :: [Type]
vars  = (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT [Name]
names
        tuple :: [Type] -> Type
tuple = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) 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
tuple [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
t ) Type -> Type -> Type
`AppT` [Type] -> Type
tuple [Type]
vars )
            (Type -> TySynEqn) -> Type -> TySynEqn
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
tuple ([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
t)) [Type]
vars
        unbundledType :: Dec
unbundledType = TySynEqn -> Dec
TySynInstD TySynEqn
unbundledTypeEq
#else
        unbundledTypeEq =
          TySynEqn
            [ VarT t, tuple vars ]
            $ tuple $ map (AppT (signal `AppT` VarT t)) vars
        unbundledType = TySynInstD unbundledTyName unbundledTypeEq
#endif

        bundleLambda :: Exp
bundleLambda = [Pat] -> Exp -> Exp
LamE ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
temps) ([Exp] -> Exp
TupE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
temps)
        applicatives :: [Exp]
applicatives = Name -> Exp
VarE '(<$>) Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: Exp -> [Exp]
forall a. a -> [a]
repeat (Name -> Exp
VarE '(<*>))
        bundle :: Dec
bundle =
          Name -> [Clause] -> Dec
FunD
            Name
bundleName
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                [ [Pat] -> Pat
TupP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names ]
                ( Exp -> Body
NormalB
                (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ (Exp -> (Exp, Exp) -> Exp) -> Exp -> [(Exp, Exp)] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                    (\f :: Exp
f (a :: Exp
a, b :: Exp
b) -> Exp
a Exp -> Exp -> Exp
`AppE` Exp
f Exp -> Exp -> Exp
`AppE` Exp
b)
                    Exp
bundleLambda
                    ([Exp] -> [Exp] -> [(Exp, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp]
applicatives ([Exp] -> [(Exp, Exp)]) -> [Exp] -> [(Exp, Exp)]
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
names)
                )
                []
            ]

        unbundleLambda :: Int -> Exp
unbundleLambda n :: Int
n =
          [Pat] -> Exp -> Exp
LamE
            [ [Pat] -> Pat
TupP [ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then Name -> Pat
VarP Name
x else Pat
WildP | Int
i <- [0..Int
tupleNumInt -> Int -> Int
forall a. Num a => a -> a -> a
-1] ] ]
            (Name -> Exp
VarE Name
x)

        unbundle :: Dec
unbundle =
          Name -> [Clause] -> Dec
FunD
            Name
unbundleName
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                [ Name -> Pat
VarP Name
tup ]
                ( Exp -> Body
NormalB (Exp -> Body) -> ([Exp] -> Exp) -> [Exp] -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
TupE ([Exp] -> Body) -> [Exp] -> Body
forall a b. (a -> b) -> a -> b
$
                    (Int -> Exp) -> [Int] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map
                      (\n :: Int
n -> Name -> Exp
VarE 'fmap Exp -> Exp -> Exp
`AppE` Int -> Exp
unbundleLambda Int
n Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
tup)
                      [0..Int
tupleNumInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]
                )
                []
            ]

    in Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instTy [Dec
unbundledType, Dec
bundle, Dec
unbundle]