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