{-# LANGUAGE TemplateHaskellQuotes #-}
module Drasil.Database.TH (
  -- * The Magic
  declareHasChunkRefs,
  -- * Re-exports from GHC.Generics for convenience
  Generic,
  Generically(..)
) where

import GHC.Generics (Generic, Generically(..))
import Language.Haskell.TH (Name, Q, Dec(..), Type(..), DerivStrategy(..))

import Drasil.Database.Chunk (HasChunkRefs)

-- | Declares that a type is a chunk type; Generates an instance of
-- 'HasChunkRefs'.
declareHasChunkRefs :: Name -> Q [Dec]
declareHasChunkRefs :: Name -> Q [Dec]
declareHasChunkRefs = [Name] -> Name -> Q [Dec]
deriveGenerically [''HasChunkRefs]

-- | Generates:
--
-- 1. A 'Generic' instance for the type:
-- @
--   deriving stock instance Generic Ty
-- @
--
-- 2. For all type classes to be derived generically:
-- @
--   deriving via Generically Ty instance TheClass Ty
-- @
deriveGenerically :: [Name] -> Name -> Q [Dec]
deriveGenerically :: [Name] -> Name -> Q [Dec]
deriveGenerically [Name]
clss Name
ty = do
  let typeCon :: Type
typeCon = Name -> Type
ConT Name
ty

      -- deriving stock instance Generic Ty
      drvGeneric :: Dec
drvGeneric = Maybe DerivStrategy -> Cxt -> Type -> Dec
StandaloneDerivD
        (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
StockStrategy)
        []
        (Type -> Type -> Type
AppT (Name -> Type
ConT ''Generic) Type
typeCon)

      -- deriving via Generically Ty instance TheClass Ty
      drvCls :: Name -> Dec
drvCls Name
cls = Maybe DerivStrategy -> Cxt -> Type -> Dec
StandaloneDerivD
        (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just (Type -> DerivStrategy
ViaStrategy (Type -> Type -> Type
AppT (Name -> Type
ConT ''Generically) Type
typeCon)))
        []
        (Type -> Type -> Type
AppT (Name -> Type
ConT Name
cls) Type
typeCon)

      -- Gather all classes we want to derive generically
      clsDrvs :: [Dec]
clsDrvs = (Name -> Dec) -> [Name] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Dec
drvCls [Name]
clss

  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
drvGeneric Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
clsDrvs