{-# LANGUAGE CPP #-}

-- | This module generates a typeclass for a given "record of functions". For this component:
--   @
--   data Logger m = Logger {
--     _info :: Text -> m ()
--   , _error :: Text -> m ()
--   }
--
--   -- makeTypeClass ''Logger generates
--
--   class WithLogger m where
--     info :: Text -> m ()
--     error :: Text -> m ()
--
--   -- This requires the import of `Data.Generics.Product.Typed` from `generic-lens`
--   instance HasType (Logger m) s => WithLogger (ReaderT s m) where
--     info t = ReaderT (\l -> _info (getTyped l) t)
--     error t = ReaderT (\l -> _error (getType l) t)
--   @
module Data.Registry.TH
  ( TypeclassOptions,
    makeTypeclass,
    makeTypeclassWith,
  )
where

import Data.Text as T (drop, splitOn)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude hiding (Type)

-- | Create the haskell code presented in the module description
makeTypeclass :: Name -> DecsQ
makeTypeclass :: Name -> DecsQ
makeTypeclass = TypeclassOptions -> Name -> DecsQ
makeTypeclassWith ((Text -> Text) -> (Text -> Text) -> TypeclassOptions
TypeclassOptions (Text
"With" <>) (Int -> Text -> Text
T.drop Int
1))

-- | These generation options can be used to tweak the generated names
data TypeclassOptions = TypeclassOptions
  { -- adjust the typeclass name based on the component constructor name
    TypeclassOptions -> Text -> Text
_typeclassName :: Text -> Text,
    -- adjust the typeclass function names based on the component function names
    TypeclassOptions -> Text -> Text
_functionName :: Text -> Text
  }

-- | Make a typeclass using some specific generation options
makeTypeclassWith :: TypeclassOptions -> Name -> DecsQ
makeTypeclassWith :: TypeclassOptions -> Name -> DecsQ
makeTypeclassWith (TypeclassOptions Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker) Name
componentType = do
  Info
info <- Name -> Q Info
reify Name
componentType
  case Info
info of
    TyConI (DataD Cxt
_ Name
name [TyVarBndr ()]
typeVars Maybe Kind
_ [RecC Name
_ [VarBangType]
types] [DerivClause]
_) -> do
      [Dec]
readertInstance <- (Text -> Text)
-> (Text -> Text)
-> Name
-> [TyVarBndr ()]
-> [VarBangType]
-> DecsQ
createReadertInstance Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr ()]
typeVars [VarBangType]
types
      [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$
        (Text -> Text)
-> (Text -> Text)
-> Name
-> [TyVarBndr ()]
-> [VarBangType]
-> [Dec]
createTypeclass Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr ()]
typeVars [VarBangType]
types
          [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
readertInstance
    TyConI (NewtypeD Cxt
_ Name
name [TyVarBndr ()]
typeVars Maybe Kind
_ (RecC Name
_ [VarBangType]
types) [DerivClause]
_) -> do
      [Dec]
readertInstance <- (Text -> Text)
-> (Text -> Text)
-> Name
-> [TyVarBndr ()]
-> [VarBangType]
-> DecsQ
createReadertInstance Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr ()]
typeVars [VarBangType]
types
      [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$
        (Text -> Text)
-> (Text -> Text)
-> Name
-> [TyVarBndr ()]
-> [VarBangType]
-> [Dec]
createTypeclass Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr ()]
typeVars [VarBangType]
types
          [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
readertInstance
    Info
other -> do
      Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only generate a typeclass for a record of functions, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, StringConv String b) => a -> b
show Info
other)
      [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)
createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr BndrVis] -> [VarBangType] -> [Dec]
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr ()] -> [VarBangType] -> [Dec]
#else
createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]
#endif
createTypeclass :: (Text -> Text)
-> (Text -> Text)
-> Name
-> [TyVarBndr ()]
-> [VarBangType]
-> [Dec]
createTypeclass Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr ()]
typeVars [VarBangType]
types =
  let typeclassName :: Name
typeclassName = (Text -> Text) -> Name -> Name
modifyName Text -> Text
typeclassNameMaker (Name -> Name
dropQualified Name
name)
      functions :: [Dec]
functions = (VarBangType -> Dec) -> [VarBangType] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> VarBangType -> Dec
makeFunctionDeclaration Text -> Text
functionNameMaker) [VarBangType]
types
   in [Cxt -> Name -> [TyVarBndr ()] -> [FunDep] -> [Dec] -> Dec
ClassD [] Name
typeclassName [TyVarBndr ()]
typeVars [] [Dec]
functions]

-- | Create an instance definition using a ReaderT instance
--     instance WithLogger (ReaderT (Logger m) m) where ...
#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)
createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr BndrVis] -> [VarBangType] -> DecsQ
createReadertInstance typeclassNameMaker functionNameMaker name [tvar] types =
  let tvarName = case tvar of PlainTV v _ -> v; KindedTV v _ _ -> v
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr ()] -> [VarBangType] -> DecsQ
createReadertInstance :: (Text -> Text)
-> (Text -> Text)
-> Name
-> [TyVarBndr ()]
-> [VarBangType]
-> DecsQ
createReadertInstance Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr ()
tvar] [VarBangType]
types =
  let tvarName :: Name
tvarName = case TyVarBndr ()
tvar of PlainTV Name
v ()
_ -> Name
v; KindedTV Name
v ()
_ Kind
_ -> Name
v
#else
createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ
createReadertInstance typeclassNameMaker functionNameMaker name [tvar] types =
  let tvarName = case tvar of PlainTV v -> v; KindedTV v _ -> v
#endif
      typeclassName :: Name
typeclassName = (Text -> Text) -> Name -> Name
modifyName Text -> Text
typeclassNameMaker (Name -> Name
dropQualified Name
name)
      functions :: [Dec]
functions = (VarBangType -> Dec) -> [VarBangType] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> Name -> VarBangType -> Dec
makeFunctionInstance Text -> Text
functionNameMaker (String -> Name
mkName String
"ReaderT")) [VarBangType]
types
      typeclassT :: Kind
typeclassT = Name -> Kind
ConT Name
typeclassName
      components :: Name
components = String -> Name
mkName String
"c"
      componentTypeT :: Kind
componentTypeT = Name -> Kind
ConT Name
name
      componentsTypeT :: Kind
componentsTypeT = Name -> Kind
VarT Name
components
      readerT :: Kind
readerT = Name -> Kind
ConT (String -> Name
mkName String
"ReaderT")
      hasTypeT :: Kind
hasTypeT = Name -> Kind
ConT (String -> Name
mkName String
"HasType")
      tvarT :: Kind
tvarT = Name -> Kind
VarT Name
tvarName
   in [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD
            Maybe Overlap
forall a. Maybe a
Nothing
            [Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
hasTypeT (Kind -> Kind -> Kind
AppT Kind
componentTypeT Kind
tvarT)) Kind
componentsTypeT]
            (Kind -> Kind -> Kind
AppT Kind
typeclassT (Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
readerT Kind
componentsTypeT) Kind
tvarT))
            [Dec]
functions
        ]
createReadertInstance Text -> Text
_ Text -> Text
_ Name
_ [TyVarBndr ()]
tvars [VarBangType]
_ = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only generate a instance for a component typeclass when it has only one type variable, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TyVarBndr ()] -> String
forall a b. (Show a, StringConv String b) => a -> b
show [TyVarBndr ()]
tvars)
  [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Make the function declaration of the typeclass based on the function name in the "record of functions"
makeFunctionDeclaration :: (Text -> Text) -> VarBangType -> Dec
makeFunctionDeclaration :: (Text -> Text) -> VarBangType -> Dec
makeFunctionDeclaration Text -> Text
functionNameMaker (Name
name, Bang
_, Kind
type') =
  Name -> Kind -> Dec
SigD ((Text -> Text) -> Name -> Name
modifyName Text -> Text
functionNameMaker (Name -> Name
dropQualified Name
name)) Kind
type'

-- | This produces: info p1 p2 = ReaderT (\component -> _info component p1 p2)
makeFunctionInstance :: (Text -> Text) -> Name -> VarBangType -> Dec
makeFunctionInstance :: (Text -> Text) -> Name -> VarBangType -> Dec
makeFunctionInstance Text -> Text
functionNameMaker Name
runnerName (Name
name, Bang
_, Kind
functionType) =
  let functionName :: Name
functionName = (Text -> Text) -> Name -> Name
modifyName Text -> Text
functionNameMaker (Name -> Name
dropQualified Name
name)
      readerT :: Exp
readerT = Name -> Exp
ConE Name
runnerName
      component :: Name
component = String -> Name
mkName String
"component"
      numberOfParameters :: Int
numberOfParameters = Kind -> Int
countNumberOfParameters Kind
functionType
      parameterNames :: [Name]
parameterNames = (\Int
i -> String -> Name
mkName (String
"p" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
show Int
i)) (Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 .. Int
numberOfParameters]
      parameters :: [Pat]
parameters = Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
parameterNames
      firstApplication :: Exp
firstApplication = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
name) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"getTyped")) (Name -> Exp
VarE Name
component))
      body :: Exp
body = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
r Name
p -> Exp -> Exp -> Exp
AppE Exp
r (Name -> Exp
VarE Name
p)) Exp
firstApplication [Name]
parameterNames
   in Name -> [Clause] -> Dec
FunD Name
functionName [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
parameters (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE Exp
readerT ([Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
component] Exp
body))) []]

-- | count the number of parameters for a function type
countNumberOfParameters :: Type -> Int
countNumberOfParameters :: Kind -> Int
countNumberOfParameters (ForallT [TyVarBndr Specificity]
_ Cxt
_ Kind
t) = Kind -> Int
countNumberOfParameters Kind
t
countNumberOfParameters (AppT (AppT Kind
ArrowT Kind
_) Kind
t) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Kind -> Int
countNumberOfParameters Kind
t
countNumberOfParameters Kind
_ = Int
0

-- | Modify a template haskell name
modifyName :: (Text -> Text) -> Name -> Name
modifyName :: (Text -> Text) -> Name -> Name
modifyName Text -> Text
f Name
n = String -> Name
mkName (Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> (Name -> Text) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
f (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name
n)

-- | Remove the module name from a qualified name
dropQualified :: Name -> Name
dropQualified :: Name -> Name
dropQualified Name
name = Name -> (Text -> Name) -> Maybe Text -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
name (String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertText a b => a -> b
toS) ([Text] -> Maybe Text
forall a. [a] -> Maybe a
lastMay (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." (Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Name
name)))