{-# 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 (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q 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 (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
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
tupleT ([Q Type] -> 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)
mapM Integer -> Q Dec
vecToTupleInstance [Integer
3..Integer
n]

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

    -- Head
    (Q Type
vecToTupleCon Q Type -> Q Type -> Q Type
`appT` Q Type
vecType)

    -- Implementation
    [ TySynEqnQ -> Q Dec
tySynInstD (Maybe [TyVarBndr] -> Q Type -> Q Type -> TySynEqnQ
tySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing Q Type
aTypeLhs Q Type
aTypeRhs)
    , Name -> [ClauseQ] -> Q Dec
funD Name
vecToTupleFunName [[Q Pat] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Q Pat
vecToTuplePat] (ExpQ -> BodyQ
normalB ExpQ
vecToTupleImpl) []]
    ]

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

  -- associated type
  tupTypeCon :: Q Type
tupTypeCon = Name -> Q Type
conT (String -> Name
mkName String
"TupType")
  aTypeLhs :: Q Type
aTypeLhs = Q Type
tupTypeCon Q Type -> Q Type -> Q Type
`appT` Q Type
vecType
  aTypeRhs :: Q Type
aTypeRhs = [Q Type] -> Q Type
tupT [Name -> Q 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
varP [Name]
varNames [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat
wildP])
  vecToTupleImpl :: ExpQ
vecToTupleImpl = [ExpQ] -> ExpQ
tupE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
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'Char -> String -> String
forall a. a -> [a] -> [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]