{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :   Grisette.Internal.TH.DeriveInstanceProvider
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Internal.TH.DeriveInstanceProvider
  ( DeriveInstanceProvider (..),
    Strategy (..),
  )
where

import Generics.Deriving (Default, Default1)
import Language.Haskell.TH
  ( Dec,
    DerivStrategy
      ( AnyclassStrategy,
        NewtypeStrategy,
        StockStrategy,
        ViaStrategy
      ),
    Name,
    Pred,
    Q,
    Type,
    appT,
    conT,
    standaloneDerivWithStrategyD,
  )
import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit)

-- | A derive instance provider provides the instance declaration.
class DeriveInstanceProvider provider where
  instanceDeclaration ::
    provider -> [[(TyVarBndrUnit, Maybe Type)]] -> [Pred] -> [Type] -> Q [Dec]

-- | A strategy for deriving instances.
data Strategy
  = Stock {Strategy -> Name
strategyClassName :: Name}
  | WithNewtype {strategyClassName :: Name}
  | ViaDefault {strategyClassName :: Name}
  | ViaDefault1 {strategyClassName :: Name}
  | Anyclass {strategyClassName :: Name}
  deriving (Strategy -> Strategy -> Bool
(Strategy -> Strategy -> Bool)
-> (Strategy -> Strategy -> Bool) -> Eq Strategy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Strategy -> Strategy -> Bool
== :: Strategy -> Strategy -> Bool
$c/= :: Strategy -> Strategy -> Bool
/= :: Strategy -> Strategy -> Bool
Eq)

getStrategy :: Strategy -> Type -> Q DerivStrategy
getStrategy :: Strategy -> Type -> Q DerivStrategy
getStrategy Strategy
strategy Type
ty =
  case Strategy
strategy of
    Stock Name
_ -> DerivStrategy -> Q DerivStrategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DerivStrategy
StockStrategy
    WithNewtype Name
_ -> DerivStrategy -> Q DerivStrategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DerivStrategy
NewtypeStrategy
    ViaDefault Name
_ ->
      Type -> DerivStrategy
ViaStrategy
        (Type -> DerivStrategy) -> Q Type -> Q DerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Default $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
    ViaDefault1 Name
_ ->
      Type -> DerivStrategy
ViaStrategy
        (Type -> DerivStrategy) -> Q Type -> Q DerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Default1 $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
    Anyclass Name
_ -> DerivStrategy -> Q DerivStrategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return DerivStrategy
AnyclassStrategy

instance DeriveInstanceProvider Strategy where
  instanceDeclaration :: Strategy
-> [[(TyVarBndrUnit, Maybe Type)]] -> [Type] -> [Type] -> Q [Dec]
instanceDeclaration Strategy
strategy [[(TyVarBndrUnit, Maybe Type)]]
_ [Type]
preds [Type]
tys = do
    DerivStrategy
s <- Strategy -> Type -> Q DerivStrategy
getStrategy Strategy
strategy ([Type] -> Type
forall a. HasCallStack => [a] -> a
last [Type]
tys)
    (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [])
      (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DerivStrategy -> Q [Type] -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> m [Type] -> m Type -> m Dec
standaloneDerivWithStrategyD
        (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
s)
        ([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
preds)
        ((Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ Strategy -> Name
strategyClassName Strategy
strategy) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tys)