{-# LANGUAGE RankNTypes #-}

-- | 'Builder' for declaring typeclass
module Language.Haskell.TH.Natural.Syntax.Class (
    -- * Builder
    newClass,
    ClassBuilder,

    -- * Functions
    addTypeVar,
    addTypeVar',
    addFunDep,
    addSignature,

    -- * Re-export
    newTypeVar,
    module Language.Haskell.TH.Natural.Syntax.Builder.Monad,
) where

import Control.Lens
import Language.Haskell.TH hiding (cxt, funDep)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Gen
import Language.Haskell.TH.Natural.Syntax.Builder
import Language.Haskell.TH.Natural.Syntax.Builder.Monad
import Language.Haskell.TH.Natural.Syntax.Common
import Language.Haskell.TH.Natural.Syntax.Name
import Language.Haskell.TH.Syntax.ExtractedCons hiding (fName)

type ClassBuilder a = ConstBuilder ClassD a

-- | Builds a typeclass declaration, using its name and a 'ClassBuilder'
newClass :: String -> ClassBuilder () -> Q ClassD
newClass :: String -> ClassBuilder () -> Q ClassD
newClass String
className ClassBuilder ()
next = ClassBuilder () -> ClassD -> Q ClassD
forall {k} (m :: * -> *) s (step :: k) (end :: k).
Monad m =>
BaseBuilder m s step end () -> s -> m s
runBaseBuilder ClassBuilder ()
next ClassD
class_
  where
    class_ :: ClassD
class_ = Cxt -> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [Dec] -> ClassD
MkClassD [] (String -> Name
mkName String
className) [] [] []

-- | Add functional dependencies
addFunDep :: [TypeVarName] -> [TypeVarName] -> ClassBuilder ()
addFunDep :: [TypeVarName] -> [TypeVarName] -> ClassBuilder ()
addFunDep [TypeVarName]
l [TypeVarName]
r = ([FunDep] -> Identity [FunDep]) -> ClassD -> Identity ClassD
forall a b. HasFunDep a b => Lens' a b
Lens' ClassD [FunDep]
funDep (([FunDep] -> Identity [FunDep]) -> ClassD -> Identity ClassD)
-> FunDep -> ClassBuilder ()
forall s (m :: * -> *) b a.
(MonadState s m, Snoc b b a a) =>
ASetter s s b b -> a -> m ()
|>= [Name] -> [Name] -> FunDep
FunDep ((TypeVarName -> Name) -> [TypeVarName] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeVarName -> Getting Name TypeVarName Name -> Name
forall s a. s -> Getting a s a -> a
^. Getting Name TypeVarName Name
forall a b. HasName a b => Lens' a b
Lens' TypeVarName Name
name) [TypeVarName]
l) ((TypeVarName -> Name) -> [TypeVarName] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TypeVarName -> Getting Name TypeVarName Name -> Name
forall s a. s -> Getting a s a -> a
^. Getting Name TypeVarName Name
forall a b. HasName a b => Lens' a b
Lens' TypeVarName Name
name) [TypeVarName]
r)

-- | Add a function signature to the class
addSignature :: (GenType a) => String -> a -> ClassBuilder ()
addSignature :: forall a. GenType a => String -> a -> ClassBuilder ()
addSignature String
fName a
tyBuilder = do
    sigTy <- Q Type -> BaseBuilder Q ClassD 'Ready 'Ready Type
forall {k} (m :: * -> *) a s (step :: k).
Monad m =>
m a -> BaseBuilder m s step step a
liftB (Q Type -> BaseBuilder Q ClassD 'Ready 'Ready Type)
-> Q Type -> BaseBuilder Q ClassD 'Ready 'Ready Type
forall a b. (a -> b) -> a -> b
$ a -> Q Type
forall a. GenType a => a -> Q Type
genTy a
tyBuilder
    addBody $ TH.SigD (mkName fName) sigTy