-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# LANGUAGE QuasiQuotes #-}

-- | Template haskell generator for 'RecFromTuple', in a separate module
-- because of staging restrictions.
module Util.TypeTuple.TH
  ( deriveRecFromTuple
  ) where

import qualified Data.Kind as Kind
import Data.Vinyl.Core (Rec(..))
import qualified Language.Haskell.TH as TH

import Util.TypeTuple.Class

-- | Produce 'RecFromTuple' instance for tuple of the given length.
deriveRecFromTuple :: Word -> TH.Q [TH.Dec]
deriveRecFromTuple :: Word -> Q [Dec]
deriveRecFromTuple (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
n) = do
  Type
fVar <- Name -> Type
TH.VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
TH.newName "f"
  [Type]
tyVars <- Int -> Q Type -> Q [Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Q Type -> Q [Type]) -> Q Type -> Q [Type]
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
TH.newName "x"

  let consTy :: Type -> Q Type -> Q Type
consTy ty :: Type
ty lty :: Q Type
lty = Q Type
TH.promotedConsT Q Type -> Q Type -> Q Type
`TH.appT` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty Q Type -> Q Type -> Q Type
`TH.appT` Q Type
lty
  let tyList :: Q Type
tyList = (Element [Type] -> Q Type -> Q Type) -> Q Type -> [Type] -> Q Type
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr Type -> Q Type -> Q Type
Element [Type] -> Q Type -> Q Type
consTy Q Type
TH.promotedNilT [Type]
tyVars

  let tupleConsTy :: Q Type -> Type -> Q Type
tupleConsTy acc :: Q Type
acc ty :: Type
ty = Q Type
acc Q Type -> Q Type -> Q Type
`TH.appT` (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fVar Q Type -> Q Type -> Q Type
`TH.appT` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty)
  let tyTuple :: Q Type
tyTuple = (Q Type -> Element [Type] -> Q Type) -> Q Type -> [Type] -> Q Type
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
foldl Q Type -> Type -> Q Type
Q Type -> Element [Type] -> Q Type
tupleConsTy (Int -> Q Type
TH.tupleT Int
n) [Type]
tyVars

  [Name]
vars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
TH.newName "a"
  let tyPat :: Q Pat
tyPat = Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> ([Pat] -> Pat) -> [Pat] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat] -> Pat
TH.TupP ([Pat] -> Q Pat) -> [Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> Pat
TH.VarP [Name]
vars

  let consRec :: Name -> ExpQ -> ExpQ
consRec var :: Name
var acc :: ExpQ
acc = [e|(:&)|] ExpQ -> ExpQ -> ExpQ
`TH.appE` Name -> ExpQ
TH.varE Name
var ExpQ -> ExpQ -> ExpQ
`TH.appE` ExpQ
acc
  let recRes :: ExpQ
recRes = (Element [Name] -> ExpQ -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr Name -> ExpQ -> ExpQ
Element [Name] -> ExpQ -> ExpQ
consRec [e|RNil|] [Name]
vars

  [d| instance RecFromTuple (Rec ($(pure fVar) :: u -> Kind.Type) $tyList) where
        type IsoRecTuple (Rec $(pure fVar) $tyList) = $tyTuple
        recFromTuple $tyPat = $recRes
    |]