{-# LANGUAGE KindSignatures  #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.Derive.ConstrName
-- Copyright   :  (c) 2024 James Koppel
-- License     :  BSD3
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive instances of @ConstrNameHF@.
--
--------------------------------------------------------------------------------

module Data.Comp.Multi.Derive.ConstrName
    (
     ConstrNameHF(..),
     makeConstrNameHF
    ) where

import Data.Comp.Derive.Utils
import Data.Comp.Multi.Kinds (Fragment)
import Language.Haskell.TH

{-| Get the constructor name of a higher-order functor value. -}
class ConstrNameHF (f :: Fragment) where
    constrNameHF :: f e l -> String

{-| Derive an instance of 'ConstrNameHF' for a type constructor of any higher-order
  kind taking at least two arguments. -}
makeConstrNameHF :: Name -> Q [Dec]
makeConstrNameHF :: Name -> Q [Dec]
makeConstrNameHF Name
fname = do
  Just (DataInfo Cxt
_cxt Name
name [TyVarBndr BndrVis]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let args' :: [TyVarBndr BndrVis]
args' = [TyVarBndr BndrVis] -> [TyVarBndr BndrVis]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr BndrVis]
args
      argNames :: Cxt
argNames = (TyVarBndr BndrVis -> Type) -> [TyVarBndr BndrVis] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type)
-> (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr BndrVis -> Name
tyVarBndrName) ([TyVarBndr BndrVis] -> [TyVarBndr BndrVis]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr BndrVis]
args')
      complType :: Type
complType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
      classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''ConstrNameHF) Type
complType
  [(Name, Cxt, Maybe Type)]
constrs' <- (Con -> Q (Name, Cxt, Maybe Type))
-> [Con] -> Q [(Name, Cxt, Maybe Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q (Name, Cxt, Maybe Type)
normalConExp [Con]
constrs
  Dec
methDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'constrNameHF (((Name, Cxt, Maybe Type) -> Q Clause)
-> [(Name, Cxt, Maybe Type)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Cxt, Maybe Type) -> Q Clause
forall {m :: * -> *} {t :: * -> *} {a} {c}.
(Quote m, Foldable t) =>
(Name, t a, c) -> m Clause
genClause [(Name, Cxt, Maybe Type)]
constrs')
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
methDecl]]
    where
      genClause :: (Name, t a, c) -> m Clause
genClause (Name
constr, t a
cArgs, c
_ty) = do
        let n :: Int
n = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
cArgs
            pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] (Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
n Pat
WildP)
            conName :: String
conName = Name -> String
qualifiedConstrName Name
constr
        Exp
body <- [| conName |]
        Clause -> m Clause
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> m Clause) -> Clause -> m Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []

-- | Get a qualified constructor name: "Module.Constructor" if module is available,
-- otherwise just "Constructor".
qualifiedConstrName :: Name -> String
qualifiedConstrName :: Name -> String
qualifiedConstrName Name
n = case Name -> Maybe String
nameModule Name
n of
  Just String
m  -> String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n
  Maybe String
Nothing -> Name -> String
nameBase Name
n