{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Galley.Cassandra.FeatureTH where
import Data.Kind
import Generics.SOP.TH
import Imports
import Language.Haskell.TH hiding (Type)
import Wire.API.Team.Feature
featureCases :: ExpQ -> Q Exp
featureCases :: ExpQ -> ExpQ
featureCases ExpQ
rhsQ = do
Exp
rhs <- ExpQ
rhsQ
TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con]
constructors [DerivClause]
_) <- Name -> Q Info
reify ''FeatureSingleton
Exp -> ExpQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$
[Match] -> Exp
LamCaseE
[ Pat -> Body -> [Dec] -> Match
Match (Name -> Cxt -> [Pat] -> Pat
ConP Name
c [] []) (Exp -> Body
NormalB Exp
rhs) []
| GadtC [Name
c] [BangType]
_ Kind
_ <- [Con]
constructors
]
generateTupleP :: Q [Dec]
generateTupleP :: Q [Dec]
generateTupleP = do
let maxSize :: Int
maxSize = Int
64 :: Int
Kind
tylist <- [t|[Type]|]
let vars :: Cxt
vars = [Name -> Kind
VarT (String -> Name
mkName (String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)) | Int
i <- [Int
0 .. Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ TypeFamilyHead -> [TySynEqn] -> Dec
ClosedTypeFamilyD
(Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead (String -> Name
mkName String
"TupleP") [Name -> () -> Kind -> TyVarBndr ()
forall flag. Name -> flag -> Kind -> TyVarBndr flag
KindedTV (String -> Name
mkName String
"xs") () Kind
tylist] FamilyResultSig
NoSig Maybe InjectivityAnn
forall a. Maybe a
Nothing)
[ Maybe [TyVarBndr ()] -> Kind -> Kind -> TySynEqn
TySynEqn
Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing
( Name -> Kind
ConT (String -> Name
mkName String
"TupleP")
Kind -> Kind -> Kind
`AppT` Cxt -> Kind
mkPattern (Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
n Cxt
vars)
)
(Cxt -> Kind
mkTuple (Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
n Cxt
vars))
| Int
n <- [Int
0 .. Int
maxSize]
]
]
where
mkPattern :: Cxt -> Kind
mkPattern = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Kind
x Kind
y -> Kind
PromotedConsT Kind -> Kind -> Kind
`AppT` Kind
x Kind -> Kind -> Kind
`AppT` Kind
y) Kind
PromotedNilT
mkTuple :: Cxt -> Kind
mkTuple [] = Name -> Kind
ConT ''()
mkTuple [Kind
v] = Name -> Kind
ConT ''Identity Kind -> Kind -> Kind
`AppT` Kind
v
mkTuple Cxt
vs =
let n :: Int
n = Cxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
vs
in (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Kind -> Kind -> Kind
AppT (Int -> Kind
TupleT Int
n) Cxt
vs
generateSOPInstances :: Q [Dec]
generateSOPInstances :: Q [Dec]
generateSOPInstances = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Name -> Q [Dec]
deriveGeneric (Name -> Q [Dec]) -> (Int -> Name) -> Int -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
tupleTypeName) [Int
31 .. Int
50]