{-# LANGUAGE GADTs , RankNTypes , ViewPatterns , TypeOperators , DeriveFunctor , DeriveFoldable , ConstraintKinds , TemplateHaskell , DeriveTraversable , FlexibleInstances , ScopedTypeVariables , UndecidableInstances , QuantifiedConstraints , MultiParamTypeClasses , UndecidableSuperClasses #-} module Data.Functor.Free.Internal where import Data.Monoid (Ap(..)) import Language.Haskell.TH.Syntax import Data.DeriveLiftedInstances 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 :: Q Pat kPat :: Q Pat kPat = Pat -> Q Pat forall (f :: * -> *) a. Applicative f => a -> f a pure (Pat -> Q Pat) -> (Name -> Pat) -> Name -> Q Pat forall b c a. (b -> c) -> (a -> b) -> a -> c . Name -> Pat VarP (Name -> Q Pat) -> Name -> Q Pat forall a b. (a -> b) -> a -> b $ String -> Name mkName String "k" freeDeriv :: Name -> Name -> Derivator freeDeriv :: Name -> Name -> Derivator freeDeriv (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 ConE -> Q Exp free) (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 -> Q Exp runFree) = Derivator idDeriv { res :: Q Exp -> Q Exp res = \Q Exp e -> [| $free (\ $kPat -> $e) |], var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp var = \Q Exp -> Q Exp -> Q Exp fold Q Exp v -> [| $(fold [| fmap |] [| \f -> $runFree f $kExp |]) $v |] } deriveFreeInstance' :: Name -> Name -> Name -> Name -> Q [Dec] deriveFreeInstance' :: Name -> Name -> Name -> Name -> Q [Dec] deriveFreeInstance' (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 free) Name cfree Name runFree (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 -> Name -> Derivator freeDeriv Name cfree Name runFree) [t| forall a c. (forall x. c x :=> $clss x) => $clss ($free c a) |] deriveInstances' :: Name -> Name -> Name -> Name -> Q [Dec] deriveInstances' :: Name -> Name -> Name -> Name -> Q [Dec] deriveInstances' Name tfree Name cfree Name runFree nm :: Name nm@(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) = [[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 <$> [Q [Dec]] -> Q [[Dec]] forall (t :: * -> *) (f :: * -> *) a. (Traversable t, Applicative f) => t (f a) -> f (t a) sequenceA [ Name -> Name -> Name -> Name -> Q [Dec] deriveFreeInstance' Name tfree Name cfree Name runFree Name nm , Derivator -> Q Type -> Q [Dec] deriveInstance Derivator showDeriv [t| $clss ShowsPrec |] , Derivator -> Q Type -> Q [Dec] deriveInstance (Derivator -> Derivator apDeriv Derivator idDeriv) [t| forall f a c. (Applicative f, $clss a) => $clss (Ap f a) |] ] class (a => b) => a :=> b instance (a => b) => a :=> b