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

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

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
Copyright   :  (c) 2023 Yamada Ryo
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable

This module provides @TemplateHaskell@ functions to derive an instance of
 t'Data.Effect.HFunctor.HFunctor'.
-}
module Data.Effect.HFunctor.TH 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 (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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Info -> Maybe DataInfo
analyzeData 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"The specified name is not that of a data type: " forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name