{-# LANGUAGE QuasiQuotes #-}
module Morley.Util.TypeTuple.TH
( deriveRecFromTuple
) where
import Data.Vinyl.Core (Rec(..))
import Language.Haskell.TH qualified as TH
import Morley.Util.TypeTuple.Class
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
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
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"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
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"x"
let consTy :: Type -> m Type -> m Type
consTy Type
ty m Type
lty = m Type
forall (m :: * -> *). Quote m => m Type
TH.promotedConsT m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`TH.appT` Type -> m Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`TH.appT` m 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 Element [Type] -> Q Type -> Q Type
forall {m :: * -> *}. Quote m => Type -> m Type -> m Type
consTy Q Type
forall (m :: * -> *). Quote m => m Type
TH.promotedNilT [Type]
tyVars
let tupleConsTy :: Q Type -> Type -> Q Type
tupleConsTy Q Type
acc Type
ty = Q Type
acc Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`TH.appT` (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fVar Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m 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
forall (m :: * -> *). Quote m => Int -> m 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
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"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 -> m Exp -> m Exp
consRec Name
var m Exp
acc = [e|(:&)|] m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
var m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` m Exp
acc
let recRes :: Q Exp
recRes = (Element [Name] -> Q Exp -> Q Exp) -> Q Exp -> [Name] -> Q Exp
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr Element [Name] -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Exp
consRec [e|RNil|] [Name]
vars
[d| instance RecFromTuple (Rec ($(pure fVar) :: u -> Type) $tyList) where
type IsoRecTuple (Rec $(pure fVar) $tyList) = $tyTuple
recFromTuple $tyPat = $recRes
|]