{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Typeclasses to standardise the arguments that the various Builder functions take
module Language.Haskell.TH.Gen (
    GenDec (..),
    GenDecs (..),
    GenExpr (..),
    GenTExpr (..),
    GenType (..),
    GenPat (..),
    GenCon (..),
) where

import Data.Constructor.Extract.Class
import Data.List (singleton)
import Language.Haskell.TH

class GenDec a where
    genDec :: a -> Q Dec

instance GenDec Dec where
    genDec :: Dec -> Q Dec
genDec = Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (GenDec a) => GenDec (Q a) where
    genDec :: Q a -> Q Dec
genDec Q a
qb = Q a
qb Q a -> (a -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Q Dec
forall a. GenDec a => a -> Q Dec
genDec

instance (ExtractedConstructor a Dec) => GenDec a where
    genDec :: a -> Q Dec
genDec = Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> (a -> Dec) -> a -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Dec
forall con ty. ExtractedConstructor con ty => con -> ty
fromEC

class GenDecs a where
    genDecs :: a -> Q [Dec]

instance GenDecs [Dec] where
    genDecs :: [Dec] -> Q [Dec]
genDecs = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (GenDecs a) => GenDecs (Q a) where
    genDecs :: Q a -> Q [Dec]
genDecs Q a
qb = Q a
qb Q a -> (a -> Q [Dec]) -> Q [Dec]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Q [Dec]
forall a. GenDecs a => a -> Q [Dec]
genDecs

instance (GenDec a) => GenDecs a where
    genDecs :: a -> Q [Dec]
genDecs = (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> [Dec]
forall a. a -> [a]
singleton (Q Dec -> Q [Dec]) -> (a -> Q Dec) -> a -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Q Dec
forall a. GenDec a => a -> Q Dec
genDec

class GenExpr a where
    genExpr :: a -> Q Exp

instance GenExpr Exp where
    genExpr :: Exp -> Q Exp
genExpr = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (m ~ Q) => GenExpr (m Exp) where
    genExpr :: m Exp -> Q Exp
genExpr = m Exp -> m Exp
m Exp -> Q Exp
forall a. a -> a
id

instance (ExtractedConstructor a Exp) => GenExpr a where
    genExpr :: a -> Q Exp
genExpr = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> (a -> Exp) -> a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Exp
forall con ty. ExtractedConstructor con ty => con -> ty
fromEC

instance (GenExpr a) => GenExpr (Q a) where
    genExpr :: Q a -> Q Exp
genExpr Q a
qb = Q a
qb Q a -> (a -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Q Exp
forall a. GenExpr a => a -> Q Exp
genExpr

class GenTExpr t a where
    genTExpr :: a -> Q (TExp t)

instance (m ~ Q) => GenTExpr t (Code m t) where
    genTExpr :: Code m t -> Q (TExp t)
genTExpr = Code m t -> m (TExp t)
Code m t -> Q (TExp t)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode

class GenType a where
    genTy :: a -> Q Type

instance GenType Type where
    genTy :: Type -> Q Type
genTy = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (ExtractedConstructor a Type) => GenType a where
    genTy :: a -> Q Type
genTy = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> (a -> Type) -> a -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Type
forall con ty. ExtractedConstructor con ty => con -> ty
fromEC

instance GenType (Q Type) where
    genTy :: Q Type -> Q Type
genTy = Q Type -> Q Type
forall a. a -> a
id

instance (m ~ Q, GenType a) => GenType (m a) where
    genTy :: m a -> Q Type
genTy m a
qb = m a
Q a
qb Q a -> (a -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Q Type
forall a. GenType a => a -> Q Type
genTy

class GenPat a where
    genPat :: a -> Q Pat

instance GenPat (Q Pat) where
    genPat :: Q Pat -> Q Pat
genPat = Q Pat -> Q Pat
forall a. a -> a
id

instance GenPat Pat where
    genPat :: Pat -> Q Pat
genPat = Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (ExtractedConstructor a Pat) => GenPat a where
    genPat :: a -> Q Pat
genPat = Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> (a -> Pat) -> a -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Pat
forall con ty. ExtractedConstructor con ty => con -> ty
fromEC

class GenCon a where
    genCon :: a -> Q Con

instance GenCon (Q Con) where
    genCon :: Q Con -> Q Con
genCon = Q Con -> Q Con
forall a. a -> a
id

instance GenCon Con where
    genCon :: Con -> Q Con
genCon = Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (ExtractedConstructor a Con) => GenCon a where
    genCon :: a -> Q Con
genCon = Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Q Con) -> (a -> Con) -> a -> Q Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Con
forall con ty. ExtractedConstructor con ty => con -> ty
fromEC

instance (GenCon a) => GenCon (Q a) where
    genCon :: Q a -> Q Con
genCon Q a
qb = Q a
qb Q a -> (a -> Q Con) -> Q Con
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Q Con
forall a. GenCon a => a -> Q Con
genCon