{-# LANGUAGE PolyKinds , TypeFamilies , TypeOperators , ConstraintKinds , TemplateHaskellQuotes #-} module Generics.Constraints ( Constraints , makeDeriving, makeDerivings , makeInstance, makeInstances ) where import Data.Kind (Constraint, Type) import GHC.Generics import qualified Language.Haskell.TH as T import qualified Language.Haskell.TH.Datatype as D type family Constraints' (t :: Type -> Type) (c :: Type -> Constraint) :: Constraint type instance Constraints' V1 c = () type instance Constraints' U1 c = () type instance Constraints' (f :+: g) c = (Constraints' f c, Constraints' g c) type instance Constraints' (f :*: g) c = (Constraints' f c, Constraints' g c) type instance Constraints' (f :.: g) c = Constraints' g c type instance Constraints' Par1 c = () type instance Constraints' (Rec1 f) c = () type instance Constraints' (K1 i a) c = c a type instance Constraints' (M1 i t f) c = Constraints' f c -- | `Constraints` is a constraint type synonym, containing the constraint -- requirements for an instance for `t` of class `c`. -- It requires an instance of class `c` for each component of `t`. type Constraints t c = Constraints' (Rep t) c makeDerivings :: [T.Name] -> [T.Name] -> T.DecsQ makeDerivings = makeMany makeDeriving makeInstances :: [T.Name] -> [T.Name] -> T.DecsQ makeInstances = makeMany makeInstance makeMany :: (T.Name -> T.Name -> T.DecsQ) -> [T.Name] -> [T.Name] -> T.DecsQ makeMany f classes types = concat <$> sequence (f <$> classes <*> types) makeDeriving :: T.Name -> T.Name -> T.DecsQ makeDeriving = makeCommon (T.StandaloneDerivD Nothing) makeInstance :: T.Name -> T.Name -> T.DecsQ makeInstance = makeCommon (\c i -> T.InstanceD Nothing c i []) makeCommon :: ([T.Type] -> T.Type -> T.Dec) -> T.Name -> T.Name -> T.DecsQ makeCommon f clsName typName = r <$> D.reifyDatatype typName where r info = [ f [T.ConT ''Constraints `T.AppT` typ `T.AppT` T.ConT clsName] (T.ConT clsName `T.AppT` typ) ] where typ = foldl T.AppT (T.ConT typName) (T.VarT . D.tvName <$> D.datatypeVars info)