{-# 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

-- | generates some of the remaining @SOP.Generic@ instances as orphans
--   it is cut off at 50 on purpose to reduce compilation times
--   you may increase up to 64 which is the number at which you
--   you should probably start fixing cql instead.
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]