-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# LANGUAGE QuasiQuotes #-}

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

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

import Morley.Util.TH (tupT)
import Morley.Util.TypeTuple.Class

-- | Produce 'RecFromTuple' instance for tuple of the given length.
deriveRecFromTuple :: Word16 -> TH.Q [TH.Dec]
deriveRecFromTuple :: Word16 -> Q [Dec]
deriveRecFromTuple (Word16 -> Int
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral -> Int
n) = do
  -- The `f` type variable
  Q Type
fVar <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
TH.varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"f"
  -- The argument type variables
  [Q Type]
tyVars <- Int -> Q (Q Type) -> Q [Q Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Q (Q Type) -> Q [Q Type]) -> Q (Q Type) -> Q [Q Type]
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
TH.varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"x"

  -- A type level list of the argument type variables
  let tyList :: Q Type
tyList = (Element [Q Type] -> Q Type -> Q Type)
-> Q Type -> [Q Type] -> Q Type
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
forall b. (Element [Q Type] -> b -> b) -> b -> [Q Type] -> b
foldr (\Element [Q Type]
ty Q Type
lty -> [t| $Q Type
Element [Q Type]
ty ': $Q Type
lty |]) [t| '[] |] [Q Type]
tyVars

  -- A tuple type of `f` applied to the argument type variables
  let tyTuple :: Q Type
tyTuple = [Q Type] -> Q Type
tupT ([Q Type] -> Q Type)
-> ([Q Type] -> [Q Type]) -> [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Type -> Q Type) -> [Q Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Q Type
ty -> [t| $Q Type
fVar $Q Type
ty |]) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ [Q Type]
tyVars

  -- Term variable names for the fields
  [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
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"a"
  -- Pattern and expression variables for the fields
  let varPats :: [Q Pat]
varPats = (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP [Name]
vars
  let varExps :: [Q Exp]
varExps = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE [Name]
vars

  -- Terms and patterns for the records
  let recRes :: Q Exp
recRes = (Element [Q Exp] -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
forall b. (Element [Q Exp] -> b -> b) -> b -> [Q Exp] -> b
foldr (\Element [Q Exp]
var Q Exp
acc -> [e| $Q Exp
Element [Q Exp]
var :& $Q Exp
acc |]) [e|RNil|] [Q Exp]
varExps
  let recPat :: Q Pat
recPat = (Element [Q Pat] -> Q Pat -> Q Pat) -> Q Pat -> [Q Pat] -> Q Pat
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
forall b. (Element [Q Pat] -> b -> b) -> b -> [Q Pat] -> b
foldr (\Element [Q Pat]
var Q Pat
acc -> [p| $Q Pat
Element [Q Pat]
var :& $Q Pat
acc |]) [p|RNil|] [Q Pat]
varPats

  [d| instance RecFromTuple (Rec ($Q Type
fVar :: u -> Type) $Q Type
tyList) where
        type IsoRecTuple (Rec $Q Type
fVar $Q Type
tyList) = $Q Type
tyTuple
        recFromTuple $([Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
TH.tupP [Q Pat]
varPats) = $Q Exp
recRes
        tupleFromRec $Q Pat
recPat = $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.tupE [Q Exp]
varExps)
    |]