{-|
Copyright  :  (C) 2019, Myrtle Software Ltd
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

module Clash.Class.HasDomain.CodeGen
  ( mkTryDomainTuples
  , mkHasDomainTuples
  ) where

import           Language.Haskell.TH.Syntax
import           Clash.CPP                    (maxTupleSize)
import           Language.Haskell.TH.Compat   (mkTySynInstD)


mkTup :: [Type] -> Type
mkTup :: [Type] -> Type
mkTup names :: [Type]
names@([Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length -> Int
n) =
  (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
n) [Type]
names

-- | Creates an instance of the form:
--
--  type instance TryDomain t (a, b, c, d, e) = Merge t a (b, c, d, e)
--
-- With /n/ number of variables on the LHS.
mkTryDomainTupleInstance :: Name -> Name -> Int -> Dec
mkTryDomainTupleInstance :: Name -> Name -> Int -> Dec
mkTryDomainTupleInstance Name
tryDomainName Name
mergeName Int
n =
  Name -> [Type] -> Type -> Dec
mkTySynInstD Name
tryDomainName [Type
t, Type
tupPat] Type
tupBody
 where
  bcde :: [Type]
bcde = (Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (Int -> Name) -> Int -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (Int -> String) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  a :: Type
a    = Name -> Type
VarT (String -> Name
mkName String
"a0")
  t :: Type
t    = Name -> Type
VarT (String -> Name
mkName String
"t")

  -- Merge t a (b, c, d, e)
  tupBody :: Type
tupBody = Name -> Type
ConT Name
mergeName Type -> Type -> Type
`AppT` Type
t Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` ([Type] -> Type
mkTup [Type]
bcde)

  -- (a, b, c, d, e)
  tupPat :: Type
tupPat = [Type] -> Type
mkTup (Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
bcde)

mkTryDomainTuples :: Name -> Name -> Q [Dec]
mkTryDomainTuples :: Name -> Name -> Q [Dec]
mkTryDomainTuples Name
tryDomainName Name
mergeName =
  [Dec] -> Q [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Int -> Dec) -> [Int] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> Int -> Dec
mkTryDomainTupleInstance Name
tryDomainName Name
mergeName) [Int
3..Int
forall a. Num a => a
maxTupleSize])


-- | Creates an instance of the form:
--
--  type instance HasDomain' dom (a, b, c, d, e) =
--    Merge' (HasDomain' dom a) (HasDomain' dom (b, c, d, e))
--
-- With /n/ number of variables on the LHS.
mkHasDomainTupleInstance :: Name -> Name -> Int -> Dec
mkHasDomainTupleInstance :: Name -> Name -> Int -> Dec
mkHasDomainTupleInstance Name
hasDomainName Name
mergeName Int
n =
  Name -> [Type] -> Type -> Dec
mkTySynInstD Name
hasDomainName [Type
dom, Type
tupPat] Type
merge
 where
  bcde :: [Type]
bcde = (Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (Int -> Name) -> Int -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (Int -> String) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  a :: Type
a    = Name -> Type
VarT (String -> Name
mkName String
"a0")
  dom :: Type
dom  = Name -> Type
VarT (String -> Name
mkName String
"dom")

  -- Merge dom a (b, c, d, e)
  merge :: Type
merge = Name -> Type
ConT Name
mergeName Type -> Type -> Type
`AppT` Type
dom Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` [Type] -> Type
mkTup [Type]
bcde

  -- (a, b, c, d, e)
  tupPat :: Type
tupPat = [Type] -> Type
mkTup (Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
bcde)

mkHasDomainTuples :: Name -> Name -> Q [Dec]
mkHasDomainTuples :: Name -> Name -> Q [Dec]
mkHasDomainTuples Name
hasDomainName Name
mergeName =
  [Dec] -> Q [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Int -> Dec) -> [Int] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> Int -> Dec
mkHasDomainTupleInstance Name
hasDomainName Name
mergeName) [Int
3..Int
forall a. Num a => a
maxTupleSize])