{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE TemplateHaskellQuotes #-}

module Clash.Sized.Vector.ToTuple.TH (vecToTupleInstance, vecToTupleInstances) where

import Clash.Sized.Vector (Vec((:>)))
import Language.Haskell.TH

appTs :: Q Type -> [Q Type] -> Q Type
appTs :: Q Type -> [Q Type] -> Q Type
appTs = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q 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 Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
appT

appPsInfix :: Name -> [Q Pat] -> Q Pat
appPsInfix :: Name -> [Q Pat] -> Q Pat
appPsInfix Name
f = (Q Pat -> Q Pat -> Q Pat) -> [Q Pat] -> Q Pat
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1 (\Q Pat
l Q Pat
r -> Q Pat -> Name -> Q Pat -> Q Pat
forall (m :: Type -> Type).
Quote m =>
m Pat -> Name -> m Pat -> m Pat
uInfixP Q Pat
l Name
f Q Pat
r)

tupT :: [Q Type] -> Q Type
tupT :: [Q Type] -> Q Type
tupT [Q Type]
tyArgs = Int -> Q Type
forall (m :: Type -> Type). Quote m => Int -> m Type
tupleT ([Q Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Q Type]
tyArgs) Q Type -> [Q Type] -> Q Type
`appTs` [Q Type]
tyArgs

vecToTupleInstances :: Integer -> Q [Dec]
vecToTupleInstances :: Integer -> Q [Dec]
vecToTupleInstances Integer
n = (Integer -> Q Dec) -> [Integer] -> Q [Dec]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Integer -> Q Dec
vecToTupleInstance [Integer
3..Integer
n]

vecToTupleInstance :: Integer -> Q Dec
vecToTupleInstance :: Integer -> Q Dec
vecToTupleInstance Integer
n =
  Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
    -- No superclasses
    (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [])

    -- Head
    (Q Type
vecToTupleCon Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
`appT` Q Type
vecType)

    -- Implementation
    [ Q TySynEqn -> Q Dec
forall (m :: Type -> Type). Quote m => m TySynEqn -> m Dec
tySynInstD (Maybe [TyVarBndr ()] -> Q Type -> Q Type -> Q TySynEqn
forall (m :: Type -> Type).
Quote m =>
Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
tySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing Q Type
aTypeLhs Q Type
aTypeRhs)
    , Name -> [Q Clause] -> Q Dec
forall (m :: Type -> Type). Quote m => Name -> [m Clause] -> m Dec
funD Name
vecToTupleFunName [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
vecToTuplePat] (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB Q Exp
vecToTupleImpl) []]
    ]

 where
  vecToTupleCon :: Q Type
vecToTupleCon = Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
conT (String -> Name
mkName String
"VecToTuple")
  vecType :: Q Type
vecType = Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
conT ''Vec Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
`appT` Q TyLit -> Q Type
forall (m :: Type -> Type). Quote m => m TyLit -> m Type
litT (Integer -> Q TyLit
forall (m :: Type -> Type). Quote m => Integer -> m TyLit
numTyLit Integer
n) Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (String -> Name
mkName String
"a")

  -- associated type
  tupTypeCon :: Q Type
tupTypeCon = Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
conT (String -> Name
mkName String
"TupType")
  aTypeLhs :: Q Type
aTypeLhs = Q Type
tupTypeCon Q Type -> Q Type -> Q Type
forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
`appT` Q Type
vecType
  aTypeRhs :: Q Type
aTypeRhs = [Q Type] -> Q Type
tupT [Name -> Q Type
forall (m :: Type -> Type). Quote m => Name -> m Type
varT (String -> Name
mkName String
"a") | Integer
_ <- [Integer
1..Integer
n]]

  -- vecToTuple
  vecToTupleFunName :: Name
vecToTupleFunName = String -> Name
mkName String
"vecToTuple"
  vecToTuplePat :: Q Pat
vecToTuplePat = Name -> [Q Pat] -> Q Pat
appPsInfix '(:>) ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP [Name]
varNames [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat
forall (m :: Type -> Type). Quote m => m Pat
wildP])
  vecToTupleImpl :: Q Exp
vecToTupleImpl = [Q Exp] -> Q Exp
forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
tupE ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
varE [Name]
varNames)

  varNames :: [Name]
varNames = (Integer -> Name) -> [Integer] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (Integer -> String) -> Integer -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'a':) (String -> String) -> (Integer -> String) -> Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) [Integer
1..Integer
n]