{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Redundant <&>" #-}

-- SPDX-License-Identifier: MPL-2.0

{- |
Copyright   :  (c) 2023 Sayo contributors
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp

This module provides @TemplateHaskell@ functions to derive an instance of
 t'Data.Effect.HFunctor.HFunctor'.
-}
module Data.Effect.HFunctor.TH (
    module Data.Effect.HFunctor.TH,
    Infinite ((:<)),
) where

import Data.Effect.HFunctor.TH.Internal (deriveHFunctor)
import Data.Effect.TH.Internal (analyzeData)
import Data.Functor ((<&>))
import Data.List.Infinite (Infinite ((:<)))
import Language.Haskell.TH (Dec, Name, Q, reify)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax (nameBase)

{- |
Derive an instance of t'Data.Effect.HFunctor.HFunctor' for a type constructor of any higher-order
kind taking at least two arguments.
-}
makeHFunctor :: Name -> Q [Dec]
makeHFunctor :: Name -> Q [Dec]
makeHFunctor Name
name = Name -> (Infinite (Q Type) -> Q Type) -> Q [Dec]
makeHFunctor' Name
name (Q Type -> Infinite (Q Type) -> Q Type
forall a b. a -> b -> a
const [t|()|])

{- |
Derive an instance of t'Data.Effect.HFunctor.HFunctor' for a type constructor of any higher-order
kind taking at least two arguments.

Furthermore, you can manually provide type constraints for the instance:

@
{\-# LANGUAGE BlockArguments #-\}
import Data.List.Infinite (Infinite ((:<)))

data Example (g :: Type -> Type) h (f :: Type -> Type) (a :: Type) where
    Example :: g (h f a) -> Example g h f a

makeHFunctor' ''Example \\(g \:\< h \:\< _) -> [t| (Functor $g, HFunctor $h) |]
@
-}
makeHFunctor' :: Name -> (Infinite (Q TH.Type) -> Q TH.Type) -> Q [Dec]
makeHFunctor' :: Name -> (Infinite (Q Type) -> Q Type) -> Q [Dec]
makeHFunctor' Name
name Infinite (Q Type) -> Q Type
manualCxt = do
    Name -> Q Info
reify Name
name Q Info -> (Info -> Maybe DataInfo) -> Q (Maybe DataInfo)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Info -> Maybe DataInfo
analyzeData Q (Maybe DataInfo) -> (Maybe DataInfo -> 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
>>= \case
        Just DataInfo
dat -> do
            (Infinite (Q Type) -> Q Type) -> DataInfo -> Q [Dec]
deriveHFunctor Infinite (Q Type) -> Q Type
manualCxt DataInfo
dat
        Maybe DataInfo
Nothing -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"The specified name is not that of a data type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name