{-# LANGUAGE
CPP
, GADTs
, PolyKinds
, RankNTypes
, ViewPatterns
, TypeOperators
, DeriveFunctor
, DeriveFoldable
, ConstraintKinds
, TemplateHaskell
, DeriveTraversable
, FlexibleInstances
, ScopedTypeVariables
, UndecidableInstances
, QuantifiedConstraints
, MultiParamTypeClasses
, UndecidableSuperClasses
#-}
#if __GLASGOW_HASKELL__ >= 810
{-# LANGUAGE StandaloneKindSignatures #-}
#endif
module Data.Functor.Cofree.Internal where
import Data.Monoid (Ap(..))
import Language.Haskell.TH.Syntax
import Data.DeriveLiftedInstances
import Data.Kind (Constraint)
kExp :: Q Exp
kExp :: Q Exp
kExp = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> (Name -> Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"k"
kPat :: Pat
kPat :: Pat
kPat = Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"k"
cofreeDeriv :: Name -> Derivator
cofreeDeriv :: Name -> Derivator
cofreeDeriv Name
cofree = Derivator
idDeriv {
cst :: Q Exp -> Q Exp
cst = \Q Exp
e -> [| const $e $kExp |],
res :: Q Exp -> Q Exp
res = \Q Exp
e -> [| $(pure (ConE cofree)) $kExp $e |],
eff :: Q Exp -> Q Exp
eff = \Q Exp
e -> [| $(pure (ConE cofree)) $kExp <$> $e |],
inp :: Q Pat -> Q Pat
inp = (Pat -> Pat) -> Q Pat -> Q Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Pat
vp -> Name -> [Pat] -> Pat
ConP Name
cofree [Pat
kPat, Pat
vp])
}
deriveCofreeInstance' :: Name -> Name -> Name -> Q [Dec]
deriveCofreeInstance' :: Name -> Name -> Name -> Q [Dec]
deriveCofreeInstance' (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> (Name -> Type) -> Name -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT -> Q Type
cofree) Name
ccofree (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> (Name -> Type) -> Name -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
ConT -> Q Type
clss)
= Derivator -> Q Type -> Q [Dec]
deriveInstance (Name -> Derivator
cofreeDeriv Name
ccofree)
[t| forall a c. (c ~=> $clss, c ($cofree c a)) => $clss ($cofree c a) |]
#if __GLASGOW_HASKELL__ < 810
type a ~=> b = (forall x. (a :: (k -> Constraint)) x => (b :: (k -> Constraint)) x) :: Constraint
#else
type (~=>) :: (k -> Constraint) -> (k -> Constraint) -> Constraint
type a ~=> b = forall x. a x => b x
#endif